e505c03bcc
nukeFile replaced with removeWhenExistsWith removeLink, which allows using RawFilePath. Utility.Directory cannot use RawFilePath since setup does not depend on posix. This commit was sponsored by Graham Spencer on Patreon.
255 lines
8 KiB
Haskell
255 lines
8 KiB
Haskell
{- Downloads git-annex autobuilds and installs them into the git-annex
|
|
- repository in ~/lib/downloads that is used to distribute git-annex
|
|
- releases.
|
|
-
|
|
- Generates info files, containing the version (of the corresponding file
|
|
- from the autobuild).
|
|
-
|
|
- Builds standalone rpms from the standalone tarballs, and populates
|
|
- a rpm package repository with them using the createrepo program.
|
|
-
|
|
- Also gpg signs the files.
|
|
-}
|
|
|
|
import Annex.Common
|
|
import Types.Distribution
|
|
import Build.Version (getChangelogVersion, Version)
|
|
import Utility.UserInfo
|
|
import Utility.Url
|
|
import Utility.Tmp.Dir
|
|
import Utility.Metered
|
|
import qualified Git.Construct
|
|
import qualified Annex
|
|
import Annex.Content
|
|
import Annex.WorkTree
|
|
import Git.Command
|
|
|
|
import Data.Time.Clock
|
|
import Data.Char
|
|
import Data.Either
|
|
import System.Posix.Directory
|
|
|
|
-- git-annex distribution signing key (for Joey Hess)
|
|
signingKey :: String
|
|
signingKey = "89C809CB"
|
|
|
|
-- URL to an autobuilt git-annex file, and the place to install
|
|
-- it in the repository.
|
|
autobuilds :: [(URLString, FilePath)]
|
|
autobuilds =
|
|
(map linuxarch ["i386", "amd64", "armel", "arm64", "i386-ancient"]) ++
|
|
[ (autobuild "x86_64-apple-yosemite/git-annex.dmg", "git-annex/OSX/current/10.10_Yosemite/git-annex.dmg")
|
|
, (autobuild "windows/git-annex-installer.exe", "git-annex/windows/current/git-annex-installer.exe")
|
|
]
|
|
where
|
|
linuxarch a =
|
|
( autobuild (a ++ "/git-annex-standalone-" ++ a ++ ".tar.gz")
|
|
, "git-annex/linux/current/git-annex-standalone-" ++ a ++ ".tar.gz"
|
|
)
|
|
autobuild f = "https://downloads.kitenet.net/git-annex/autobuild/" ++ f
|
|
|
|
-- Names of architectures in standalone tarballs and the corresponding
|
|
-- rpm architecture.
|
|
tarrpmarches :: [(String, String)]
|
|
tarrpmarches =
|
|
[ ("i386", "i386")
|
|
, ("amd64", "x86_64")
|
|
, ("arm64", "aarch64")
|
|
]
|
|
|
|
main :: IO ()
|
|
main = do
|
|
useFileSystemEncoding
|
|
version <- getChangelogVersion
|
|
repodir <- getRepoDir
|
|
topdir <- getCurrentDirectory
|
|
changeWorkingDirectory repodir
|
|
updated <- catMaybes <$> mapM (getbuild repodir) autobuilds
|
|
state <- Annex.new =<< Git.Construct.fromPath "."
|
|
ood <- Annex.eval state $ do
|
|
buildrpms topdir updated
|
|
makeinfos updated version
|
|
syncToArchiveOrg
|
|
unless (null ood) $
|
|
error $ "Some info files are out of date: " ++ show (map fst ood)
|
|
|
|
-- Download a build from the autobuilder, virus check it, and return its
|
|
-- version.
|
|
-- It's very important that the version matches the build, otherwise
|
|
-- auto-upgrades can loop reatedly. So, check build-version before
|
|
-- and after downloading the file.
|
|
getbuild :: FilePath -> (URLString, FilePath) -> IO (Maybe (FilePath, Version))
|
|
getbuild repodir (url, f) = do
|
|
bv1 <- getbv
|
|
let dest = repodir </> f
|
|
let tmp = dest ++ ".tmp"
|
|
removeWhenExistsWith removeFile tmp
|
|
createDirectoryIfMissing True (parentDir dest)
|
|
let oops s = do
|
|
removeWhenExistsWith removeFile tmp
|
|
putStrLn $ "*** " ++ s
|
|
return Nothing
|
|
uo <- defUrlOptions
|
|
ifM (isRight <$> download nullMeterUpdate url tmp uo)
|
|
( ifM (liftIO $ virusFree tmp)
|
|
( do
|
|
bv2 <- getbv
|
|
case bv2 of
|
|
Nothing -> oops $ "no build-version file for " ++ url
|
|
(Just v)
|
|
| bv2 == bv1 -> do
|
|
removeWhenExistsWith removeFile dest
|
|
renameFile tmp dest
|
|
-- remove git rev part of version
|
|
let v' = takeWhile (/= '-') v
|
|
return $ Just (f, v')
|
|
| otherwise -> oops $ "build version changed while downloading " ++ url ++ " " ++ show (bv1, bv2)
|
|
, oops $ "VIRUS detected in " ++ url
|
|
)
|
|
, oops $ "failed to download " ++ url
|
|
)
|
|
where
|
|
bvurl = takeDirectory url ++ "/build-version"
|
|
getbv = do
|
|
bv <- catchDefaultIO "" $ readProcess "curl" ["--silent", bvurl]
|
|
return $ if null bv || any (not . versionchar) bv then Nothing else Just bv
|
|
versionchar c = isAlphaNum c || c == '.' || c == '-'
|
|
|
|
makeinfos :: [(FilePath, Version)] -> Version -> Annex [([Char], Maybe GitAnnexDistribution)]
|
|
makeinfos updated version = do
|
|
mapM_ (\f -> inRepo $ runBool [Param "annex", Param "add", File f]) (map fst updated)
|
|
void $ inRepo $ runBool
|
|
[ Param "commit"
|
|
, Param "-a"
|
|
, Param ("-S" ++ signingKey)
|
|
, Param "-m"
|
|
, Param $ "publishing git-annex " ++ version
|
|
]
|
|
now <- liftIO getCurrentTime
|
|
liftIO $ putStrLn $ "building info files"
|
|
forM_ updated $ \(f, bv) -> do
|
|
v <- lookupKey (toRawFilePath f)
|
|
case v of
|
|
Nothing -> noop
|
|
Just k -> whenM (inAnnex k) $ do
|
|
liftIO $ putStrLn f
|
|
let infofile = f ++ ".info"
|
|
let d = GitAnnexDistribution
|
|
{ distributionUrl = mkUrl f
|
|
, distributionKey = fromKey id k
|
|
, distributionVersion = bv
|
|
, distributionReleasedate = now
|
|
, distributionUrgentUpgrade = Just "6.20180626"
|
|
}
|
|
liftIO $ writeFile infofile $ formatInfoFile d
|
|
void $ inRepo $ runBool [Param "add", File infofile]
|
|
signFile infofile
|
|
signFile f
|
|
void $ inRepo $ runBool
|
|
[ Param "commit"
|
|
, Param ("-S" ++ signingKey)
|
|
, Param "-m"
|
|
, Param $ "updated info files for git-annex " ++ version
|
|
]
|
|
void $ inRepo $ runBool
|
|
[ Param "annex"
|
|
, Param "move"
|
|
, Param "--to"
|
|
, Param "website"
|
|
, Param "--force"
|
|
]
|
|
void $ inRepo $ runBool
|
|
[ Param "annex"
|
|
, Param "sync"
|
|
]
|
|
|
|
-- Check for out of date info files.
|
|
infos <- liftIO $ filter (".info" `isSuffixOf`)
|
|
<$> dirContentsRecursive "git-annex"
|
|
ds <- liftIO $ forM infos (readish <$$> readFile)
|
|
let dis = zip infos ds
|
|
let ood = filter outofdate dis
|
|
return ood
|
|
where
|
|
outofdate (_, md) = case md of
|
|
Nothing -> True
|
|
Just d -> distributionVersion d /= version
|
|
|
|
getRepoDir :: IO FilePath
|
|
getRepoDir = do
|
|
home <- liftIO myHomeDir
|
|
return $ home </> "lib" </> "downloads"
|
|
|
|
mkUrl :: FilePath -> String
|
|
mkUrl f = "https://downloads.kitenet.net/" ++ f
|
|
|
|
signFile :: FilePath -> Annex ()
|
|
signFile f = do
|
|
void $ liftIO $ boolSystem "gpg"
|
|
[ Param "-a"
|
|
, Param $ "--default-key=" ++ signingKey
|
|
, Param "--detach-sign"
|
|
, File f
|
|
]
|
|
liftIO $ rename (f ++ ".asc") (f ++ ".sig")
|
|
void $ inRepo $ runBool [Param "add", File (f ++ ".sig")]
|
|
|
|
-- clamscan should handle unpacking archives, but did not in my
|
|
-- testing, so do it manually.
|
|
virusFree :: FilePath -> IO Bool
|
|
virusFree f
|
|
| ".tar.gz" `isSuffixOf` f = unpack $ \tmpdir ->
|
|
boolSystem "tar" [ Param "xf", File f, Param "-C", File tmpdir ]
|
|
| ".dmg" `isSuffixOf` f = unpack $ \tmpdir -> do
|
|
-- 7z can extract partitions from a dmg, and then
|
|
-- run on partitions can extract their files
|
|
unhfs tmpdir f
|
|
parts <- filter (".hfs" `isSuffixOf`) <$> getDirectoryContents tmpdir
|
|
forM_ parts $ unhfs tmpdir
|
|
return True
|
|
| otherwise = clamscan f
|
|
where
|
|
clamscan f' = boolSystem "clamscan"
|
|
[ Param "--no-summary"
|
|
, Param "-r"
|
|
, Param f'
|
|
]
|
|
unpack unpacker = withTmpDir "clamscan" $ \tmpdir -> do
|
|
unlessM (unpacker tmpdir) $
|
|
error $ "Failed to unpack " ++ f ++ " for virus scan"
|
|
clamscan tmpdir
|
|
unhfs dest f' = unlessM (boolSystem "7z" [ Param "x", Param ("-o" ++ dest), File f' ]) $
|
|
error $ "Failed extracting hfs " ++ f'
|
|
|
|
buildrpms :: FilePath -> [(FilePath, Version)] -> Annex ()
|
|
buildrpms topdir l = do
|
|
liftIO $ createDirectoryIfMissing True rpmrepo
|
|
oldrpms <- map (rpmrepo </>) . filter (".rpm" `isSuffixOf`)
|
|
<$> liftIO (getDirectoryContents rpmrepo)
|
|
forM_ tarrpmarches $ \(tararch, rpmarch) ->
|
|
forM_ (filter (isstandalonetarball tararch . fst) l) $ \(tarball, v) -> do
|
|
liftIO $ mapM_ (removeWhenExistsWith removeLink) (filter ((rpmarch ++ ".rpm") `isSuffixOf`) oldrpms)
|
|
void $ liftIO $ boolSystem script
|
|
[ Param rpmarch
|
|
, File tarball
|
|
, Param v
|
|
, File rpmrepo
|
|
]
|
|
void $ inRepo $ runBool [Param "annex", Param "get", File rpmrepo]
|
|
void $ liftIO $ boolSystem "createrepo" [File rpmrepo]
|
|
void $ inRepo $ runBool [Param "annex", Param "add", File rpmrepo]
|
|
where
|
|
isstandalonetarball tararch f =
|
|
("git-annex-standalone-" ++ tararch ++ ".tar.gz") `isSuffixOf` f
|
|
script = topdir </> "standalone" </> "rpm" </> "rpmbuild-from-standalone-tarball"
|
|
rpmrepo = "git-annex/linux/current/rpms"
|
|
|
|
-- My .mrconfig is configured to copy new files to archive.org,
|
|
-- and moves old versions of content to archive.org to free up space on my
|
|
-- server.
|
|
syncToArchiveOrg :: IO ()
|
|
syncToArchiveOrg = void $ boolSystem "mr"
|
|
[ Param "-d"
|
|
, File "/srv/web/downloads.kitenet.net"
|
|
, Param "update"
|
|
]
|