diff --git a/.gitignore b/.gitignore index 93b996f..b3d841a 100644 --- a/.gitignore +++ b/.gitignore @@ -15,6 +15,7 @@ cabal.sandbox.config *.aux *.hp *.eventlog +*.orig .DS_Store .stack-work/ .vscode/ diff --git a/Rome.cabal b/Rome.cabal index f7dca4a..2cb8dd7 100644 --- a/Rome.cabal +++ b/Rome.cabal @@ -1,5 +1,5 @@ name: Rome -version: 0.20.0.56 +version: 0.21.0.57 synopsis: A cache for Carthage description: Please see README.md homepage: https://github.com/blender/Rome @@ -26,7 +26,6 @@ library , Data.Carthage.Common , Data.Carthage.VersionFile , Data.Romefile - , Data.S3Config , Text.Parsec.Utils , Xcode.DWARF , Caches.S3.Probing @@ -36,11 +35,13 @@ library , Caches.Local.Uploading , Caches.Local.Downloading , Caches.Common + , Network.AWS.Utils build-depends: base >= 4.7 && < 5 , amazonka >= 1.6.1 , amazonka-core >= 1.6.1 , amazonka-s3 >= 1.6.1 + , amazonka-sts >= 1.6.1 , exceptions >= 0.8 , lens >= 4.13 , parsec >= 3.1.10 diff --git a/Rome.podspec b/Rome.podspec index fe51d40..7efd893 100644 --- a/Rome.podspec +++ b/Rome.podspec @@ -1,6 +1,6 @@ Pod::Spec.new do |s| s.name = 'Rome' - s.version = '0.20.0.56' + s.version = '0.21.0.57' s.summary = 'A cache tool for Carthage' s.homepage = 'https://github.com/blender/Rome' s.source = { :http => "#{s.homepage}/releases/download/v#{s.version}/rome.zip" } diff --git a/app/Main.hs b/app/Main.hs index f2fd898..fe86265 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -10,7 +10,7 @@ import System.Exit romeVersion :: RomeVersion -romeVersion = (0, 20, 0, 56) +romeVersion = (0, 21, 0, 57) diff --git a/src/Configuration.hs b/src/Configuration.hs index 6624129..0bd5071 100644 --- a/src/Configuration.hs +++ b/src/Configuration.hs @@ -32,10 +32,14 @@ getRomefileEntries absoluteRomefilePath = in withExceptT toErr $ fromYaml <|> fromIni where toErr e = "Error while parsing " <> absoluteRomefilePath <> ": " <> e -getS3ConfigFile :: MonadIO m => m FilePath -getS3ConfigFile = ( awsConfigFilePath) `liftM` liftIO getHomeDirectory +getAWSConfigFilePath :: MonadIO m => m FilePath +getAWSConfigFilePath = ( awsConfigFilePath) `liftM` liftIO getHomeDirectory where awsConfigFilePath = ".aws/config" +getAWSCredentialsFilePath:: MonadIO m => m FilePath +getAWSCredentialsFilePath = ( awsCredentialsFilePath) `liftM` liftIO getHomeDirectory + where awsCredentialsFilePath = ".aws/credentials" + carthageBuildDirectory :: FilePath carthageBuildDirectory = "Carthage" "Build" diff --git a/src/Data/Romefile.hs b/src/Data/Romefile.hs index 704fb4c..5c447c8 100644 --- a/src/Data/Romefile.hs +++ b/src/Data/Romefile.hs @@ -19,6 +19,7 @@ module Data.Romefile , cacheInfo , bucket , localCacheDir + , enginePath , frameworkName , frameworkType , FrameworkType (..) @@ -174,7 +175,8 @@ cacheInfo :: Lens' Romefile RomeCacheInfo cacheInfo = lens _cacheInfo (\parseResult n -> parseResult { _cacheInfo = n }) data RomeCacheInfo = RomeCacheInfo { _bucket :: Maybe T.Text - , _localCacheDir :: Maybe FilePath -- relative path + , _localCacheDir :: Maybe FilePath -- relative or absolue path + , _enginePath :: Maybe FilePath -- relative or absolue path } deriving (Eq, Show, Generic) @@ -182,11 +184,14 @@ instance FromJSON RomeCacheInfo where parseJSON = withObject "RomeCacheInfo" $ \v -> RomeCacheInfo <$> v .:? "s3Bucket" <*> v .:? "local" + <*> v .:? "engine" instance ToJSON RomeCacheInfo where - toJSON (RomeCacheInfo b l) = object fields + toJSON (RomeCacheInfo b l e) = object fields where - fields = [T.pack "s3Bucket" .= b | isJust b] ++ [T.pack "local" .= l | isJust l] + fields = [T.pack "s3Bucket" .= b | isJust b] + ++ [T.pack "local" .= l | isJust l] + ++ [T.pack "engine" .= e| isJust e] bucket :: Lens' RomeCacheInfo (Maybe T.Text) bucket = lens _bucket (\cInfo n -> cInfo { _bucket = n }) @@ -194,6 +199,9 @@ bucket = lens _bucket (\cInfo n -> cInfo { _bucket = n }) localCacheDir :: Lens' RomeCacheInfo (Maybe FilePath) localCacheDir = lens _localCacheDir (\cInfo n -> cInfo { _localCacheDir = n }) +enginePath :: Lens' RomeCacheInfo (Maybe FilePath) +enginePath = lens _enginePath (\cInfo n -> cInfo { _enginePath = n }) + -- |The canonical name of the Romefile canonicalRomefileName :: String canonicalRomefileName = "Romefile" @@ -226,6 +234,7 @@ toRomefile :: INI.Ini -> Either T.Text Romefile toRomefile ini = do _bucket <- getBucket ini _localCacheDir <- getLocalCacheDir ini + let _engine = Nothing -- Engines are not supported in INI let _repositoryMapEntries = getRepositoryMapEntries ini _ignoreMapEntries = getIgnoreMapEntries ini _cacheInfo = RomeCacheInfo {..} diff --git a/src/Data/S3Config.hs b/src/Data/S3Config.hs deleted file mode 100644 index b560a00..0000000 --- a/src/Data/S3Config.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Data.S3Config - ( S3Config - , parseS3Config - , regionOf - , endPointOf - ) where - --- For now, only very little information needs to be extracted from the S3 --- config file, but extracting it into a separate module is consistent with --- `Data.Romefile` and `Data.Carthage` and avoids dealing with the raw INI --- file representation (String-keyed hashmaps) in the main logic. - -import Control.Monad ((<=<)) -import Data.Either.Utils (maybeToEither) -import Data.Ini (Ini, lookupValue, parseIni) -import qualified Data.Text as T (Text, null, unpack) -import qualified Network.AWS as AWS -import qualified Network.AWS.Data as AWS -import Network.URL - -newtype S3Config = S3Config { _ini :: Ini } - -regionOf :: T.Text -> S3Config -> Either String AWS.Region -regionOf profile = parseRegion <=< lookupValue profile "region" . _ini - where - parseRegion s = if T.null s --- better error message - then Left "Failed reading: Failure parsing Region from empty string" - else AWS.fromText s - -endPointOf :: T.Text -> S3Config -> Either String URL -endPointOf profile = parseURL <=< lookupValue profile "endpoint" . _ini - where - parseURL s = if T.null s - then Left "Failed reading: Failure parsing Endpoint from empty string" - else - maybeToEither "Failed reading: Endpoint is not a valid URL" - $ importURL - . T.unpack - $ s - -parseS3Config :: T.Text -> Either String S3Config -parseS3Config = fmap S3Config . parseIni diff --git a/src/Lib.hs b/src/Lib.hs index 5fb3d70..b37e8ea 100644 --- a/src/Lib.hs +++ b/src/Lib.hs @@ -30,18 +30,27 @@ import Control.Monad.Trans.Maybe (exceptToMaybeT, runMaybeT) import qualified Data.ByteString.Char8 as BS (pack) import qualified Data.ByteString.Lazy as LBS import Data.Yaml (encodeFile) +import Data.IORef (newIORef) import Data.Carthage.Cartfile import Data.Carthage.TargetPlatform -import Data.Either.Extra (maybeToEither) +import Data.Either.Extra (maybeToEither, eitherToMaybe, isRight, mapLeft) +import Data.Either.Utils (fromLeft) import Data.Maybe (fromMaybe, maybe) import Data.Monoid ((<>)) import Data.Romefile import qualified Data.Map.Strict as M (empty) -import qualified Data.S3Config as S3Config import qualified Data.Text as T +import qualified Data.Text.Encoding as T (encodeUtf8) import qualified Network.AWS as AWS +import qualified Network.AWS.Auth as AWS (fromEnv) +import qualified Network.AWS.Env as AWS (Env (..), retryConnectionFailure) import qualified Network.AWS.Data as AWS (fromText) +import qualified Network.AWS.Data.Sensitive as AWS (Sensitive (..)) import qualified Network.AWS.S3 as S3 +import qualified Network.AWS.STS.AssumeRole as STS (assumeRole, arrsCredentials) +import qualified Network.AWS.Utils as AWS +import qualified Network.HTTP.Conduit as Conduit + import Network.URL import System.Directory import System.Environment @@ -51,6 +60,12 @@ import Types.Commands as Commands import Utils import Xcode.DWARF +-- # TODO: clean up + +import qualified Codec.Archive.Zip as Zip + +-- # + s3EndpointOverride :: URL -> AWS.Service @@ -64,6 +79,79 @@ s3EndpointOverride (URL (Absolute h) _ _) = S3.s3 s3EndpointOverride _ = S3.s3 +-- | Tries to get authentication details and region to perform +-- | requests to AWS. +-- | The `AWS_PROFILE` is read from the environment +-- | or falls back to `default`. +-- | The `AWS_REGION` is first read from the environment, if not found +-- | it is read from `~/.aws/config` based on the profile discovered in the previous step. +-- | The `AWS_ACCESS_KEY_ID` & `AWS_SECRET_ACCESS_KEY` are first +-- | read from the environment. If not found, then the `~/.aws/crendetilas` +-- | file is read. If `source_profile` key is present the reading of the +-- | authentication details happens from this profile rather then the `AWS_PROFILE`. +-- | Finally, if `role_arn` is specified, the crendials gathered up to now are used +-- | to obtain new credentials with STS esclated to `role_arn`. +getAWSEnv :: (MonadIO m, MonadCatch m) => ExceptT String m AWS.Env +getAWSEnv = do + region <- discoverRegion + endpointURL <- runMaybeT . exceptToMaybeT $ discoverEndpoint + profile <- T.pack . fromMaybe "default" <$> liftIO + (lookupEnv (T.unpack "AWS_PROFILE")) + credentials <- + runExceptT $ AWS.credentialsFromFile =<< getAWSCredentialsFilePath + (auth, _) <- + AWS.catching AWS._MissingEnvError AWS.fromEnv $ \envError -> either + throwError + (\cred -> do + let finalProfile = fromMaybe + profile + (eitherToMaybe $ AWS.sourceProfileOf profile =<< credentials) + let + authAndRegion = + (,) + <$> mapLeft + (\e -> + T.unpack envError + ++ ". " + ++ e + ++ " in file ~/.aws/credentilas" + ) + (AWS.authFromCredentilas finalProfile =<< credentials) + <*> pure (pure region) + liftEither authAndRegion + ) + credentials + manager <- liftIO (Conduit.newManager Conduit.tlsManagerSettings) + ref <- liftIO (newIORef Nothing) + let roleARN = eitherToMaybe $ AWS.roleARNOf profile =<< credentials + let curerntEnv = AWS.Env region + (\_ _ -> pure ()) + (AWS.retryConnectionFailure 3) + mempty + manager + ref + auth + case roleARN of + Just role -> newEnvFromRole role curerntEnv + Nothing -> return + $ AWS.configure (maybe S3.s3 s3EndpointOverride endpointURL) curerntEnv + +newEnvFromRole :: MonadIO m => T.Text -> AWS.Env -> ExceptT String m AWS.Env +newEnvFromRole roleARN currentEnv = do + assumeRoleResult <- + liftIO + $ AWS.runResourceT + . AWS.runAWS currentEnv + $ AWS.send + $ STS.assumeRole roleARN "rome-cache-operation" + let maybeAuth = AWS.Auth <$> assumeRoleResult ^. STS.arrsCredentials + case maybeAuth of + Nothing -> + throwError + $ "Could not create AWS Auth from STS response: " + ++ show assumeRoleResult + Just newAuth -> return $ currentEnv & AWS.envAuth .~ newAuth + getAWSRegion :: (MonadIO m, MonadCatch m) => ExceptT String m AWS.Env getAWSRegion = do region <- discoverRegion @@ -73,18 +161,23 @@ getAWSRegion = do <&> AWS.configure (maybe S3.s3 s3EndpointOverride endpointURL) ) -bothCacheKeysMissingMessage :: String -bothCacheKeysMissingMessage - = "Error: expected at least one of \"local\" or \ - \\"S3-Bucket\" key in the [Cache] section of your Romefile." +allCacheKeysMissingMessage :: String +allCacheKeysMissingMessage + = "Error: expected at least one of \"local\", \ + \\"s3Bucket\" or \"engine\" in the cache definition of your Romefile." + +conflictingCachesMessage :: String +conflictingCachesMessage + = "Error: both \"s3Bucket\" and \"engine\" defined. \ + \ Rome cannot use both, choose one." conflictingSkipLocalCacheOptionMessage :: String conflictingSkipLocalCacheOptionMessage - = "Error: only \"local\" key is present \ - \in the [Cache] section of your Romefile but you have asked Rome to skip \ + = "Error: only \"local\" defined as cache\ + \in your Romefile, but you have asked Rome to skip \ \this cache." --- | Runs Rome with `RomeOptions` on a given a `AWS.Env`. +-- | Runs Rome with a set of `RomeOptions`. runRomeWithOptions :: RomeOptions -- ^ The `RomeOptions` to run Rome with. -> RomeVersion @@ -121,7 +214,8 @@ runUDCCommand command absoluteRomefilePath verbose romeVersion = do let cInfo = romeFile ^. cacheInfo let mS3BucketName = S3.BucketName <$> cInfo ^. bucket - mlCacheDir <- liftIO $ traverse absolutizePath $ cInfo ^. localCacheDir + mlCacheDir <- liftIO $ traverse absolutizePath $ cInfo ^. localCacheDir + mEnginePath <- liftIO $ traverse absolutizePath $ cInfo ^. enginePath case command of @@ -140,6 +234,7 @@ runUDCCommand command absoluteRomefilePath verbose romeVersion = do cartfileEntries cachePrefixString mS3BucketName + mEnginePath mlCacheDir platforms @@ -159,6 +254,7 @@ runUDCCommand command absoluteRomefilePath verbose romeVersion = do cachePrefixString mS3BucketName mlCacheDir + mEnginePath platforms List (RomeListPayload listMode platforms cachePrefixString printFormat noIgnoreFlag noSkipCurrentFlag) @@ -199,6 +295,7 @@ runUDCCommand command absoluteRomefilePath verbose romeVersion = do (listArtifacts mS3BucketName mlCacheDir + mEnginePath listMode (reverseRepositoryMap <> if _noSkipCurrent noSkipCurrentFlag then currentInvertedMap @@ -233,8 +330,15 @@ runUDCCommand command absoluteRomefilePath verbose romeVersion = do <> romeVersionToString vers <> noColorControlSequence + -- case (mS3BucketName, mEnginePath) of + -- (Nothing, Nothing) -> undefined -- Proceed donw regular path + -- (Just _, Nothing) -> undefined -- Proceed donw regular path + -- (Just b , Just e) -> throwError $ "Cannot specify both bucket \"" ++ show b ++ "\" and engine at " ++ e ++ " at the same time." + -- (Nothing, Just e) -> undefined -- run command with all info + type FlowFunction = Maybe S3.BucketName -- ^ Just an S3 Bucket name or Nothing -> Maybe FilePath -- ^ Just the path to the local cache or Nothing + -> Maybe FilePath -- ^ Just the path to the engine or Nothing -> InvertedRepositoryMap -- ^ The map used to resolve `FrameworkName`s to `ProjectName`s. -> [FrameworkVersion] -- ^ A list of `FrameworkVersion` from which to derive Frameworks, dSYMs and .version files -> [TargetPlatform] -- ^ A list of `TargetPlatform` to restrict this operation to. @@ -259,9 +363,10 @@ performWithDefaultFlow -> String -- cachePrefixString -> Maybe S3.BucketName -- mS3BucketName -> Maybe String -- mlCacheDir + -> Maybe String -- mEnginePath -> [TargetPlatform] -- platforms -> RomeMonad () -performWithDefaultFlow flowFunc (verbose, noIgnoreFlag, skipLocalCache, noSkipCurrentFlag, concurrentlyFlag) (repositoryMapEntries, ignoreMapEntries, currentMapEntries) gitRepoNames cartfileEntries cachePrefixString mS3BucketName mlCacheDir platforms +performWithDefaultFlow flowFunc (verbose, noIgnoreFlag, skipLocalCache, noSkipCurrentFlag, concurrentlyFlag) (repositoryMapEntries, ignoreMapEntries, currentMapEntries) gitRepoNames cartfileEntries cachePrefixString mS3BucketName mlCacheDir mEnginePath platforms = do let ignoreFrameworks = concatMap _frameworks ignoreMapEntries @@ -292,6 +397,7 @@ performWithDefaultFlow flowFunc (verbose, noIgnoreFlag, skipLocalCache, noSkipCu (flowFunc mS3BucketName mlCacheDir + mEnginePath reverseRepositoryMap (derivedFrameworkVersions `filterOutFrameworksAndVersionsIfNotIn` finalIgnoreNames @@ -315,6 +421,7 @@ performWithDefaultFlow flowFunc (verbose, noIgnoreFlag, skipLocalCache, noSkipCu (flowFunc mS3BucketName mlCacheDir + mEnginePath currentInvertedMap (currentFrameworkVersions `filterOutFrameworksAndVersionsIfNotIn` finalIgnoreNames @@ -346,6 +453,7 @@ performWithDefaultFlow flowFunc (verbose, noIgnoreFlag, skipLocalCache, noSkipCu runReaderT (flowFunc mS3BucketName mlCacheDir + mEnginePath (reverseRepositoryMap <> currentInvertedMap) frameworkVersions platforms @@ -356,6 +464,7 @@ performWithDefaultFlow flowFunc (verbose, noIgnoreFlag, skipLocalCache, noSkipCu listArtifacts :: Maybe S3.BucketName -- ^ Just an S3 Bucket name or Nothing -> Maybe FilePath -- ^ Just the path to the local cache or Nothing + -> Maybe FilePath -- ^ Just the path to the engine or Nothing -> ListMode -- ^ A list mode to execute this operation in. -> InvertedRepositoryMap -- ^ The map used to resolve `FrameworkName`s to `ProjectName`s. -> [FrameworkVersion] -- ^ A list of `FrameworkVersion` from which to derive Frameworks @@ -365,13 +474,14 @@ listArtifacts (CachePrefix, SkipLocalCacheFlag, Bool) RomeMonad () -listArtifacts mS3BucketName mlCacheDir listMode reverseRepositoryMap frameworkVersions platforms format +listArtifacts mS3BucketName mlCacheDir mEnginePath listMode reverseRepositoryMap frameworkVersions platforms format = do (_, _, verbose) <- ask let sayFunc = if verbose then sayLnWithTime else sayLn repoAvailabilities <- getProjectAvailabilityFromCaches mS3BucketName mlCacheDir + mEnginePath reverseRepositoryMap frameworkVersions platforms @@ -389,6 +499,7 @@ listArtifacts mS3BucketName mlCacheDir listMode reverseRepositoryMap frameworkVe getProjectAvailabilityFromCaches :: Maybe S3.BucketName -- ^ Just an S3 Bucket name or Nothing -> Maybe FilePath -- ^ Just the path to the local cache or Nothing + -> Maybe FilePath -- ^ Just the path to the engine or Nothing -> InvertedRepositoryMap -- ^ The map used to resolve `FrameworkName`s to `ProjectName`s. -> [FrameworkVersion] -- ^ A list of `FrameworkVersion` from which to derive Frameworks, dSYMs and .version files -> [TargetPlatform] -- ^ A list of `TargetPlatform`s to limit the operation to. @@ -396,9 +507,9 @@ getProjectAvailabilityFromCaches (CachePrefix, SkipLocalCacheFlag, Bool) RomeMonad [ProjectAvailability] -getProjectAvailabilityFromCaches (Just s3BucketName) _ reverseRepositoryMap frameworkVersions platforms +getProjectAvailabilityFromCaches (Just s3BucketName) _ Nothing reverseRepositoryMap frameworkVersions platforms = do - env <- lift getAWSRegion + env <- lift getAWSEnv (cachePrefix, _, verbose) <- ask let readerEnv = (env, cachePrefix, verbose) availabilities <- liftIO $ runReaderT @@ -412,7 +523,7 @@ getProjectAvailabilityFromCaches (Just s3BucketName) _ reverseRepositoryMap fram reverseRepositoryMap availabilities -getProjectAvailabilityFromCaches Nothing (Just lCacheDir) reverseRepositoryMap frameworkVersions platforms +getProjectAvailabilityFromCaches Nothing (Just lCacheDir) Nothing reverseRepositoryMap frameworkVersions platforms = do (cachePrefix, SkipLocalCacheFlag skipLocalCache, _) <- ask when skipLocalCache $ throwError conflictingSkipLocalCacheOptionMessage @@ -426,8 +537,13 @@ getProjectAvailabilityFromCaches Nothing (Just lCacheDir) reverseRepositoryMap f reverseRepositoryMap availabilities -getProjectAvailabilityFromCaches Nothing Nothing _ _ _ = - throwError bothCacheKeysMissingMessage +getProjectAvailabilityFromCaches Nothing lCacheDir (Just ePath) _ _ _ = + undefined-- runEngineList ePath lCacheDir reverseRepositoryMap frameworkVersions platforms +getProjectAvailabilityFromCaches (Just _) _ (Just _) _ _ _ = + throwError conflictingCachesMessage +getProjectAvailabilityFromCaches Nothing Nothing Nothing _ _ _ = + throwError allCacheKeysMissingMessage + @@ -435,14 +551,19 @@ getProjectAvailabilityFromCaches Nothing Nothing _ _ _ = downloadArtifacts :: Maybe S3.BucketName -- ^ Just an S3 Bucket name or Nothing -> Maybe FilePath -- ^ Just the path to the local cache or Nothing + -> Maybe FilePath -- ^ Just the path to the engine or Nothing -> InvertedRepositoryMap -- ^ The map used to resolve `FrameworkName`s to `ProjectName`s. -> [FrameworkVersion] -- ^ A list of `FrameworkVersion` from which to derive Frameworks, dSYMs and .version files -> [TargetPlatform] -- ^ A list of `TargetPlatform`s to limit the operation to. -> ReaderT - (CachePrefix, SkipLocalCacheFlag, ConcurrentlyFlag, Bool) + ( CachePrefix + , SkipLocalCacheFlag + , ConcurrentlyFlag + , Bool + ) RomeMonad () -downloadArtifacts mS3BucketName mlCacheDir reverseRepositoryMap frameworkVersions platforms +downloadArtifacts mS3BucketName mlCacheDir mEnginePath reverseRepositoryMap frameworkVersions platforms = do (cachePrefix, skipLocalCacheFlag@(SkipLocalCacheFlag skipLocalCache), conconrrentlyFlag@(ConcurrentlyFlag performConcurrently), verbose) <- ask @@ -450,10 +571,10 @@ downloadArtifacts mS3BucketName mlCacheDir reverseRepositoryMap frameworkVersion let sayFunc :: MonadIO m => String -> m () sayFunc = if verbose then sayLnWithTime else sayLn - case (mS3BucketName, mlCacheDir) of + case (mS3BucketName, mlCacheDir, mEnginePath) of - (Just s3BucketName, lCacheDir) -> do - env <- lift getAWSRegion + (Just s3BucketName, lCacheDir, Nothing) -> do + env <- lift getAWSEnv let uploadDownloadEnv = (env, cachePrefix, skipLocalCacheFlag, conconrrentlyFlag, verbose) let action1 = runReaderT @@ -474,7 +595,7 @@ downloadArtifacts mS3BucketName mlCacheDir reverseRepositoryMap frameworkVersion then liftIO $ concurrently_ action1 action2 else liftIO $ action1 >> action2 - (Nothing, Just lCacheDir) -> do + (Nothing, Just lCacheDir, Nothing) -> do let readerEnv = (cachePrefix, verbose) when skipLocalCache $ throwError conflictingSkipLocalCacheOptionMessage @@ -500,8 +621,12 @@ downloadArtifacts mS3BucketName mlCacheDir reverseRepositoryMap frameworkVersion mapM_ (whenLeft sayFunc) errors ) readerEnv - - (Nothing, Nothing) -> throwError bothCacheKeysMissingMessage + -- Use engine + (Nothing, lCacheDir, Just ePath) -> undefined + -- Misconfigured + (Nothing, Nothing, Nothing) -> throwError allCacheKeysMissingMessage + -- Misconfigured + (Just s3BucketName, _, Just ePath) -> throwError conflictingCachesMessage where gitRepoNamesAndVersions :: [ProjectNameAndVersion] @@ -515,20 +640,26 @@ downloadArtifacts mS3BucketName mlCacheDir reverseRepositoryMap frameworkVersion uploadArtifacts :: Maybe S3.BucketName -- ^ Just an S3 Bucket name or Nothing -> Maybe FilePath -- ^ Just the path to the local cache or Nothing + -> Maybe FilePath -- ^ Just the path to the engine or Nothing -> InvertedRepositoryMap -- ^ The map used to resolve `FrameworkName`s to `ProjectName`s. -> [FrameworkVersion] -- ^ A list of `FrameworkVersion` from which to derive Frameworks, dSYMs and .version files -> [TargetPlatform] -- ^ A list of `TargetPlatform` to restrict this operation to. -> ReaderT - (CachePrefix, SkipLocalCacheFlag, ConcurrentlyFlag, Bool) + ( CachePrefix + , SkipLocalCacheFlag + , ConcurrentlyFlag + , Bool + ) RomeMonad () -uploadArtifacts mS3BucketName mlCacheDir reverseRepositoryMap frameworkVersions platforms +uploadArtifacts mS3BucketName mlCacheDir mEnginePath reverseRepositoryMap frameworkVersions platforms = do (cachePrefix, skipLocalCacheFlag@(SkipLocalCacheFlag skipLocalCache), concurrentlyFlag@(ConcurrentlyFlag performConcurrently), verbose) <- ask - case (mS3BucketName, mlCacheDir) of - (Just s3BucketName, lCacheDir) -> do - awsEnv <- lift getAWSRegion + case (mS3BucketName, mlCacheDir, mEnginePath) of + -- S3 Cache, but no engine + (Just s3BucketName, lCacheDir, Nothing) -> do + awsEnv <- lift getAWSEnv let uploadDownloadEnv = ( awsEnv , cachePrefix @@ -553,8 +684,8 @@ uploadArtifacts mS3BucketName mlCacheDir reverseRepositoryMap frameworkVersions if performConcurrently then liftIO $ concurrently_ action1 action2 else liftIO $ action1 >> action2 - - (Nothing, Just lCacheDir) -> do + -- No remotes, just local + (Nothing, Just lCacheDir, Nothing) -> do let readerEnv = (cachePrefix, verbose) when skipLocalCache $ throwError conflictingSkipLocalCacheOptionMessage liftIO @@ -569,7 +700,7 @@ uploadArtifacts mS3BucketName mlCacheDir reverseRepositoryMap frameworkVersions (saveVersionFilesToLocalCache lCacheDir gitRepoNamesAndVersions) readerEnv - (Nothing, Nothing) -> throwError bothCacheKeysMissingMessage + (Nothing, Nothing, Nothing) -> throwError allCacheKeysMissingMessage where gitRepoNamesAndVersions :: [ProjectNameAndVersion] gitRepoNamesAndVersions = repoNamesAndVersionForFrameworkVersions @@ -836,6 +967,66 @@ saveFrameworkAndArtifactsToLocalCache lCacheDir reverseRomeMap fVersion@(Framewo + +uploadFrameworksAndArtifactsWithEngine + :: FilePath -- ^ The path to the engine or Nothing + -> Maybe FilePath -- ^ Just the path to the local cache or Nothing + -> InvertedRepositoryMap -- ^ The map used to resolve `FrameworkName`s to `ProjectName`s. + -> [FrameworkVersion] -- ^ A list of `FrameworkVersion` from which to derive Frameworks, dSYMs and .verison files + -> [TargetPlatform] -- ^ A list of `TargetPlatform` to restrict this operation to. + -> ReaderT (CachePrefix, SkipLocalCacheFlag, Bool) RomeMonad () +uploadFrameworksAndArtifactsWithEngine engine mlCacheDir reverseRomeMap fvs = + mapM_ (sequence . upload) + where + upload = mapM + (uploadFrameworkAndArtifactsWithEngine engine mlCacheDir reverseRomeMap) + fvs + + +uploadFrameworkAndArtifactsWithEngine + :: FilePath -- ^ The path to the engine or Nothing + -> Maybe FilePath -- ^ Just the path to the local cache or Nothing + -> InvertedRepositoryMap -- ^ The map used to resolve `FrameworkName`s to `ProjectName`s. + -> FrameworkVersion -- ^ A`FrameworkVersion` from which to derive Frameworks, dSYMs and .verison files + -> TargetPlatform -- ^ A `TargetPlatform` to restrict this operation to. + -> ReaderT (CachePrefix, SkipLocalCacheFlag, Bool) RomeMonad () +uploadFrameworkAndArtifactsWithEngine engine mlCacheDir reverseRomeMap fVersion@(FrameworkVersion f@(Framework fwn fwt fwps) _) platform + = do + (cachePrefix, s@(SkipLocalCacheFlag skipLocalCache), verbose) <- ask + void . runExceptT $ do + frameworkArchive <- createZipArchive frameworkDirectory verbose + unless skipLocalCache + $ maybe (return ()) liftIO + $ runReaderT + <$> ( saveFrameworkToLocalCache + <$> mlCacheDir + <*> Just frameworkArchive + <*> Just reverseRomeMap + <*> Just fVersion + <*> Just platform + ) + <*> Just (cachePrefix, s, verbose) + + liftIO $ saveBinaryToFile + (Zip.fromArchive frameworkArchive) + ("/tmp/" <> frameworkNameWithFrameworkExtension <> ".zip") + + -- (env, cachePrefix, s@(SkipLocalCacheFlag skipLocalCache), verbose) <- ask + + -- let uploadDownloadEnv = (env, cachePrefix, verbose) + + -- void . runExceptT $ do + -- frameworkArchive <- createZipArchive frameworkDirectory verbose + where + frameworkNameWithFrameworkExtension = appendFrameworkExtensionTo f + platformBuildDirectory = + carthageArtifactsBuildDirectoryForPlatform platform f + frameworkDirectory = + platformBuildDirectory frameworkNameWithFrameworkExtension + dSYMNameWithDSYMExtension = frameworkNameWithFrameworkExtension <> ".dSYM" + dSYMdirectory = platformBuildDirectory dSYMNameWithDSYMExtension + bcSybolMapPath d = platformBuildDirectory bcsymbolmapNameFrom d + -- | Downloads a list of .version files from an S3 Bucket or a local cache. downloadVersionFilesFromCaches :: S3.BucketName -- ^ The cache definition. @@ -1195,7 +1386,9 @@ discoverRegion = do let eitherEnvRegion = ExceptT . return $ envRegion >>= AWS.fromText . T.pack let eitherFileRegion = - (getS3ConfigFile >>= flip getRegionFromFile (fromMaybe "default" profile)) + ( getAWSConfigFilePath + >>= flip getRegionFromFile (fromMaybe "default" profile) + ) `catch` \(e :: IOError) -> ExceptT . return . Left . show $ e eitherEnvRegion <|> eitherFileRegion @@ -1207,9 +1400,10 @@ getRegionFromFile => FilePath -- ^ The path to the file containing the `AWS.Region` -> String -- ^ The name of the profile to use -> ExceptT String m AWS.Region -getRegionFromFile f profile = fromFile f $ \file -> ExceptT . return $ do - config <- S3Config.parseS3Config file - S3Config.regionOf (T.pack profile) config +getRegionFromFile f profile = + fromFile f $ \fileContents -> ExceptT . return $ do + config <- AWS.parseConfigFile fileContents + AWS.regionOf (T.pack profile) config @@ -1225,12 +1419,11 @@ discoverEndpoint = do $ maybeString >>= importURL profile <- liftIO $ lookupEnv "AWS_PROFILE" - let - fileEndPointURL = - ( getS3ConfigFile - >>= flip getEndpointFromFile (fromMaybe "default" profile) - ) - `catch` \(e :: IOError) -> ExceptT . return . Left . show $ e + let fileEndPointURL = + ( getAWSConfigFilePath + >>= flip getEndpointFromFile (fromMaybe "default" profile) + ) + `catch` \(e :: IOError) -> ExceptT . return . Left . show $ e (ExceptT . return $ envEndpointURL) <|> fileEndPointURL @@ -1239,10 +1432,10 @@ discoverEndpoint = do -- | Reads an `URL` from a file for a given profile getEndpointFromFile :: MonadIO m - => FilePath -- ^ The path to the file containing the `AWS.Region` - -> String -- ^ The name of the profile to use + => String -- ^ The name of the profile to use + -> FilePath -- ^ The path to the file containing the `AWS.Region` -> ExceptT String m URL -getEndpointFromFile f profile = fromFile f $ \file -> ExceptT . return $ do - config <- S3Config.parseS3Config file - S3Config.endPointOf (T.pack profile) config - +getEndpointFromFile profile f = + fromFile f $ \fileContents -> ExceptT . return $ do + config <- AWS.parseConfigFile fileContents + AWS.endPointOf (T.pack profile) config diff --git a/src/Network/AWS/Utils.hs b/src/Network/AWS/Utils.hs new file mode 100644 index 0000000..65f3499 --- /dev/null +++ b/src/Network/AWS/Utils.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.AWS.Utils + ( ConfigFile + , credentialsFromFile + , authFromCredentilas + , parseConfigFile + , regionOf + , endPointOf + , sourceProfileOf + , accessKeyIdOf + , secretAccessKeyOf + , roleARNOf + ) where + +-- For now, only very little information needs to be extracted from the S3 +-- config file, but extracting it into a separate module is consistent with +-- `Data.Romefile` and `Data.Carthage` and avoids dealing with the raw INI +-- file representation (String-keyed hashmaps) in the main logic. + +import Control.Monad ((<=<)) +import Data.Either.Utils (maybeToEither) +import Data.Either.Extra (mapLeft) +import Data.Ini (Ini, lookupValue, parseIni) +import qualified Data.Text as T (Text, null, unpack) +import qualified Data.Text.Encoding as T (encodeUtf8) +import qualified Data.Text.IO as T (readFile) +import qualified Network.AWS as AWS +import qualified Network.AWS.Data as AWS +import qualified Network.AWS.Data.Sensitive as AWS (Sensitive (..)) +import Network.URL +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Except (ExceptT (..), withExceptT) + +newtype ConfigFile = ConfigFile { _awsConfigIni :: Ini } +newtype CredentialsFile = CredentialsFile { _awsCredentialsIni :: Ini } + +class FromIni a where + asIni :: a -> Ini + +instance FromIni ConfigFile where + asIni = _awsConfigIni + +instance FromIni CredentialsFile where + asIni = _awsCredentialsIni + +-- | Reads `CredentialsFile` from a file at a given path +credentialsFromFile + :: MonadIO m + => FilePath -- ^ The path to the file containing the credentials. Usually `~/.aws/credentials` + -> ExceptT String m CredentialsFile +credentialsFromFile filePath = do + file <- liftIO (T.readFile filePath) + withExceptT (("Could not parse " <> filePath <> ": ") <>) (action file) + where action a = ExceptT . return $ parseCredentialsFile a + +authFromCredentilas :: T.Text -> CredentialsFile -> Either String AWS.Auth +authFromCredentilas profile credentials = AWS.Auth <$> authEnv + where + accessKeyId = T.encodeUtf8 <$> accessKeyIdOf profile credentials + secretAccessKey = T.encodeUtf8 <$> secretAccessKeyOf profile credentials + authEnv = + AWS.AuthEnv + <$> (AWS.AccessKey <$> accessKeyId) + <*> (AWS.Sensitive . AWS.SecretKey <$> secretAccessKey) + <*> pure Nothing + <*> pure Nothing + +regionOf :: T.Text -> ConfigFile -> Either String AWS.Region +regionOf profile = parseRegion <=< lookupValue profile "region" . asIni + where + parseRegion s = if T.null s +-- better error message + then Left "Failed reading: Failure parsing Region from empty string" + else AWS.fromText s + +endPointOf :: T.Text -> ConfigFile -> Either String URL +endPointOf profile = parseURL <=< lookupValue profile "endpoint" . asIni + where + parseURL s = if T.null s + then Left "Failed reading: Failure parsing Endpoint from empty string" + else + maybeToEither "Failed reading: Endpoint is not a valid URL" + $ importURL + . T.unpack + $ s + +getPropertyFromCredentials + :: T.Text -> T.Text -> CredentialsFile -> Either String T.Text +getPropertyFromCredentials profile property = + lookupValue profile property . asIni + +sourceProfileOf :: T.Text -> CredentialsFile -> Either String T.Text +sourceProfileOf profile credFile = + getPropertyFromCredentials profile "source_profile" credFile + `withError` const (missingKeyError key profile) + where key = "source_profile" + +roleARNOf :: T.Text -> CredentialsFile -> Either String T.Text +roleARNOf profile credFile = getPropertyFromCredentials profile key credFile + `withError` const (missingKeyError key profile) + where key = "role_arn" + +accessKeyIdOf :: T.Text -> CredentialsFile -> Either String T.Text +accessKeyIdOf profile credFile = + getPropertyFromCredentials profile key credFile + `withError` const (missingKeyError key profile) + where key = "aws_access_key_id" + +missingKeyError :: T.Text -> T.Text -> String +missingKeyError key profile = + "Could not find key `" + ++ T.unpack key + ++ "` for profile `" + ++ T.unpack profile + ++ "`" + +withError :: Either a b -> (a -> c) -> Either c b +withError = flip mapLeft + +secretAccessKeyOf :: T.Text -> CredentialsFile -> Either String T.Text +secretAccessKeyOf profile credFile = + getPropertyFromCredentials profile key credFile + `withError` const (missingKeyError key profile) + where key = "aws_secret_access_key" + +parseConfigFile :: T.Text -> Either String ConfigFile +parseConfigFile = fmap ConfigFile . parseIni + +parseCredentialsFile :: T.Text -> Either String CredentialsFile +parseCredentialsFile = fmap CredentialsFile . parseIni +