From f52d86431808a53db3140f540566ce4e1c554b83 Mon Sep 17 00:00:00 2001 From: Tommaso Piazza Date: Mon, 15 Aug 2016 17:18:49 +0200 Subject: [PATCH] Finalizing listing --- Rome.cabal | 2 +- app/Main.hs | 4 +-- src/Lib.hs | 92 ++++++++++++++++++++++++++++++++++++++--------------- 3 files changed, 70 insertions(+), 28 deletions(-) diff --git a/Rome.cabal b/Rome.cabal index 963f3ff..fe78756 100644 --- a/Rome.cabal +++ b/Rome.cabal @@ -1,5 +1,5 @@ name: Rome -version: 0.2.0.1 +version: 0.3.0.1 synopsis: An S3 cache for Carthage description: Please see README.md homepage: https://github.com/blender/Rome diff --git a/app/Main.hs b/app/Main.hs index bbc8a05..68b5380 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -8,7 +8,7 @@ import Options.Applicative as Opts romeVersion :: String -romeVersion = "0.2.0.1" +romeVersion = "0.3.0.1" @@ -21,7 +21,7 @@ main = do Nothing -> putStrLn $ romeVersion ++ " - Romam uno die non fuisse conditam." Just romeOptions -> do env <- AWS.newEnv AWS.NorthVirginia AWS.Discover - l <- runExceptT $ donwloadORUpload env romeOptions + l <- runExceptT $ runRomeWithOptions env romeOptions case l of Right _ -> return () Left e -> putStrLn e diff --git a/src/Lib.hs b/src/Lib.hs index 5fa9649..60848d1 100644 --- a/src/Lib.hs +++ b/src/Lib.hs @@ -8,7 +8,7 @@ {- Exports -} module Lib ( parseRomeOptions - , donwloadORUpload + , runRomeWithOptions ) where @@ -38,10 +38,12 @@ import Text.Parsec.String {- Types -} -type Location = String -type Version = String -type Config = (AWS.Env, Bool) -type RomeMonad = ExceptT String IO +type Location = String +type Version = String +type FrameworkName = String +type GitRepoName = String +type Config = (AWS.Env, Bool) +type RomeMonad = ExceptT String IO data RepoHosting = GitHub | Git deriving (Eq, Show) @@ -52,13 +54,13 @@ data CartfileEntry = CartfileEntry { hosting :: RepoHosting } deriving (Show, Eq) -data RomefileEntry = RomefileEntry { gitRepositoryName :: String - , frameworkCommonName :: String +data RomefileEntry = RomefileEntry { gitRepositoryName :: GitRepoName + , frameworkCommonName :: FrameworkName } deriving (Show, Eq) -data RomeCommand = Upload [String] - | Download [String] +data RomeCommand = Upload [FrameworkName] + | Download [FrameworkName] | List ListMode deriving (Show, Eq) @@ -119,8 +121,8 @@ getRomefileEntries = do Left e -> throwError $ "Romefile parse error: " ++ show e Right (bucketName, entries) -> return (S3.BucketName $ T.pack bucketName, entries) -donwloadORUpload :: AWS.Env -> RomeOptions -> ExceptT String IO () -donwloadORUpload env (RomeOptions options verbose) = do +runRomeWithOptions :: AWS.Env -> RomeOptions -> ExceptT String IO () +runRomeWithOptions env (RomeOptions options verbose) = do cartfileEntries <- getCartfileEntires (s3BucketName, romefileEntries) <- getRomefileEntries case options of @@ -138,20 +140,21 @@ donwloadORUpload env (RomeOptions options verbose) = do Download names -> liftIO $ runReaderT (downloadFrameworksFromS3 s3BucketName (filterByNames cartfileEntries romefileEntries names)) (env, verbose) - List All -> sayLn "Will list all" - - List Missing -> sayLn "Will list only missing" - - List Present -> sayLn "Will list only present" + List listMode -> do + let frameworkAndVersions = constructFrameworksAndVersionsFrom cartfileEntries romefileEntries + existing <- liftIO $ runReaderT (probeForFrameworks s3BucketName frameworkAndVersions) (env, verbose) + let t = toInvertedRomeFilesEntriesMap romefileEntries + let namesVersionAndExisting = replaceKnownFrameworkNamesWitGitRepoNamesInProbeResults (toInvertedRomeFilesEntriesMap romefileEntries) . filterAccordingToListMode listMode $ zip frameworkAndVersions existing + liftIO $ mapM_ (printProbeResult listMode) namesVersionAndExisting where - constructFrameworksAndVersionsFrom cartfileEntries romefileEntries = zip (deriveFrameworkNames (toRomeFilesEntriesMap romefileEntries) cartfileEntries) (map version cartfileEntries) - filterByNames cartfileEntries romefileEntries = concatMap (constructFrameworksAndVersionsFrom cartfileEntries romefileEntries `filterByName`) + constructFrameworksAndVersionsFrom cartfileEntries romefileEntries = zip (deriveFrameworkNames (toRomeFilesEntriesMap romefileEntries) cartfileEntries) (map version cartfileEntries) + filterByNames cartfileEntries romefileEntries = concatMap (constructFrameworksAndVersionsFrom cartfileEntries romefileEntries `filterByName`) fromErrorMessage :: AWS.ErrorMessage -> String fromErrorMessage (AWS.ErrorMessage t) = T.unpack t -filterByName:: [(String, Version)] -> String -> [(String, Version)] +filterByName:: [(FrameworkName, Version)] -> FrameworkName -> [(FrameworkName, Version)] filterByName fs s = filter (\(name, version) -> name == s) fs uploadFrameworksToS3 s3Bucket = mapM_ (uploadFrameworkToS3 s3Bucket) @@ -174,10 +177,10 @@ uploadBinary s3BucketName binaryZip destinationPath frameworkName = do Left e -> sayLn $ "Error uploading " <> frameworkName <> " : " <> errorString e Right _ -> sayLn $ "Successfully uploaded " <> frameworkName <> " to: " <> destinationPath -downloadFrameworksFromS3 s3Bucket = mapM_ (downloadFrameworkFromS3 s3Bucket) +downloadFrameworksFromS3 s3BucketName = mapM_ (downloadFrameworkFromS3 s3BucketName) downloadFrameworkFromS3 s3BucketName (frameworkName, version) = do - let frameworkZipName = appendFrameworkExtensionTo frameworkName ++ "-" ++ version ++ ".zip" + let frameworkZipName = frameworkArchiveName (frameworkName, version) let frameworkObjectKey = S3.ObjectKey . T.pack $ frameworkName ++ "/" ++ frameworkZipName (env, verbose) <- ask runResourceT . AWS.runAWS env $ getFramework s3BucketName frameworkObjectKey frameworkZipName verbose @@ -193,30 +196,47 @@ getFramework s3BucketName frameworkObjectKey frameworkZipName verbose = do sayLn $ "Unzipped: " ++ frameworkZipName +probeForFrameworks s3BucketName = mapM (probeForFramework s3BucketName) + +probeForFramework s3BucketName (frameworkName, version) = do + let frameworkZipName = frameworkArchiveName (frameworkName, version) + let frameworkObjectKey = S3.ObjectKey . T.pack $ frameworkName ++ "/" ++ frameworkZipName + (env, verbose) <- ask + runResourceT . AWS.runAWS env $ checkIfFrameworkExistsInBucket s3BucketName frameworkObjectKey verbose + + +checkIfFrameworkExistsInBucket s3BucketName frameworkObjectKey verbose = do + rs <- AWS.trying AWS._Error (AWS.send $ S3.headObject s3BucketName frameworkObjectKey) + case rs of + Left e -> return False + Right hoResponse -> return True + errorString :: AWS.Error -> String errorString e = fromErrorMessage $ fromMaybe (AWS.ErrorMessage "Unexpected Error") maybeServiceError where maybeServiceError = view AWS.serviceMessage =<< (e ^? AWS._ServiceError) - sayLn :: MonadIO m => String -> m () sayLn = liftIO . putStrLn zipOptions :: Bool -> [Zip.ZipOption] zipOptions verbose = if verbose then [Zip.OptRecursive, Zip.OptVerbose] else [Zip.OptRecursive] -deriveFrameworkNames :: M.Map String String -> [CartfileEntry] -> [String] +deriveFrameworkNames :: M.Map GitRepoName Version -> [CartfileEntry] -> [FrameworkName] deriveFrameworkNames romeMap = map (deriveFrameworkName romeMap) -deriveFrameworkName :: M.Map String String -> CartfileEntry -> String +deriveFrameworkName :: M.Map GitRepoName Version -> CartfileEntry -> FrameworkName 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 :: FrameworkName -> String appendFrameworkExtensionTo a = a ++ ".framework" +frameworkArchiveName :: (String, Version) -> String +frameworkArchiveName (name, version) = appendFrameworkExtensionTo name ++ "-" ++ version ++ ".zip" + splitWithSeparator :: (Eq a) => a -> [a] -> [[a]] splitWithSeparator _ [] = [] splitWithSeparator a as = g as : splitWithSeparator a (dropTaken as as) @@ -225,6 +245,24 @@ splitWithSeparator a as = g as : splitWithSeparator a (dropTaken as as) g = takeWhile (/= a) . dropWhile (== a) dropTaken bs = drop $ numberOfAsIn bs + length (g bs) +printProbeResult :: MonadIO m => ListMode -> ((String, Version), Bool) -> m () +printProbeResult listMode ((frameworkName, version), present) | listMode == Missing || listMode == Present = sayLn frameworkName + | otherwise = sayLn $ frameworkName <> " " <> version <> " " <> printProbeStringForBool present + +printProbeStringForBool :: Bool -> String +printProbeStringForBool True = "✔︎" +printProbeStringForBool False = "✘" + +filterAccordingToListMode :: ListMode -> [((String, Version), Bool)] -> [((String, Version), Bool)] +filterAccordingToListMode All probeResults = probeResults +filterAccordingToListMode Missing probeResults = (\((name, version), present) -> not present) `filter`probeResults +filterAccordingToListMode Present probeResults = (\((name, version), present) -> present) `filter`probeResults + +replaceKnownFrameworkNamesWitGitRepoNamesInProbeResults :: M.Map FrameworkName GitRepoName -> [((FrameworkName, Version), Bool)] -> [((String, Version), Bool)] +replaceKnownFrameworkNamesWitGitRepoNamesInProbeResults reverseRomeMap = map (replaceResultIfFrameworkNameIsInMap reverseRomeMap) + where + replaceResultIfFrameworkNameIsInMap reverseRomeMap ((frameworkName, version), present) = ((fromMaybe frameworkName (M.lookup frameworkName reverseRomeMap), version), present) + -- Cartfile.resolved parsing @@ -294,6 +332,10 @@ parseRomeConfig = do toRomeFilesEntriesMap :: [RomefileEntry] -> M.Map String String toRomeFilesEntriesMap = M.fromList . map romeFileEntryToTuple +toInvertedRomeFilesEntriesMap :: [RomefileEntry] -> M.Map String String +toInvertedRomeFilesEntriesMap = M.fromList . map ( uncurry (flip (,)) . romeFileEntryToTuple) + + romeFileEntryToTuple :: RomefileEntry -> (String, String) romeFileEntryToTuple RomefileEntry {..} = (gitRepositoryName, frameworkCommonName)