mega-sdist-0.3.0.3: mega-sdist.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
import ClassyPrelude.Conduit
import System.Directory
import Network.HTTP.Simple
import Data.Conduit.Tar
import Data.Conduit.Zlib (ungzip)
import System.Process.Typed
import System.FilePath
import Data.Conduit.Binary (sinkFileCautious)
import Data.Yaml (Value (..), decodeEither')
import Options.Applicative.Simple
import Paths_mega_sdist (version)
import System.IO.Temp (withSystemTempDirectory)
import qualified Data.ByteString.Lazy as L
import Data.Semigroup (Max (..), Option (..))
import qualified Data.Version
import Text.ParserCombinators.ReadP (readP_to_S)
import qualified Data.Text as T

getUrlHackage :: Package -> IO Request
getUrlHackage (Package _fp (PackageName a) (Version b)) =
    parseRequest $ unpack $ concat
        [ "https://s3.amazonaws.com/hackage.fpcomplete.com/package/"
        , a
        , "-"
        , b
        , ".tar.gz"
        ]

getPaths :: Value -> IO [FilePath]
getPaths value = maybe (error $ "getPaths failed: " ++ show value) return $ do
    Object top <- return value
    Object locals <- lookup "locals" top
    forM (toList locals) $ \l -> do
        Object o <- return l
        String path <- lookup "path" o
        return $ unpack path

data Args = Args
    { toTag :: !Bool
    , getDiffs :: !Bool
    , rawDirs :: ![FilePath]
    }

main :: IO ()
main = do
    (Args {..}, ()) <- simpleOptions
        $(simpleVersion version)
        "Check Haskell cabal package versions in a mega-repo"
        "Determines if the code present in this repo is the most current with Hackage"
        (Args
            <$> switch
                    ( long "gittag"
                   <> help "Call 'git tag' if all versions are ready for release"
                    )
            <*> switch
                    ( long "get-diffs"
                   <> help "Display the diffs between old and new version"
                    )
            <*> many
                    ( strArgument (metavar "DIR")
                    )
        )
        empty

    (queryBS, _) <- readProcess_ $ proc "stack" ["query"]
    queryValue <-
        case decodeEither' (toStrict queryBS) of
            Left e -> error $ "Could not parse 'stack query': " ++ show e
            Right x -> return x
    allDirs <- getPaths queryValue
    dirs <-
      if null rawDirs
        then return allDirs
        else do
          myPaths <- mapM (fmap addTrailingPathSeparator . canonicalizePath) rawDirs
          return $ filter (\y -> any (\x -> (x `isPrefixOf` y)) myPaths) (map addTrailingPathSeparator allDirs)

    whenM (doesDirectoryExist "tarballs") $ removeDirectoryRecursive "tarballs"
    createDirectoryIfMissing True "tarballs"

    tarballs <- forM dirs $ \dir -> do
        (_, output) <- readProcess_ $ proc "stack" ["sdist", dir]
        case lastMay $ map unpack $ words $ decodeUtf8 output of
            Just fp -> do
                let dest = "tarballs" </> takeFileName fp
                renameFile fp dest
                return dest
            Nothing -> error $ "Unexpected 'stack sdist' output in dir: " ++ dir

    m <- unionsWith mappend <$> mapM (go getDiffs) tarballs

    case lookup NoChanges m of
        Nothing -> return ()
        Just s -> do
            say "The following packages from Hackage have not changed:"
            mapM_ sayPackage $ keys s
            mapM_ (removeFile . packageFile) $ keys s

    case lookup DoesNotExist m of
        Nothing -> return ()
        Just s -> do
            say "\nThe following new packages exist locally:"
            forM_ (mapToList s) $ \(name, mdiff) -> do
                sayPackage name
                forM_ mdiff (L.hPut stdout)

    case lookup NeedsVersionBump m of
        Nothing -> do
            say "\nNo version bumps required, good to go!"
            when toTag $ do
                let pcs = fmap mkProcess
                         $ maybe [] keys $ lookup DoesNotExist m
                    mkProcess (Package _fp (PackageName name) (Version version)) =
                         proc "git" ["tag", unpack $ concat [name, "/", version]]
                mapM_ sayShow pcs
                mapM_ runProcess_ pcs
        Just s -> do
            say "\nThe following packages require a version bump:"
            forM_ (mapToList s) $ \(name, mdiff) -> do
                sayPackage name
                forM_ mdiff (L.hPut stdout)

data Status = DoesNotExist | NoChanges | NeedsVersionBump
    deriving (Show, Eq, Ord)

type Diff = LByteString

go :: Bool -- ^ get diffs
   -> FilePath
   -> IO (Map Status (Map Package (Maybe Diff)))
go getDiffs fp = do
    package <- parsePackage fp
    localFileHackage <- liftIO $ getHackageFile package
    localFileExists <- liftIO $ doesFileExist localFileHackage
    let handleFile = do
            let v = packageVersion package
            (isDiff, mdiff) <- compareTGZ getDiffs (packageName package) localFileHackage v fp v
            return $ if isDiff then (NeedsVersionBump, mdiff) else (NoChanges, Nothing)
    (status, mdiff) <-
        if localFileExists
            then handleFile
            else do
                reqH <- getUrlHackage package
                runResourceT $ httpSink reqH $ \resH -> do
                case () of
                  ()
                    | getResponseStatusCode resH `elem` [403, 404] -> do
                        mdiff <-
                          if getDiffs
                            then do
                                mlatest <- getLatestVersion (packageName package)
                                case mlatest of
                                  Nothing -> return Nothing
                                  Just (latest, latestv) -> do
                                    (isDiff, mdiff) <- liftIO $ compareTGZ getDiffs (packageName package) latest latestv fp (packageVersion package)
                                    return $ if isDiff then mdiff else Nothing
                            else return Nothing
                        return (DoesNotExist, mdiff)
                    | getResponseStatusCode resH == 403 -> return (DoesNotExist, Nothing)
                    | getResponseStatusCode resH == 200 -> do
                        liftIO $ createDirectoryIfMissing True $ takeDirectory localFileHackage
                        sinkFileCautious localFileHackage
                        liftIO handleFile
                    | otherwise -> error $ "Invalid status code: " ++ show (getResponseStatus resH)
    return $ singletonMap status $ singletonMap package mdiff

-- | Get the filepath for the latest version of a package from
-- Hackage, if it exists at all.
getLatestVersion :: MonadIO m => PackageName -> m (Maybe (FilePath, Version))
getLatestVersion name = liftIO $ do
    stack <- getAppUserDataDirectory "stack"
    let index = stack </> "indices" </> "Hackage" </> "00-index.tar"
    mversion <- runConduitRes
        $ sourceFile index
       .| untar
       .| withEntries yield
       .| foldMapC (parseVersionNumber name)
    case mversion of
        Option Nothing -> return Nothing
        Option (Just (Max version)) -> do
            let p = Package "" name $ toTextVersion version
            fp <- liftIO $ getHackageFile p
            req <- liftIO $ getUrlHackage p
            runResourceT $ httpSink req $ \res ->
              if getResponseStatusCode res == 200
                then do
                  liftIO $ createDirectoryIfMissing True $ takeDirectory fp
                  sinkFileCautious fp
                  return $ Just (fp, toTextVersion version)
                else error $ "Could not download from Hackage: " ++ show p

newtype PackageName = PackageName { unPackageName :: Text }
    deriving (Show, Eq, Ord)
newtype Version = Version { unVersion :: Text }
    deriving (Show, Eq, Ord)
data Package = Package
    { packageFile :: !FilePath
    , packageName :: !PackageName
    , packageVersion :: !Version
    }
    deriving (Show, Eq, Ord)

toTextVersion :: Data.Version.Version -> Version
toTextVersion = Version . pack . Data.Version.showVersion

parseVersionNumber :: PackageName
                   -- ^ target package we care about
                   -> Header
                   -> Option (Max Data.Version.Version)
parseVersionNumber pn header = Option $ fmap Max $ do
    [name, version, dotcabal] <- Just $ T.splitOn "/" $ pack fp
    guard $ PackageName name == pn
    guard $ name ++ ".cabal" == dotcabal
    listToMaybe $ map fst
                $ filter (null . snd)
                $ readP_to_S Data.Version.parseVersion
                $ unpack version
  where
    fp = headerFilePath header

parsePackage :: MonadThrow m => FilePath -> m Package
parsePackage fp =
    case stripSuffix ".tar.gz" $ pack $ takeFileName fp of
        Nothing -> error $ "Does not end with .tar.gz: " ++ unpack fp
        Just s -> do
            let s' = reverse s
                (b', a') = break (== '-') s'
                a = reverse $ drop 1 a'
                b = reverse b'
            return $ Package fp (PackageName a) (Version b)

sayPackage :: MonadIO m => Package -> m ()
sayPackage (Package _ (PackageName name) (Version version)) = say $ concat [name, "-", version]

getHackageFile :: Package -> IO FilePath
getHackageFile (Package _fp (PackageName a') (Version b')) = do
    stack <- getAppUserDataDirectory "stack"
    return $ stack </> "indices" </> "Hackage" </> "packages" </> a </> b </>
                concat [a, "-", b, ".tar.gz"]
  where
    a = unpack a'
    b = unpack b'

compareTGZ :: Bool -- ^ get diffs?
           -> PackageName
           -> FilePath
           -- ^ old tarball
           -> Version
           -- ^ old version
           -> FilePath
           -- ^ new tarball
           -> Version
           -- ^ new version
           -> IO (Bool, Maybe Diff)
compareTGZ getDiffs pn a av b bv = do
    a' <- getContents a
    b' <- getContents b
    let isDiff = a' /= b'
    mdiff <-
        if getDiffs && isDiff
            then withSystemTempDirectory "diff" $ \diff -> do
                let fill dir x = forM_ (mapToList (asMap x)) $ \(fp, bs) -> do
                      let fp' = dir </> fp
                      createDirectoryIfMissing True $ takeDirectory fp'
                      L.writeFile fp' bs
                fill (diff </> "old") a'
                fill (diff </> "new") b'
                let toNV v = concat
                        [ unpack (unPackageName pn)
                        , "-"
                        , unpack (unVersion v)
                        ]
                (_, out, _) <- readProcess $ setWorkingDir diff $ proc "diff"
                    [ "-r"
                    , "old" </> toNV av
                    , "new" </> toNV bv
                    ]
                return $ Just out
            else return Nothing
    return (a' /= b', mdiff)
  where
    getContents :: FilePath -> IO (Map FilePath LByteString)
    getContents fp = handleAny (onErr fp) $ runConduitRes
         $ sourceFile fp
        .| ungzip
        .| untar
        .| withEntries addEntry
        .| foldC

    onErr fp e = do
        say $ concat
            [ "Error opening tarball: "
            , pack fp
            , ", "
            , tshow e
            ]
        return mempty

    addEntry header
        | headerFileType header == FTNormal = do
            lbs <- sinkLazy
            yield $ asMap $ singletonMap (headerFilePath header) lbs
        | otherwise = return ()