{-# LANGUAGE FlexibleContexts #-}

{-# LANGUAGE NamedFieldPuns #-}

{-# LANGUAGE OverloadedStrings #-}

{-# LANGUAGE ScopedTypeVariables #-}

module Lib (module Lib

, Types.RomeVersion

, Utils.romeVersionToString

)

where

import Caches.Common

import Caches.Local.Downloading

import Caches.Local.Probing

import Caches.Local.Uploading

import Caches.S3.Downloading

import Caches.S3.Probing

import Caches.S3.Uploading

import Engine.Downloading

import Engine.Probing

import Engine.Uploading

import Configuration

import Control.Applicative ((<|>))

import Control.Concurrent.Async.Lifted.Safe (mapConcurrently_, mapConcurrently, concurrently_)

import Control.Lens hiding (List)

import Control.Monad

import Control.Monad.Catch

import Control.Monad.Except

import Control.Monad.Reader (ReaderT, ask, runReaderT)

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, eitherToMaybe, mapLeft)

import Data.Maybe (fromMaybe, maybe)

import Data.Monoid ((<>))

import Data.Romefile

import qualified Data.Map.Strict as M (empty)

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

import System.FilePath

import Types

import Types.Commands as Commands

import Utils

import Xcode.DWARF

s3EndpointOverride :: URL -> AWS.Service

s3EndpointOverride (URL (Absolute h) _ _) =

let isSecure = secure h

host' = host h

port' = port h <|> if isSecure then Just 443 else Nothing

in AWS.setEndpoint isSecure

(BS.pack host')

(maybe 9000 fromInteger port')

S3.s3

s3EndpointOverride _ = S3.s3

-- | Tries to get authentication details and region to perform

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) `catch` \(e :: IOError) -> ExceptT . return . Left . show $ e

config <-

runExceptT $ (AWS.configFromFile =<< getAWSConfigFilePath) `catch` \(e :: IOError) -> ExceptT . return . Left . show $ e

(auth, _) <-

AWS.catching AWS._MissingEnvError AWS.fromEnv $ \envError -> either

throwError

(\cred -> do

let finalProfile = fromMaybe

profile

(eitherToMaybe $ AWS.sourceProfileOf profile =<< config)

let

authAndRegion =

(,)

<$> mapLeft

(\e ->

T.unpack envError

++ ". "

++ e

++ " in file ~/.aws/credentials"

)

(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 =<< config

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

endpointURL <- runMaybeT . exceptToMaybeT $ discoverEndpoint

set AWS.envRegion region

<$> ( AWS.newEnv AWS.Discover

<&> AWS.configure (maybe S3.s3 s3EndpointOverride endpointURL)

)

allCacheKeysMissingMessage :: String

allCacheKeysMissingMessage

= "Error: expected at least one of \"local\", \

conflictingCachesMessage :: String

conflictingCachesMessage

= "Error: both \"s3Bucket\" and \"engine\" defined. \

conflictingSkipLocalCacheOptionMessage :: String

conflictingSkipLocalCacheOptionMessage

= "Error: only \"local\" defined as cache \

-- | Runs Rome with a set of `RomeOptions`.

runRomeWithOptions

:: RomeOptions -- ^ The `RomeOptions` to run Rome with.

-> RomeVersion

-> RomeMonad ()

runRomeWithOptions (RomeOptions options romefilePath verbose) romeVersion = do

absoluteRomefilePath <- liftIO $ absolutizePath romefilePath

case options of

Utils _ ->

runUtilsCommand options absoluteRomefilePath verbose romeVersion

_ ->

runUDCCommand options absoluteRomefilePath verbose romeVersion

-- | Runs one of the Utility commands

runUtilsCommand

:: RomeCommand -> FilePath -> Bool -> RomeVersion -> RomeMonad ()

runUtilsCommand command absoluteRomefilePath _ _ =

case command of

Utils _ -> do

romeFileEntries <- getRomefileEntries absoluteRomefilePath

lift $ encodeFile absoluteRomefilePath romeFileEntries

_ -> throwError "Error: Programming Error. Only Utils command supported."

-- | Runs a command containing a `UDCPayload`

runUDCCommand :: RomeCommand -> FilePath -> Bool -> RomeVersion -> RomeMonad ()

runUDCCommand command absoluteRomefilePath verbose romeVersion = do

cartfileEntries <- getCartfileEntries

`catch` \(_ :: IOError) -> ExceptT . return $ Right []

romeFile <- getRomefileEntries absoluteRomefilePath

let ignoreMapEntries = _ignoreMapEntries romeFile

let currentMapEntries = _currentMapEntries romeFile

let repositoryMapEntries = _repositoryMapEntries romeFile

let ignoreFrameworks = concatMap _frameworks ignoreMapEntries

let cInfo = romeFile ^. cacheInfo

let mS3BucketName = S3.BucketName <$> cInfo ^. bucket

mlCacheDir <- liftIO $ traverse absolutizePath $ cInfo ^. localCacheDir

mEnginePath <- liftIO $ traverse absolutizePath $ cInfo ^. enginePath

case command of

Upload (RomeUDCPayload gitRepoNames platforms cachePrefixString skipLocalCache noIgnoreFlag noSkipCurrentFlag concurrentlyFlag)

-> sayVersionWarning romeVersion verbose

*> performWithDefaultFlow

uploadArtifacts

( verbose

, noIgnoreFlag

, skipLocalCache

, noSkipCurrentFlag

, concurrentlyFlag

)

(repositoryMapEntries, ignoreMapEntries, currentMapEntries)

gitRepoNames

cartfileEntries

cachePrefixString

mS3BucketName

mlCacheDir

mEnginePath

platforms

Download (RomeUDCPayload gitRepoNames platforms cachePrefixString skipLocalCache noIgnoreFlag noSkipCurrentFlag concurrentlyFlag)

-> sayVersionWarning romeVersion verbose

*> performWithDefaultFlow

downloadArtifacts

( verbose

, noIgnoreFlag

, skipLocalCache

, noSkipCurrentFlag

, concurrentlyFlag

)

(repositoryMapEntries, ignoreMapEntries, currentMapEntries)

gitRepoNames

cartfileEntries

cachePrefixString

mS3BucketName

mlCacheDir

mEnginePath

platforms

List (RomeListPayload listMode platforms cachePrefixString printFormat noIgnoreFlag noSkipCurrentFlag)

-> do

currentVersion <- deriveCurrentVersion

let

finalRepositoryMapEntries =

if _noIgnore noIgnoreFlag

then

repositoryMapEntries

else

repositoryMapEntries

`filterRomeFileEntriesByPlatforms` ignoreMapEntries

let repositoryMap = toRepositoryMap finalRepositoryMapEntries

let reverseRepositoryMap =

toInvertedRepositoryMap finalRepositoryMapEntries

let finalIgnoreNames =

if _noIgnore noIgnoreFlag then [] else ignoreFrameworks

let derivedFrameworkVersions =

deriveFrameworkNamesAndVersion repositoryMap cartfileEntries

let frameworkVersions =

derivedFrameworkVersions

`filterOutFrameworksAndVersionsIfNotIn` finalIgnoreNames

let cachePrefix = CachePrefix cachePrefixString

let filteredCurrentMapEntries =

currentMapEntries

`filterRomeFileEntriesByPlatforms` ignoreMapEntries

let currentFrameworks =

concatMap (snd . romeFileEntryToTuple) filteredCurrentMapEntries

let currentFrameworkVersions =

map (flip FrameworkVersion currentVersion) currentFrameworks

let currentInvertedMap =

toInvertedRepositoryMap filteredCurrentMapEntries

runReaderT

(listArtifacts

mS3BucketName

mlCacheDir

mEnginePath

listMode

(reverseRepositoryMap <> if _noSkipCurrent noSkipCurrentFlag

then currentInvertedMap

else M.empty

)

(frameworkVersions <> if _noSkipCurrent noSkipCurrentFlag

then

(currentFrameworkVersions

`filterOutFrameworksAndVersionsIfNotIn` finalIgnoreNames

)

else []

)

platforms

printFormat

)

(cachePrefix, SkipLocalCacheFlag False, verbose)

_ ->

throwError

"Error: Programming Error. Only List, Download, Upload commands are supported."

where

sayVersionWarning vers verb = runMaybeT $ exceptToMaybeT $ do

let sayFunc = if verb then sayLnWithTime else sayLn

(uptoDate, latestVersion) <- checkIfRomeLatestVersionIs vers

unless uptoDate

$ sayFunc

$ redControlSequence

<> "*** Please update to the latest Rome version: "

<> romeVersionToString latestVersion

<> ". "

<> "You are currently on: "

<> romeVersionToString vers

<> noColorControlSequence

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.

-> ReaderT (CachePrefix, SkipLocalCacheFlag, ConcurrentlyFlag, Bool) RomeMonad ()

-- | Convenience function wrapping the regular sequence of events

performWithDefaultFlow

:: FlowFunction

-> ( Bool {- verbose -}

, NoIgnoreFlag {- noIgnoreFlag -}

, SkipLocalCacheFlag {- skipLocalCache -}

, NoSkipCurrentFlag {- noSkipCurrentFlag -}

, ConcurrentlyFlag

) {- concurrentlyFlag -}

-> ([RomefileEntry] {- repositoryMapEntries -}

, [RomefileEntry] {- ignoreMapEntries -}

, [RomefileEntry]) {- currentMapEntries -}

-> [ProjectName] -- gitRepoNames

-> [CartfileEntry] -- cartfileEntries

-> 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 mEnginePath platforms

= do

let ignoreFrameworks = concatMap _frameworks ignoreMapEntries

let

finalRepositoryMapEntries =

if _noIgnore noIgnoreFlag

then

repositoryMapEntries

else

repositoryMapEntries

`filterRomeFileEntriesByPlatforms` ignoreMapEntries

let repositoryMap = toRepositoryMap finalRepositoryMapEntries

let reverseRepositoryMap =

toInvertedRepositoryMap finalRepositoryMapEntries

let finalIgnoreNames =

if _noIgnore noIgnoreFlag then [] else ignoreFrameworks

if null gitRepoNames

then

let

derivedFrameworkVersions =

deriveFrameworkNamesAndVersion repositoryMap cartfileEntries

cachePrefix = CachePrefix cachePrefixString

in

do

runReaderT

(flowFunc

mS3BucketName

mlCacheDir

mEnginePath

reverseRepositoryMap

(derivedFrameworkVersions

`filterOutFrameworksAndVersionsIfNotIn` finalIgnoreNames

)

platforms

)

(cachePrefix, skipLocalCache, concurrentlyFlag, verbose)

when (_noSkipCurrent noSkipCurrentFlag) $ do

currentVersion <- deriveCurrentVersion

let filteredCurrentMapEntries =

currentMapEntries

`filterRomeFileEntriesByPlatforms` ignoreMapEntries

let currentFrameworks = concatMap (snd . romeFileEntryToTuple)

filteredCurrentMapEntries

let currentFrameworkVersions = map

(flip FrameworkVersion currentVersion)

currentFrameworks

let currentInvertedMap =

toInvertedRepositoryMap filteredCurrentMapEntries

runReaderT

(flowFunc

mS3BucketName

mlCacheDir

mEnginePath

currentInvertedMap

(currentFrameworkVersions

`filterOutFrameworksAndVersionsIfNotIn` finalIgnoreNames

)

platforms

)

(cachePrefix, skipLocalCache, concurrentlyFlag, verbose)

else do

currentVersion <- deriveCurrentVersion

let filteredCurrentMapEntries =

( (\e -> _projectName e `elem` gitRepoNames)

`filter` currentMapEntries

) -- Make sure the command is only run for the mentioned projects

`filterRomeFileEntriesByPlatforms` ignoreMapEntries

let currentFrameworks =

concatMap (snd . romeFileEntryToTuple) filteredCurrentMapEntries

let currentFrameworkVersions =

map (flip FrameworkVersion currentVersion) currentFrameworks

let

derivedFrameworkVersions = deriveFrameworkNamesAndVersion

repositoryMap

(filterCartfileEntriesByGitRepoNames gitRepoNames cartfileEntries)

frameworkVersions =

(derivedFrameworkVersions <> currentFrameworkVersions)

`filterOutFrameworksAndVersionsIfNotIn` finalIgnoreNames

cachePrefix = CachePrefix cachePrefixString

currentInvertedMap =

toInvertedRepositoryMap filteredCurrentMapEntries

runReaderT

(flowFunc mS3BucketName

mlCacheDir

mEnginePath

(reverseRepositoryMap <> currentInvertedMap)

frameworkVersions

platforms

)

(cachePrefix, skipLocalCache, concurrentlyFlag, verbose)

-- | Lists Frameworks in the caches.

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

-> [TargetPlatform] -- ^ A list of `TargetPlatform` to limit the operation to.

-> PrintFormat -- ^ A format of the string result: text or JSON.

-> ReaderT

(CachePrefix, SkipLocalCacheFlag, Bool)

RomeMonad

()

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

if format == Text

then mapM_ sayFunc $ repoLines repoAvailabilities

else sayFunc $ toJSONStr $ ReposJSON

(fmap formattedRepoAvailabilityJSON repoAvailabilities)

where

repoLines repoAvailabilities = filter (not . null)

$ fmap (formattedRepoAvailability listMode) repoAvailabilities

-- | Produces a list of `ProjectAvailability`s for Frameworks

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.

-> ReaderT

(CachePrefix, SkipLocalCacheFlag, Bool)

RomeMonad

[ProjectAvailability]

getProjectAvailabilityFromCaches (Just s3BucketName) _ Nothing reverseRepositoryMap frameworkVersions platforms

= do

env <- lift getAWSEnv

(cachePrefix, _, verbose) <- ask

let readerEnv = (env, cachePrefix, verbose)

availabilities <- liftIO $ runReaderT

(probeS3ForFrameworks s3BucketName

reverseRepositoryMap

frameworkVersions

platforms

)

readerEnv

return $ getMergedGitRepoAvailabilitiesFromFrameworkAvailabilities

reverseRepositoryMap

availabilities

getProjectAvailabilityFromCaches Nothing (Just lCacheDir) Nothing reverseRepositoryMap frameworkVersions platforms

= do

(cachePrefix, SkipLocalCacheFlag skipLocalCache, _) <- ask

when skipLocalCache $ throwError conflictingSkipLocalCacheOptionMessage

availabilities <- probeLocalCacheForFrameworks lCacheDir

cachePrefix

reverseRepositoryMap

frameworkVersions

platforms

return $ getMergedGitRepoAvailabilitiesFromFrameworkAvailabilities

reverseRepositoryMap

availabilities

getProjectAvailabilityFromCaches Nothing _ (Just ePath) reverseRepositoryMap frameworkVersions platforms

= do

(cachePrefix, _, _) <- ask

availabilities <- probeEngineForFrameworks ePath

cachePrefix

reverseRepositoryMap

frameworkVersions

platforms

return $ getMergedGitRepoAvailabilitiesFromFrameworkAvailabilities

reverseRepositoryMap

availabilities

getProjectAvailabilityFromCaches (Just _) _ (Just _) _ _ _ =

throwError conflictingCachesMessage

getProjectAvailabilityFromCaches Nothing Nothing Nothing _ _ _ =

throwError allCacheKeysMissingMessage

-- | Downloads Frameworks, related dSYMs and .version files in the caches.

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

)

RomeMonad

()

downloadArtifacts mS3BucketName mlCacheDir mEnginePath reverseRepositoryMap frameworkVersions platforms

= do

(cachePrefix, skipLocalCacheFlag@(SkipLocalCacheFlag skipLocalCache), concurrentlyFlag@(ConcurrentlyFlag performConcurrently), verbose) <-

ask

let sayFunc :: MonadIO m => String -> m ()

sayFunc = if verbose then sayLnWithTime else sayLn

case (mS3BucketName, mlCacheDir, mEnginePath) of

(Just s3BucketName, lCacheDir, Nothing) -> do

env <- lift getAWSEnv

let uploadDownloadEnv =

(env, cachePrefix, skipLocalCacheFlag, concurrentlyFlag, verbose)

let action1 = runReaderT

(downloadFrameworksAndArtifactsFromCaches s3BucketName

lCacheDir

reverseRepositoryMap

frameworkVersions

platforms

)

uploadDownloadEnv

let action2 = runReaderT

(downloadVersionFilesFromCaches s3BucketName

lCacheDir

gitRepoNamesAndVersions

)

uploadDownloadEnv

if performConcurrently

then liftIO $ concurrently_ action1 action2

else liftIO $ action1 >> action2

(Nothing, Just lCacheDir, Nothing) -> do

let readerEnv = (cachePrefix, verbose)

when skipLocalCache $ throwError conflictingSkipLocalCacheOptionMessage

liftIO $ do

runReaderT

(do

errors <-

mapM runExceptT

$ getAndUnzipFrameworksAndArtifactsFromLocalCache

lCacheDir

reverseRepositoryMap

frameworkVersions

platforms

mapM_ (whenLeft sayFunc) errors

)

readerEnv

runReaderT

(do

errors <- mapM runExceptT $ getAndSaveVersionFilesFromLocalCache

lCacheDir

gitRepoNamesAndVersions

mapM_ (whenLeft sayFunc) errors

)

readerEnv

-- Use engine

(Nothing, lCacheDir, Just ePath) -> do

let engineEnv = (cachePrefix, skipLocalCacheFlag, concurrentlyFlag, verbose)

let action1 = runReaderT

(downloadFrameworksAndArtifactsWithEngine ePath

lCacheDir

reverseRepositoryMap

frameworkVersions

platforms

)

engineEnv

let action2 = runReaderT

(downloadVersionFilesWithEngine ePath

lCacheDir

gitRepoNamesAndVersions

)

engineEnv

if performConcurrently

then liftIO $ concurrently_ action1 action2

else liftIO $ action1 >> action2

-- Misconfigured

(Nothing, Nothing, Nothing) -> throwError allCacheKeysMissingMessage

-- Misconfigured

(Just s3BucketName, _, Just ePath) -> throwError conflictingCachesMessage

where

gitRepoNamesAndVersions :: [ProjectNameAndVersion]

gitRepoNamesAndVersions = repoNamesAndVersionForFrameworkVersions

reverseRepositoryMap

frameworkVersions

-- | Uploads Frameworks and relative dSYMs together with .version files to caches

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

)

RomeMonad

()

uploadArtifacts mS3BucketName mlCacheDir mEnginePath reverseRepositoryMap frameworkVersions platforms

= do

(cachePrefix, skipLocalCacheFlag@(SkipLocalCacheFlag skipLocalCache), concurrentlyFlag@(ConcurrentlyFlag performConcurrently), verbose) <-

ask

case (mS3BucketName, mlCacheDir, mEnginePath) of

-- S3 Cache, but no engine

(Just s3BucketName, lCacheDir, Nothing) -> do

awsEnv <- lift getAWSEnv

let uploadDownloadEnv =

( awsEnv

, cachePrefix

, skipLocalCacheFlag

, concurrentlyFlag

, verbose

)

let action1 = runReaderT

(uploadFrameworksAndArtifactsToCaches s3BucketName

lCacheDir

reverseRepositoryMap

frameworkVersions

platforms

)

uploadDownloadEnv

let action2 = runReaderT

(uploadVersionFilesToCaches s3BucketName

lCacheDir

gitRepoNamesAndVersions

)

uploadDownloadEnv

if performConcurrently

then liftIO $ concurrently_ action1 action2

else liftIO $ action1 >> action2

-- No remotes, just local

(Nothing, Just lCacheDir, Nothing) -> do

let readerEnv = (cachePrefix, verbose)

when skipLocalCache $ throwError conflictingSkipLocalCacheOptionMessage

liftIO

$ runReaderT

(saveFrameworksAndArtifactsToLocalCache lCacheDir

reverseRepositoryMap

frameworkVersions

platforms

)

readerEnv

>> runReaderT

(saveVersionFilesToLocalCache lCacheDir gitRepoNamesAndVersions)

readerEnv

-- Engine, maybe Cache

(Nothing, lCacheDir, Just enginePath) -> do

let engineEnv =

( cachePrefix

, skipLocalCacheFlag

, concurrentlyFlag

, verbose

)

let action1 = runReaderT

(uploadFrameworksAndArtifactsToEngine enginePath

lCacheDir

reverseRepositoryMap

frameworkVersions

platforms

)

engineEnv

let action2 = runReaderT

(uploadVersionFilesToEngine enginePath

lCacheDir

gitRepoNamesAndVersions

)

engineEnv

if performConcurrently

then liftIO $ concurrently_ action1 action2

else liftIO $ action1 >> action2

(Nothing, Nothing, Nothing) -> throwError allCacheKeysMissingMessage

where

gitRepoNamesAndVersions :: [ProjectNameAndVersion]

gitRepoNamesAndVersions = repoNamesAndVersionForFrameworkVersions

reverseRepositoryMap

frameworkVersions

-- | Uploads a lest of .version files to the engine.

uploadVersionFilesToEngine

:: FilePath -- ^ The engine definition.

-> Maybe FilePath -- ^ Just the path to the local cache or Nothing.

-> [ProjectNameAndVersion] -- ^ A list of `ProjectName` and `Version` information.

-> ReaderT (CachePrefix, SkipLocalCacheFlag, ConcurrentlyFlag, Bool) IO ()

uploadVersionFilesToEngine enginePath mlCacheDir =

mapM_ (uploadVersionFileToEngine enginePath mlCacheDir)

-- | Uploads a .version file to the engine.

uploadVersionFileToEngine

:: FilePath -- ^ The engine definition.

-> Maybe FilePath -- ^ Just the path to the local cache or Nothing.

-> ProjectNameAndVersion -- ^ The information used to derive the name and path for the .version file.

-> ReaderT (CachePrefix, SkipLocalCacheFlag, ConcurrentlyFlag, Bool) IO ()

uploadVersionFileToEngine enginePath mlCacheDir projectNameAndVersion = do

(cachePrefix, SkipLocalCacheFlag skipLocalCache, _, verbose) <- ask

versionFileExists <- liftIO $ doesFileExist versionFileLocalPath

when versionFileExists $ do

versionFileContent <- liftIO $ LBS.readFile versionFileLocalPath

unless skipLocalCache

$ maybe (return ()) liftIO

$ saveVersionFileBinaryToLocalCache

<$> mlCacheDir

<*> Just cachePrefix

<*> Just versionFileContent

<*> Just projectNameAndVersion

<*> Just verbose

liftIO $ runReaderT

(uploadVersionFileToEngine' enginePath

versionFileContent

projectNameAndVersion

)

(cachePrefix, verbose)

where

versionFileName = versionFileNameForProjectName $ fst projectNameAndVersion

versionFileLocalPath = carthageBuildDirectory </> versionFileName

-- | Uploads a lest of .version files to the caches.

uploadVersionFilesToCaches

:: S3.BucketName -- ^ The cache definition.

-> Maybe FilePath -- ^ Just the path to the local cache or Nothing.

-> [ProjectNameAndVersion] -- ^ A list of `ProjectName` and `Version` information.

-> ReaderT UploadDownloadCmdEnv IO ()

uploadVersionFilesToCaches s3Bucket mlCacheDir =

mapM_ (uploadVersionFileToCaches s3Bucket mlCacheDir)

-- | Uploads a .version file the caches.

uploadVersionFileToCaches

:: S3.BucketName -- ^ The cache definition.

-> Maybe FilePath -- ^ Just the path to the local cache or Nothing.

-> ProjectNameAndVersion -- ^ The information used to derive the name and path for the .version file.

-> ReaderT UploadDownloadCmdEnv IO ()

uploadVersionFileToCaches s3BucketName mlCacheDir projectNameAndVersion = do

(env, cachePrefix, SkipLocalCacheFlag skipLocalCache, _, verbose) <- ask

versionFileExists <- liftIO $ doesFileExist versionFileLocalPath

when versionFileExists $ do

versionFileContent <- liftIO $ LBS.readFile versionFileLocalPath

unless skipLocalCache

$ maybe (return ()) liftIO

$ saveVersionFileBinaryToLocalCache

<$> mlCacheDir

<*> Just cachePrefix

<*> Just versionFileContent

<*> Just projectNameAndVersion

<*> Just verbose

liftIO $ runReaderT

(uploadVersionFileToS3 s3BucketName

versionFileContent

projectNameAndVersion

)

(env, cachePrefix, verbose)

where

versionFileName = versionFileNameForProjectName $ fst projectNameAndVersion

versionFileLocalPath = carthageBuildDirectory </> versionFileName

-- | Uploads a list of Frameworks and relative dSYMs to the caches.

uploadFrameworksAndArtifactsToCaches

:: S3.BucketName -- ^ The cache definition.

-> Maybe FilePath -- ^ Just the path to a local cache or Nothing

-> InvertedRepositoryMap -- ^ The map used to resolve `FrameworkName`s to `ProjectName`s.

-> [FrameworkVersion] -- ^ A list of `FrameworkVersion` identifying the Frameworks and dSYMs.

-> [TargetPlatform] -- ^ A list of `TargetPlatform`s restricting the scope of this action.

-> ReaderT UploadDownloadCmdEnv IO ()

uploadFrameworksAndArtifactsToCaches s3BucketName mlCacheDir reverseRomeMap fvs platforms

= do

(_, _, _, ConcurrentlyFlag performConcurrently, _) <- ask

if performConcurrently

then mapConcurrently_ uploadConcurrently fvs

else mapM_ (sequence . upload) platforms

where

uploadConcurrently f = mapConcurrently

(uploadFrameworkAndArtifactsToCaches s3BucketName

mlCacheDir

reverseRomeMap

f

)

platforms

upload = mapM

(uploadFrameworkAndArtifactsToCaches s3BucketName mlCacheDir reverseRomeMap)

fvs

-- | Uploads a Framework, the relative dSYM and bcsymbolmaps to the caches.

uploadFrameworkAndArtifactsToCaches

:: S3.BucketName -- ^ The cache definition.

-> Maybe FilePath -- ^ Just the path to the local cache or Nothing.

-> InvertedRepositoryMap -- ^ The map used to resolve `FrameworkName`s to `ProjectName`s.

-> FrameworkVersion -- ^ The `FrameworkVersion` identifying the Framework and the dSYM

-> TargetPlatform -- ^ A `TargetPlatform` restricting the scope of this action.

-> ReaderT UploadDownloadCmdEnv IO ()

uploadFrameworkAndArtifactsToCaches s3BucketName mlCacheDir reverseRomeMap fVersion@(FrameworkVersion f@(Framework fwn _ _) _) platform

= do

(env, cachePrefix, s@(SkipLocalCacheFlag skipLocalCache), _, verbose) <- ask

let uploadDownloadEnv = (env, cachePrefix, verbose)

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 $ runReaderT

(uploadFrameworkToS3 frameworkArchive

s3BucketName

reverseRomeMap

fVersion

platform

)

uploadDownloadEnv

void . runExceptT $ do

dSYMArchive <- createZipArchive dSYMdirectory verbose

unless skipLocalCache

$ maybe (return ()) liftIO

$ runReaderT

<$> ( saveDsymToLocalCache

<$> mlCacheDir

<*> Just dSYMArchive

<*> Just reverseRomeMap

<*> Just fVersion

<*> Just platform

)

<*> Just (cachePrefix, s, verbose)

liftIO $ runReaderT

(uploadDsymToS3 dSYMArchive

s3BucketName

reverseRomeMap

fVersion

platform

)

uploadDownloadEnv

void . runExceptT $ do

dwarfUUIDs <- dwarfUUIDsFrom (frameworkDirectory </> fwn)

maybeUUIDsArchives <- liftIO $ forM dwarfUUIDs $ \dwarfUUID ->

runMaybeT $ do

dwarfArchive <- exceptToMaybeT

$ createZipArchive (bcSymbolMapPath dwarfUUID) verbose

return (dwarfUUID, dwarfArchive)

unless skipLocalCache

$ forM_ maybeUUIDsArchives

$ mapM

$ \(dwarfUUID, dwarfArchive) ->

maybe (return ()) liftIO

$ runReaderT

<$> ( saveBcsymbolmapToLocalCache

<$> mlCacheDir

<*> Just dwarfUUID

<*> Just dwarfArchive

<*> Just reverseRomeMap

<*> Just fVersion

<*> Just platform

)

<*> Just (cachePrefix, s, verbose)

forM_ maybeUUIDsArchives $ mapM $ \(dwarfUUID, dwarfArchive) ->

liftIO $ runReaderT

(uploadBcsymbolmapToS3 dwarfUUID

dwarfArchive

s3BucketName

reverseRomeMap

fVersion

platform

)

uploadDownloadEnv

where

frameworkNameWithFrameworkExtension = appendFrameworkExtensionTo f

platformBuildDirectory =

carthageArtifactsBuildDirectoryForPlatform platform f

frameworkDirectory =

platformBuildDirectory </> frameworkNameWithFrameworkExtension

dSYMNameWithDSYMExtension = frameworkNameWithFrameworkExtension <> ".dSYM"

dSYMdirectory = platformBuildDirectory </> dSYMNameWithDSYMExtension

bcSymbolMapPath d = platformBuildDirectory </> bcsymbolmapNameFrom d

-- | Saves a list of Frameworks, relative dSYMs and bcsymbolmaps to a local cache.

saveFrameworksAndArtifactsToLocalCache

:: MonadIO m

=> FilePath -- ^ The cache definition.

-> InvertedRepositoryMap -- ^ The map used to resolve `FrameworkName`s to `ProjectName`s.

-> [FrameworkVersion] -- ^ A list of `FrameworkVersion` identifying Frameworks and dSYMs

-> [TargetPlatform] -- ^ A list of `TargetPlatform` restricting the scope of this action.

-> ReaderT (CachePrefix, Bool) m ()

saveFrameworksAndArtifactsToLocalCache lCacheDir reverseRomeMap fvs = mapM_

(sequence . save)

where

save =

mapM (saveFrameworkAndArtifactsToLocalCache lCacheDir reverseRomeMap) fvs

-- | Saves a Framework, the relative dSYM and then bcsymbolmaps to a local cache.

saveFrameworkAndArtifactsToLocalCache

:: MonadIO m

=> FilePath -- ^ The cache definition

-> InvertedRepositoryMap -- ^ The map used to resolve `FrameworkName`s to `ProjectName`s.

-> FrameworkVersion -- ^ A `FrameworkVersion` identifying Framework and dSYM.

-> TargetPlatform -- ^ A `TargetPlatform` restricting the scope of this action.

-> ReaderT (CachePrefix, Bool) m ()

saveFrameworkAndArtifactsToLocalCache lCacheDir reverseRomeMap fVersion@(FrameworkVersion f@(Framework fwn _ _) _) platform

= do

(cachePrefix, verbose) <- ask

let readerEnv = (cachePrefix, SkipLocalCacheFlag False, verbose)