diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..a4ee41a --- /dev/null +++ b/.gitignore @@ -0,0 +1,19 @@ +dist +dist-* +cabal-dev +*.o +*.hi +*.chi +*.chs.h +*.dyn_o +*.dyn_hi +.hpc +.hsenv +.cabal-sandbox/ +cabal.sandbox.config +*.prof +*.aux +*.hp +*.eventlog +.stack-work/ +cabal.project.local diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..8b2408b --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License + +Copyright (c) 2016 Tommaso Piazza + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 index 0000000..bc5d315 --- /dev/null +++ b/README.md @@ -0,0 +1,115 @@ +# Rome + +Rome is a tool that allows developer on Apple platforms to use Amazon's S3 as a +cache for frameworks build with [Carthage](https://github.com/Carthage/Carthage). + +## The problem + +Suppose you're working on some frameworks for you iOS project and want to share +your frameworks with your team. A great way to do so is to use Carthage and have +team members point the `Cartfile` to the new framework version (or branch, tag, commit) +and run `carthage update`. + +Unfortunately this will require them to build from scratch the new framework. +This is particularly annoying if the dependency tree for that framework is big +and / or takes a long time to build. + +## The solution + +Use a cache. The first team member can build the framework and share it while all +other developers can get it from the cache with no waiting time. + +## Workflow + +The Rome's workflow changes depending if you are the producer (i.e. the first +person in your team to build the framework) or the consumer. + +### Producer workflow + +``` +$ vi Cartfile #point to the new version of the framework +$ carthage update && rome upload +``` + +### Consumer workflow + +``` +$ vi Cartfile +$ carthage update --no-build && rome download +``` + +or + +``` +$ vi Cartfile.resolved #point to the new version of the framework +$ rome download +``` +## Set up and Usage + +- First you need a `.aws-keys` file in your home folder. This is used to specify +your AWS Credentials +- Second you need a `Romefile` in the project where you want to use Rome. At the +same level where the `Cartfile` is. + +### Setting up AWS credentials +In your home folder create a `.aws-keys` that contains the following line +``` +default AWS_IDENTITY AWS_PRIVATE_KEY +``` + +this should look something like + +``` +default AGIAJQARMD67CE3DTKHA TedRV2/dFkBr1H3D7xuPsF9+CBHTjK0NKrJuoVs8 +``` + +these will be the credentials that Rome will use to access S3 on your behalf + +### Romefile + +The Romefile has tow purposes: +1. Specifies what S3 bucket to use - [S3Bucket] section. This section is __required__. +1. Allows to use custom name mappings between repository names and framework names - [RepositoryMap] section. This section is __optional__ and can be omitted. + +A Romefile looks like this + +``` +[S3Bucket] + ios-dev-bucket + +[RepositoryMap] + awesome-framework-for-cat-names CatFramework + better-dog-names DogFramework +``` + +#### S3Bucket section +This section contains the name of the S3 bucket you want Rome to use to upload/download. + +#### RepositoryMap +This contains the mappings of git repository names with framework names. +This is particularly useful inn case you are not using github and the "Organization/FrameworkName" convention. + +Example: + +Suppose you have the following in your `Cartfile` + +``` +git "http://stash.myAimalStartup.com/scm/iossdk/awesome-framework-for-cat-names.git" ~> 3.3.1 +git "http://stash.myAimalStartup.com/scm/iossdk/better-dog-name.git" ~> 0.4.4 +``` + +but your framework names are actually `CatFramework` and `DogFramework` as opposed to `awesome-framework-for-cat-names` and `better-dog-names`. + +simply add a `[RepositoryMap]` section to your `Romefile` and specify the following mapping: + +``` +[S3Bucket] + ios-dev-bucket + +[RepositoryMap] + awesome-framework-for-cat-names CatFramework + better-dog-names DogFramework +``` + +## Get Rome +The Rome binary is attached as a zip to the releases here on GitHub. diff --git a/Rome.cabal b/Rome.cabal new file mode 100644 index 0000000..eafe767 --- /dev/null +++ b/Rome.cabal @@ -0,0 +1,62 @@ +name: Rome +version: 0.1.0.0 +synopsis: An S3 cache for Carthage +description: Please see README.md +homepage: https://github.com/blender/Rome#readme +license: BSD3 +license-file: LICENSE +author: Tommaso Piazza +maintainer: tommaso.piazza@gmail.com +copyright: 2016 Tommaso Piazza +category: Web +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Lib + build-depends: base >= 4.7 && < 5 + , aws >= 0.13 + , parsec >= 3.1.10 + , mtl >= 2.2.1 + , directory >= 1.2.2 + , containers >= 0.5 + , conduit >= 1.2 + , conduit-extra >= 1.1 + , http-conduit >= 2.1 + , text >= 1.2 + , bytestring >= 0.10 + , zip-archive >= 0.2 + , resourcet >= 1.1 + , optparse-applicative >= 0.12 + + + + default-language: Haskell2010 + +executable rome + hs-source-dirs: app + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: base >= 4.7 && < 5 + , Rome + , mtl >= 2.2.1 + , optparse-applicative >= 0.12 + + + + default-language: Haskell2010 + +test-suite Rome-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , Rome + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/blender/Rome diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 index 0000000..8a0dc2b --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,26 @@ +module Main where + +import Control.Monad.Except +import Options.Applicative as Opts +import Lib + + + +romeVersion :: String +romeVersion = "0.1.0.0" + + + +-- Main +main :: IO () +main = do + let opts = info (Opts.helper <*> Opts.flag' Nothing (Opts.long "version" <> Opts.help "Prints the version information" <> Opts.hidden ) <|> Just <$> parseRomeOptions) (header "S3 cache tool for Carthage" ) + cmd <- execParser opts + (cfg, s3cfg) <- getS3Configuration + case cmd of + Nothing -> putStrLn $ romeVersion ++ " - Romam uno die non fuisse conditam." + Just romeOptions -> do + l <- runExceptT $ donwloadORUpload cfg s3cfg romeOptions + case l of + Right _ -> return () + Left e -> putStrLn e diff --git a/src/Lib.hs b/src/Lib.hs new file mode 100644 index 0000000..284741a --- /dev/null +++ b/src/Lib.hs @@ -0,0 +1,285 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + + + +module Lib + ( parseRomeOptions + , getS3Configuration + , donwloadORUpload + ) where + + + + + +import qualified Aws +import qualified Aws.S3 as S3 +import qualified Codec.Archive.Zip as Zip +import Control.Applicative ((<|>)) +import Control.Monad +import Control.Monad.Except +import Control.Monad.Reader (ReaderT, ask, runReaderT) +import Control.Monad.Trans (MonadIO, lift, liftIO) +import Control.Monad.Trans.Resource (runResourceT) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.Conduit (($$+-), ($=)) +import Data.Conduit.Binary (sinkLbs) +import qualified Data.Map as M +import Data.Maybe +import qualified Data.Text as T +import Network.HTTP.Conduit (Manager, RequestBody (..), + newManager, responseBody, + tlsManagerSettings) +import Options.Applicative as Opts +import System.Directory +import qualified Text.Parsec as Parsec +import Text.Parsec.String + + +type Location = String +type Version = String +type Config = (Aws.Configuration, S3.S3Configuration Aws.NormalQuery, Bool) +type RomeMonad = ExceptT String IO + +data RepoHosting = GitHub | Git + deriving (Eq, Show) + +data CartfileEntry = CartfileEntry { hosting :: RepoHosting + , location :: Location + , version :: Version + } + deriving (Show, Eq) + +data RomefileEntry = RomefileEntry { gitRepositoryName :: String + , frameworkCommonName :: String + } + deriving (Show, Eq) + +data RomeCommand = Upload [String] + | Download [String] + deriving (Show, Eq) + +data RomeOptions = RomeOptions { romeCommand :: RomeCommand + , verbose :: Bool + } + + + + +uploadParser :: Opts.Parser RomeCommand +uploadParser = pure Upload <*> Opts.many (Opts.argument str (Opts.metavar "FRAMEWORKS..." <> Opts.help "Zero or more framework names as specified in the Cartfile. If zero, all frameworks are uploaded.")) + +downloadParser :: Opts.Parser RomeCommand +downloadParser = pure Download <*> Opts.many (Opts.argument str (Opts.metavar "FRAMEWORKS..." <> Opts.help "Zero or more framework names as specified in the Cartfile. If zero, all frameworks are downloaded.")) + +parseRomeCommand :: Opts.Parser RomeCommand +parseRomeCommand = Opts.subparser $ + Opts.command "upload" (uploadParser `withInfo` "Uploads frameworks contained in the local Carthage/Build/iOS to S3, according to the local Cartfile.resolved") + <> Opts.command "download" (downloadParser `withInfo` "Downdloads and unpacks in Carthage/Build/iOS frameworks found in S3, according to the local Carftfile.resolved") + +parseRomeOptions :: Opts.Parser RomeOptions +parseRomeOptions = RomeOptions <$> parseRomeCommand <*> Opts.switch ( Opts.short 'v' <> help "Show verbose output" ) + +withInfo :: Opts.Parser a -> String -> Opts.ParserInfo a +withInfo opts desc = Opts.info (Opts.helper <*> opts) $ Opts.progDesc desc + +cartfileResolved :: String +cartfileResolved = "Cartfile.resolved" + +romefile :: String +romefile = "Romefile" + +getCartfileEntires :: RomeMonad [CartfileEntry] +getCartfileEntires = do + eitherCartfileEntries <- liftIO $ parseFromFile (Parsec.many1 parseCartfileResolvedLine) cartfileResolved + case eitherCartfileEntries of + Left e -> throwError $ "Carfile.resolved parse error: " ++ show e + Right cartfileEntries -> return cartfileEntries + +getRomefileEntries :: RomeMonad (S3.Bucket, [RomefileEntry]) +getRomefileEntries = do + romeConfig <- liftIO $ parseFromFile parseRomeConfig romefile + case romeConfig of + Left e -> throwError $ "Romefile parse error: " ++ show e + Right (bucketName, entries) -> return (T.pack bucketName, entries) + +donwloadORUpload :: Aws.Configuration -> S3.S3Configuration Aws.NormalQuery -> RomeOptions -> ExceptT String IO () +donwloadORUpload cfg s3cfg (RomeOptions options verbose) = do + cartfileEntries <- getCartfileEntires + (s3BucketName, romefileEntries) <- getRomefileEntries + case options of + Upload [] -> do + let frameworkAndVersions = constructFrameworksAndVersionsFrom cartfileEntries romefileEntries + liftIO $ runReaderT (uploadFrameworksToS3 s3BucketName frameworkAndVersions) (cfg, s3cfg, verbose) + + Upload names -> + liftIO $ runReaderT (uploadFrameworksToS3 s3BucketName (filterByNames cartfileEntries romefileEntries names)) (cfg, s3cfg, verbose) + + Download [] -> do + let frameworkAndVersions = constructFrameworksAndVersionsFrom cartfileEntries romefileEntries + liftIO $ runReaderT (downloadFrameworksFromS3 s3BucketName frameworkAndVersions) (cfg, s3cfg, verbose) + + Download names -> + liftIO $ runReaderT (downloadFrameworksFromS3 s3BucketName (filterByNames cartfileEntries romefileEntries names)) (cfg, s3cfg, verbose) + where + constructFrameworksAndVersionsFrom cartfileEntries romefileEntries = zip (deriveFrameworkNames (toRomeFilesEntriesMap romefileEntries) cartfileEntries) (map version cartfileEntries) + filterByNames cartfileEntries romefileEntries = concatMap (constructFrameworksAndVersionsFrom cartfileEntries romefileEntries `filterByName`) + + +getS3Configuration :: MonadIO m => m (Aws.Configuration, S3.S3Configuration Aws.NormalQuery) +getS3Configuration = do + cfg <- Aws.baseConfiguration + let s3cfg = Aws.defServiceConfig :: S3.S3Configuration Aws.NormalQuery + return (cfg, s3cfg) + +filterByName:: [(String, Version)] -> String -> [(String, Version)] +filterByName fs s = filter (\(name, version) -> name == s) fs + +uploadFrameworksToS3 :: (MonadIO m) => S3.Bucket -> [(String, Version)] -> ReaderT Config m () +uploadFrameworksToS3 s3Bucket s = do + manager <- liftIO $ newManager tlsManagerSettings + mapM_ (uploadFrameworkToS3 manager s3Bucket) s + +uploadFrameworkToS3 :: (MonadIO m) => Manager -> S3.Bucket -> (String, Version) -> ReaderT Config m () +uploadFrameworkToS3 manager s3Bucket (framework, version) = do + let pathInCarthageBuild = appendFrameworkExtensionTo $ "Carthage/Build/iOS/" ++ framework + exists <- liftIO $ doesDirectoryExist pathInCarthageBuild + when exists $ do + (_, _, verbose) <- ask + archive <- liftIO $ Zip.addFilesToArchive (zipOptions verbose) Zip.emptyArchive [pathInCarthageBuild] + uploadB manager s3Bucket (Zip.fromArchive archive) (framework ++ "/" ++ appendFrameworkExtensionTo framework ++ "-" ++ version ++ ".zip") + +downloadFrameworksFromS3 :: (MonadIO m) => S3.Bucket -> [(String, Version)] -> ReaderT Config m () +downloadFrameworksFromS3 s3Bucket s = do + manager <- liftIO $ newManager tlsManagerSettings + mapM_ (downloadFrameworkFromS3 manager s3Bucket) s + +downloadFrameworkFromS3 :: (MonadIO m) => Manager -> S3.Bucket -> (String, Version) -> ReaderT Config m () +downloadFrameworkFromS3 manager s3Bucket (frameworkName, version) = do + (awsConfig, s3Config, verbose) <- ask + liftIO $ + {- Create a request object with S3.getObject and run the request with pureAws. -} + runResourceT $ do + let frameworkZipName = appendFrameworkExtensionTo frameworkName ++ "-" ++ version ++ ".zip" + let frameworkRemotePath = frameworkName ++ "/" ++ frameworkZipName + e <- Aws.aws awsConfig s3Config manager $ S3.getObject s3Bucket (T.pack frameworkRemotePath) + let eitherResponse = Aws.responseResult e + case eitherResponse of + Left exception -> liftIO . putStrLn $ "Could not download: " ++ frameworkZipName + Right S3.GetObjectResponse { .. } -> do + lbs <- responseBody gorResponse $$+- sinkLbs + liftIO . putStrLn $ "Donwloaded: " ++ frameworkZipName + lift $ Zip.extractFilesFromArchive (zipOptions verbose) (Zip.toArchive lbs) + liftIO . putStrLn $ "Unzipped: " ++ frameworkZipName + +zipOptions :: Bool -> [Zip.ZipOption] +zipOptions verbose = if verbose then [Zip.OptRecursive, Zip.OptVerbose] else [Zip.OptRecursive] + +uploadB :: (MonadIO m) => Manager -> S3.Bucket -> L.ByteString -> String -> ReaderT Config m () +uploadB manager s3Bucket lazyByteString destinationPath = do + contents <- ask + (awsConfig, s3Config, verbose) <- ask + liftIO $ + runResourceT $ do + let body = RequestBodyLBS lazyByteString + response <- Aws.pureAws awsConfig s3Config manager $ + S3.putObject s3Bucket (T.pack destinationPath) body + liftIO . putStrLn $ "Uploaded: " ++ destinationPath + +deriveFrameworkNames :: M.Map String String -> [CartfileEntry] -> [String] +deriveFrameworkNames romeMap = map (deriveFrameworkName romeMap) + +deriveFrameworkName :: M.Map String String -> CartfileEntry -> String +deriveFrameworkName romeMap (CartfileEntry GitHub l _) = last $ splitWithSeparator '/' l +deriveFrameworkName romeMap (CartfileEntry Git l _) = fromMaybe "" (M.lookup (getGitRepositoryNameFromGitURL l) romeMap >>= \x -> Just x) + where + getGitRepositoryNameFromGitURL = reverse . tail . snd . splitAt 3 . reverse . last . splitWithSeparator '/' + +appendFrameworkExtensionTo :: String -> String +appendFrameworkExtensionTo a = a ++ ".framework" + +splitWithSeparator :: (Eq a) => a -> [a] -> [[a]] +splitWithSeparator _ [] = [] +splitWithSeparator a as = g as : splitWithSeparator a (dropTaken as as) + where + numberOfAsIn = length . takeWhile (== a) + g = takeWhile (/= a) . dropWhile (== a) + dropTaken bs = drop $ numberOfAsIn bs + length (g bs) + + + +-- Cartfile.resolved parsing + +parseGitHub :: Parsec.Parsec String () RepoHosting +parseGitHub = Parsec.string "github" >> Parsec.many1 Parsec.space >> pure GitHub + +parseGit :: Parsec.Parsec String () RepoHosting +parseGit = Parsec.string "git" >> Parsec.many1 Parsec.space >> pure Git + +repoHosting :: Parsec.Parsec String () RepoHosting +repoHosting = Parsec.try parseGit <|> parseGitHub + +quotedContent :: Parsec.Parsec String () String +quotedContent = do + Parsec.char '"' + location <- parseUnquotedString + Parsec.char '"' + return location + +parseCartfileResolvedLine :: Parsec.Parsec String () CartfileEntry +parseCartfileResolvedLine = do + hosting <- repoHosting + location <- quotedContent + Parsec.many1 Parsec.space + version <- quotedContent + Parsec.endOfLine + return CartfileEntry {..} + + + +-- Romefile parsing + +parseS3BucketNameSection :: Parsec.Parsec String () String +parseS3BucketNameSection = do + Parsec.string "[S3Bucket]" >> Parsec.endOfLine + s3BucketName <- parseWhiteSpaces >> parseUnquotedString + Parsec.endOfLine + return s3BucketName + +parseRepositoryMapSection :: Parsec.Parsec String () [RomefileEntry] +parseRepositoryMapSection = do + Parsec.string "[RepositoryMap]" >> Parsec.endOfLine + Parsec.many parseRepositoryMapLine + +parseRepositoryMapLine :: Parsec.Parsec String () RomefileEntry +parseRepositoryMapLine = do + gitRepositoryName <- parseWhiteSpaces >> parseUnquotedString + frameworkCommonName <- parseWhiteSpaces >> parseUnquotedString + Parsec.endOfLine + return RomefileEntry {..} + +parseWhiteSpaces :: Parsec.Parsec String () String +parseWhiteSpaces = Parsec.try (Parsec.many1 Parsec.space) <|> Parsec.many1 Parsec.tab + +parseUnquotedString :: Parsec.Parsec String () String +parseUnquotedString = Parsec.many1 (Parsec.noneOf ['"', ' ', '\t', '\n', '\'', '\\', '\r']) + +parseRomeConfig :: Parsec.Parsec String () (String, [RomefileEntry]) +parseRomeConfig = do + s3BucketName <- parseS3BucketNameSection + Parsec.many Parsec.newline + romeFileEntries <- Parsec.option [] parseRepositoryMapSection + Parsec.manyTill parseWhiteSpaces Parsec.eof + return (s3BucketName, romeFileEntries) + +toRomeFilesEntriesMap :: [RomefileEntry] -> M.Map String String +toRomeFilesEntriesMap = M.fromList . map romeFileEntryToTuple + +romeFileEntryToTuple :: RomefileEntry -> (String, String) +romeFileEntryToTuple RomefileEntry {..} = (gitRepositoryName, frameworkCommonName) + +parse rule text = Parsec.parse rule "(source)" text diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..5a0abaf --- /dev/null +++ b/stack.yaml @@ -0,0 +1,66 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# http://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# resolver: ghcjs-0.1.0_ghc-7.10.2 +# resolver: +# name: custom-snapshot +# location: "./custom-snapshot.yaml" +resolver: lts-6.0 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# - location: +# git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# extra-dep: true +# subdirs: +# - auto-update +# - wai +# +# A package marked 'extra-dep: true' will only be built if demanded by a +# non-dependency (i.e. a user package), and its test suites and benchmarks +# will not be run. This is useful for tweaking upstream packages. +packages: +- '.' +# Dependency packages to be pulled from upstream that are not in the resolver +# (e.g., acme-missiles-0.3) +extra-deps: [] + +# Override default flag values for local packages and extra-deps +flags: {} + +# Extra package databases containing global packages +extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=1.1" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor \ No newline at end of file diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 0000000..cd4753f --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"