mega-sdist-0.3.1: 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 hiding (header, value)
import qualified Paths_mega_sdist as Paths (version)
import System.IO (hIsTerminalDevice)
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 Paths.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
toColor <- hIsTerminalDevice stdout
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
sayDiff toColor mdiff
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)) =
let ident = concat [name, "-", version]
msg = "Release: " ++ ident
in proc "git" ["tag", "-s", unpack ident, "-m", unpack msg]
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
sayDiff toColor mdiff
sayDiff :: Bool -- ^ use color?
-> Maybe Diff -> IO ()
sayDiff toColor = mapM_ $ L.hPut stdout . (if toColor then colorize else id)
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 indexTar = stack </> "indices" </> "Hackage" </> "00-index.tar"
mversion <- runConduitRes
$ sourceFile indexTar
.| untarChunks
.| 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"
[ "-ruN"
, "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
.| untarChunks
.| 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 ()
colorize :: LByteString -> LByteString
colorize =
intercalate "\n" . map colorLine . L.split 10
where
colorLine :: LByteString -> LByteString
colorLine l =
case (toEnum . fromEnum) <$> headMay l of
Just '-' -> add "31" l
Just '+' -> add "32" l
Just '@' -> add "34" l
_ -> l
add :: LByteString -> LByteString -> LByteString
add color l = concat
[ "\x1b["
, color
, "m"
, l
, "\x1b[0m"
]