ryantm/nixpkgs-update
1
1
Fork 0
mirror of https://github.com/ryantm/nixpkgs-update.git synced 2024-08-17 01:30:21 +03:00
Code Issues Packages Projects Releases Wiki Activity

use -Wall and fix all warnings

Browse Source
This commit is contained in:
Ryan Mulligan 2018-12-23 16:14:33 -08:00
parent 2ebd9c33db
commit 2d4fe9053a
15 changed files with 102 additions and 112 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -5,3 +5,4 @@ dist/
dist-newstyle/
/nixpkgs-update.cabal
/shell.nix
.ghc*

3
package.yaml
View File

@ -16,6 +16,8 @@ extra-source-files:
github: ryantm/nixpkgs-update
ghc-options: -Wall
dependencies:
- base >= 4.7 && < 5
- directory >= 1.3 && < 1.4
@ -37,6 +39,7 @@ dependencies:
- transformers
- lifted-base
- xdg-basedir
- template-haskell
executables:
nixpkgs-update:

30
src/Check.hs
View File

@ -91,10 +91,6 @@ checkReport (BinaryCheck p False False) =
checkReport (BinaryCheck p _ _) =
"- " <> toTextIgnore p <> " passed the binary check."
successfullCheck :: BinaryCheck -> Bool
successfullCheck (BinaryCheck _ False False) = False
successfullCheck _ = True
result :: UpdateEnv -> FilePath -> Sh Text
result updateEnv resultPath = do
let expectedVersion = newVersion updateEnv
@ -112,26 +108,26 @@ result updateEnv resultPath = do
if binExists
then findWhen test_f (resultPath </> "bin")
else return []
checks <- forM binaries $ \binary -> runChecks expectedVersion binary
addToReport (T.intercalate "\n" (map checkReport checks))
checks' <- forM binaries $ \binary -> runChecks expectedVersion binary
addToReport (T.intercalate "\n" (map checkReport checks'))
let passedZeroExitCode =
(T.pack . show)
(foldl
(\sum c ->
(\acc c ->
if zeroExitCode c
then sum + 1
else sum)
then acc + 1
else acc)
0
checks :: Int)
checks' :: Int)
passedVersionPresent =
(T.pack . show)
(foldl
(\sum c ->
(\acc c ->
if versionPresent c
then sum + 1
else sum)
then acc + 1
else acc)
0
checks :: Int)
checks' :: Int)
numBinaries = (T.pack . show) (length binaries)
addToReport
("- " <> passedZeroExitCode <> " of " <> numBinaries <>
@ -139,7 +135,7 @@ result updateEnv resultPath = do
addToReport
("- " <> passedVersionPresent <> " of " <> numBinaries <>
" passed binary check by having the new version present in output.")
Shell.canFail $ cmd "grep" "-r" expectedVersion resultPath
_ <- Shell.canFail $ cmd "grep" "-r" expectedVersion resultPath
whenM ((== 0) <$> lastExitCode) $
addToReport $
"- found " <> expectedVersion <> " with grep in " <>
@ -147,9 +143,7 @@ result updateEnv resultPath = do
whenM
(null <$>
findWhen
(\path ->
((expectedVersion `T.isInfixOf` toTextIgnore path) &&) <$>
test_f path)
(\p -> ((expectedVersion `T.isInfixOf` toTextIgnore p) &&) <$> test_f p)
resultPath) $
addToReport $
"- found " <> expectedVersion <> " in filename of file in " <>

21
src/Clean.hs
View File

@ -52,15 +52,16 @@ fixSrcUrl updateEnv derivationFile attrPath oldSrcUrl = do
do
let newName = name <> "-${version}"
File.replace newDerivationName newName derivationFile
cmd "grep" "-q" ("name = \"" <> newName <> "\"") derivationFile
cmd
"sed"
"-i"
("s|^\\([ ]*\\)\\(name = \"" <> name <>
"-${version}\";\\)|\\1\\2\\n\\1version = \"" <>
newVersion updateEnv <>
"\";|")
derivationFile
_ <- cmd "grep" "-q" ("name = \"" <> newName <> "\"") derivationFile
_ <-
cmd
"sed"
"-i"
("s|^\\([ ]*\\)\\(name = \"" <> name <>
"-${version}\";\\)|\\1\\2\\n\\1version = \"" <>
newVersion updateEnv <>
"\";|")
derivationFile
cmd
"grep"
"-q"
@ -96,7 +97,7 @@ fixSrcUrl updateEnv derivationFile attrPath oldSrcUrl = do
"${version}"
(T.replace newDerivationName "${name}" downloadUrl)
lift $ File.replace oldUrl newUrl derivationFile
lift $ cmd "grep" "-q" ("url = \"" <> newUrl <> "\";") derivationFile
_ <- lift $ cmd "grep" "-q" ("url = \"" <> newUrl <> "\";") derivationFile
whenM
(lift $
Shell.succeeded $

5
src/DeleteMerged.hs
View File

@ -6,14 +6,11 @@ module DeleteMerged
( deleteDone
) where
import OurPrelude
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Vector as V
import qualified GH
import qualified Git
import qualified Shell
import Utils (Options)
default (T.Text)
@ -24,6 +21,6 @@ deleteDone o = do
Git.cleanAndResetToMaster
result <- GH.closedAutoUpdateRefs o
case result of
Left error -> T.putStrLn error
Left e -> T.putStrLn e
Right refs ->
V.sequence_ (fmap (\r -> Git.deleteBranch ("auto-update/" <> r)) refs)

13
src/GH.hs
View File

@ -25,9 +25,8 @@ import Shelly hiding (tag)
import Utils
gReleaseUrl :: URLParts -> IO (Either Text Text)
gReleaseUrl (URLParts owner repo tag) =
bimap (T.pack . show) (getUrl . releaseHtmlUrl) <$>
releaseByTagName owner repo tag
gReleaseUrl (URLParts o r t) =
bimap (T.pack . show) (getUrl . releaseHtmlUrl) <$> releaseByTagName o r t
releaseUrl :: Text -> IO (Either Text Text)
releaseUrl url =
@ -51,14 +50,14 @@ parseURL url =
("GitHub: " <> url <> " is not a GitHub URL.")
("https://github.com/" `T.isPrefixOf` url)
let parts = T.splitOn "/" url
owner <- N <$> tryAt ("GitHub: owner part missing from " <> url) parts 3
repo <- N <$> tryAt ("GitHub: repo part missing from " <> url) parts 4
o <- N <$> tryAt ("GitHub: owner part missing from " <> url) parts 3
r <- N <$> tryAt ("GitHub: repo part missing from " <> url) parts 4
tagPart <- tryAt ("GitHub: tag part missing from " <> url) parts 6
tag <-
t <-
tryJust
("GitHub: tag part missing .tar.gz suffix " <> url)
(T.stripSuffix ".tar.gz" tagPart)
return $ URLParts owner repo tag
return $ URLParts o r t
compareUrl :: Text -> Text -> IO (Either Text Text)
compareUrl urlOld urlNew =

26
src/Git.hs
View File

@ -20,7 +20,7 @@ module Git
import OurPrelude
import qualified Data.Text as T
import Data.Time.Clock (UTCTime, addUTCTime, diffUTCTime, getCurrentTime)
import Data.Time.Clock (addUTCTime, getCurrentTime)
import qualified Shell
import Shelly
import System.Directory (getHomeDirectory, getModificationTime)
@ -33,10 +33,10 @@ clean = shelly $ cmd "git" "clean" "-fdx"
cleanAndResetTo :: MonadIO m => Text -> Text -> m ()
cleanAndResetTo branch target = do
shelly $ cmd "git" "reset" "--hard"
_ <- shelly $ cmd "git" "reset" "--hard"
clean
shelly $ cmd "git" "checkout" "-B" branch target
shelly $ cmd "git" "reset" "--hard" target
_ <- shelly $ cmd "git" "checkout" "-B" branch target
_ <- shelly $ cmd "git" "reset" "--hard" target
clean
cleanAndResetToMaster :: MonadIO m => m ()
@ -46,9 +46,9 @@ cleanAndResetToStaging :: MonadIO m => m ()
cleanAndResetToStaging = cleanAndResetTo "staging" "upstream/staging"
cleanup :: MonadIO m => Text -> m ()
cleanup branchName = do
cleanup bName = do
cleanAndResetToMaster
shelly $ Shell.canFail $ cmd "git" "branch" "-D" branchName
shelly $ Shell.canFail $ cmd "git" "branch" "-D" bName
showRef :: MonadIO m => Text -> m Text
showRef ref = shelly $ cmd "git" "show-ref" ref
@ -80,19 +80,19 @@ push updateEnv =
["--dry-run" | dryRun (options updateEnv)])
checkoutAtMergeBase :: MonadIO m => Text -> m ()
checkoutAtMergeBase branchName = do
checkoutAtMergeBase bName = do
base <-
T.strip <$>
shelly (cmd "git" "merge-base" "upstream/master" "upstream/staging")
shelly $ cmd "git" "checkout" "-B" branchName base
shelly $ cmd "git" "checkout" "-B" bName base
checkAutoUpdateBranchDoesntExist :: MonadIO m => Text -> ExceptT Text m ()
checkAutoUpdateBranchDoesntExist packageName = do
checkAutoUpdateBranchDoesntExist pName = do
remoteBranches <-
lift $
map T.strip . T.lines <$> shelly (silently $ cmd "git" "branch" "--remote")
when
(("origin/auto-update/" <> packageName) `elem` remoteBranches)
(("origin/auto-update/" <> pName) `elem` remoteBranches)
(throwE "Update branch already on origin.")
commit :: MonadIO m => Text -> m ()
@ -102,8 +102,8 @@ headHash :: MonadIO m => m Text
headHash = shelly $ cmd "git" "rev-parse" "HEAD"
deleteBranch :: MonadIO m => Text -> m ()
deleteBranch branchName =
deleteBranch bName =
shelly $
Shell.canFail $ do
cmd "git" "branch" "-D" branchName
cmd "git" "push" "origin" (":" <> branchName)
_ <- cmd "git" "branch" "-D" bName
cmd "git" "push" "origin" (":" <> bName)

6
src/Main.hs
View File

@ -41,10 +41,10 @@ programInfo =
makeOptions :: IO Options
makeOptions = do
dryRun <- isJust <$> getEnv "DRY_RUN"
dry <- isJust <$> getEnv "DRY_RUN"
homeDir <- T.pack <$> getHomeDirectory
githubToken <- T.strip <$> T.readFile "github_token.txt"
return $ Options dryRun (homeDir <> "/.nixpkgs-update") githubToken
token <- T.strip <$> T.readFile "github_token.txt"
return $ Options dry (homeDir <> "/.nixpkgs-update") token
main :: IO ()
main = do

6
src/Nix.hs
View File

@ -80,8 +80,8 @@ lookupAttrPath updateEnv =
Shell.shellyET &
overwriteErrorT "nix-env -q failed to find package name with old version"
getDerivationFile :: MonadIO m => UpdateEnv -> Text -> ExceptT Text m FilePath
getDerivationFile updateEnv attrPath =
getDerivationFile :: MonadIO m => Text -> ExceptT Text m FilePath
getDerivationFile attrPath =
cmd "env" "EDITOR=echo" "nix" "edit" attrPath "-f" "." & fmap T.strip &
fmap fromText &
Shell.shellyET &
@ -167,7 +167,7 @@ buildCmd =
build :: MonadIO m => Text -> ExceptT Text m ()
build attrPath =
(buildCmd attrPath & Shell.shellyET) <|>
(do buildFailedLog
(do _ <- buildFailedLog
throwE "nix log failed trying to get build logs")
where
buildFailedLog = do

4
src/OurPrelude.hs
View File

@ -1,3 +1,5 @@
{-# LANGUAGE PartialTypeSignatures #-}
module OurPrelude
( (>>>)
, (<|>)
@ -26,6 +28,8 @@ import Data.Semigroup ((<>))
import Data.Set (Set)
import Data.Text (Text)
import Data.Vector (Vector)
import Language.Haskell.TH.Quote
import qualified NeatInterpolation
interpolate :: QuasiQuoter
interpolate = NeatInterpolation.text

14
src/Outpaths.hs
View File

@ -16,10 +16,10 @@ import Shelly
import Text.Parsec (parse)
import Text.Parser.Char
import Text.Parser.Combinators
import Utils
default (Text)
outPathsExpr :: Text
outPathsExpr =
[interpolate|
@ -78,11 +78,12 @@ in
outPath :: Sh Text
outPath =
sub $ do
cmd
"curl"
"-o"
"outpaths.nix"
"https://raw.githubusercontent.com/NixOS/ofborg/released/ofborg/src/outpaths.nix"
_ <-
cmd
"curl"
"-o"
"outpaths.nix"
"https://raw.githubusercontent.com/NixOS/ofborg/released/ofborg/src/outpaths.nix"
setenv "GC_INITIAL_HEAP_SIZE" "10g"
cmd
"nix-env"
@ -107,6 +108,7 @@ data ResultLine = ResultLine
} deriving (Eq, Ord, Show)
-- Example query result line:
testInput :: Text
testInput =
"haskellPackages.amazonka-dynamodb-streams.x86_64-linux doc=/nix/store/m4rpsc9nx0qcflh9ni6qdlg6hbkwpicc-amazonka-dynamodb-streams-1.6.0-doc;/nix/store/rvd4zydr22a7j5kgnmg5x6695c7bgqbk-amazonka-dynamodb-streams-1.6.0\nhaskellPackages.agum.x86_64-darwin doc=/nix/store/n526rc0pa5h0krdzsdni5agcpvcd3cb9-agum-2.7-doc;/nix/store/s59r75svbjm724q5iaprq4mln5k6wcr9-agum-2.7"

10
src/Shell.hs
View File

@ -18,9 +18,9 @@ import Utils
-- | Set environment variables needed by various programs
setUpEnvironment :: Options -> Sh ()
setUpEnvironment options = do
setUpEnvironment o = do
setenv "PAGER" ""
setenv "GITHUB_TOKEN" (githubToken options)
setenv "GITHUB_TOKEN" (githubToken o)
ourSilentShell :: Options -> Sh a -> IO a
ourSilentShell o s =
@ -48,12 +48,12 @@ shE s = do
-- of it.
shRE :: Sh a -> Sh (Either Text Text)
shRE s = do
canFail s
_ <- canFail s
stderr <- lastStderr
status <- lastExitCode
case status of
0 -> return $ Left ""
c -> return $ Right stderr
_ -> return $ Right stderr
shellyET :: MonadIO m => Sh a -> ExceptT Text m a
shellyET = shE >>> shelly >>> ExceptT
@ -63,6 +63,6 @@ canFail = errExit False
succeeded :: Sh a -> Sh Bool
succeeded s = do
canFail s
_ <- canFail s
status <- lastExitCode
return (status == 0)

46
src/Update.hs
View File

@ -13,21 +13,19 @@ import OurPrelude
import qualified Blacklist
import qualified Check
import Clean (fixSrcUrl)
import Control.Exception (SomeException)
import Control.Exception.Lifted
import Data.IORef
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Time.Clock (UTCTime, addUTCTime, diffUTCTime, getCurrentTime)
import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime)
import Data.Time.Format (defaultTimeLocale, formatTime, iso8601DateFormat)
import qualified File
import qualified GH
import qualified Git
import qualified Nix
import Outpaths
import Prelude hiding (FilePath)
import Prelude hiding (FilePath, log)
import qualified Shell
import Shelly.Lifted
import Utils
@ -35,7 +33,6 @@ import Utils
, UpdateEnv(..)
, Version
, branchName
, eitherToError
, parseUpdates
, tRead
)
@ -48,6 +45,7 @@ data MergeBaseOutpathsInfo = MergeBaseOutpathsInfo
, mergeBaseOutpaths :: Set ResultLine
}
log' :: (MonadIO m, MonadSh m) => FilePath -> Text -> m ()
log' logFile msg
-- TODO: switch to Data.Time.Format.ISO8601 once time-1.9.0 is available
= do
@ -57,10 +55,10 @@ log' logFile msg
appendfile logFile (runDate <> " " <> msg <> "\n")
updateAll :: Options -> IO ()
updateAll options =
Shell.ourShell options $ do
let logFile = fromText (workingDir options) </> "ups.log"
mkdir_p (fromText (workingDir options))
updateAll o =
Shell.ourShell o $ do
let logFile = fromText (workingDir o) </> "ups.log"
mkdir_p (fromText (workingDir o))
touchfile logFile
updates <- readfile "packages-to-update.txt"
let log = log' logFile
@ -70,7 +68,7 @@ updateAll options =
liftIO $ addUTCTime (fromInteger $ -60 * 60 * 2) <$> getCurrentTime
mergeBaseOutpathSet <-
liftIO $ newIORef (MergeBaseOutpathsInfo twoHoursAgo S.empty)
updateLoop options log (parseUpdates updates) mergeBaseOutpathSet
updateLoop o log (parseUpdates updates) mergeBaseOutpathSet
updateLoop ::
Options
@ -79,28 +77,28 @@ updateLoop ::
-> IORef MergeBaseOutpathsInfo
-> Sh ()
updateLoop _ log [] _ = log "ups.sh finished"
updateLoop options log (Left e:moreUpdates) mergeBaseOutpathsContext = do
updateLoop o log (Left e:moreUpdates) mergeBaseOutpathsContext = do
log e
updateLoop options log moreUpdates mergeBaseOutpathsContext
updateLoop options log (Right (package, oldVersion, newVersion):moreUpdates) mergeBaseOutpathsContext = do
log (package <> " " <> oldVersion <> " -> " <> newVersion)
let updateEnv = UpdateEnv package oldVersion newVersion options
updateLoop o log moreUpdates mergeBaseOutpathsContext
updateLoop o log (Right (pName, oldVer, newVer):moreUpdates) mergeBaseOutpathsContext = do
log (pName <> " " <> oldVer <> " -> " <> newVer)
let updateEnv = UpdateEnv pName oldVer newVer o
updated <- updatePackage log updateEnv mergeBaseOutpathsContext
case updated of
Left failure -> do
liftIO $ Git.cleanup (branchName updateEnv)
log $ "FAIL " <> failure
if ".0" `T.isSuffixOf` newVersion
then let Just newNewVersion = ".0" `T.stripSuffix` newVersion
if ".0" `T.isSuffixOf` newVer
then let Just newNewVersion = ".0" `T.stripSuffix` newVer
in updateLoop
options
o
log
(Right (package, oldVersion, newNewVersion) : moreUpdates)
(Right (pName, oldVer, newNewVersion) : moreUpdates)
mergeBaseOutpathsContext
else updateLoop options log moreUpdates mergeBaseOutpathsContext
else updateLoop o log moreUpdates mergeBaseOutpathsContext
Right _ -> do
log "SUCCESS"
updateLoop options log moreUpdates mergeBaseOutpathsContext
updateLoop o log moreUpdates mergeBaseOutpathsContext
updatePackage ::
(Text -> Sh ())
@ -122,7 +120,7 @@ updatePackage log updateEnv mergeBaseOutpathsContext =
Blacklist.attrPath attrPath
masterShowRef <- lift $ Git.showRef "master"
lift $ log masterShowRef
derivationFile <- Nix.getDerivationFile updateEnv attrPath
derivationFile <- Nix.getDerivationFile attrPath
flip catches [Handler (\(ex :: SomeException) -> throwE (T.pack (show ex)))] $
-- Make sure it hasn't been updated on master
do
@ -130,8 +128,8 @@ updatePackage log updateEnv mergeBaseOutpathsContext =
Nix.assertOldVersionOn updateEnv "master" masterDerivationContents
-- Make sure it hasn't been updated on staging
Git.cleanAndResetToStaging
masterShowRef <- lift $ Git.showRef "staging"
lift $ log masterShowRef
stagingShowRef <- lift $ Git.showRef "staging"
lift $ log stagingShowRef
stagingDerivationContents <- lift $ readfile derivationFile
Nix.assertOldVersionOn updateEnv "staging" stagingDerivationContents
lift $ Git.checkoutAtMergeBase (branchName updateEnv)

17
src/Utils.hs
View File

@ -10,7 +10,6 @@ module Utils
, tRead
, parseUpdates
, overwriteErrorT
, eitherToError
, branchName
) where
@ -45,9 +44,10 @@ setupNixpkgs = do
fp <- getUserCacheDir "nixpkgs"
exists <- doesDirectoryExist fp
unless exists $ do
shelly $ run "hub" ["clone", "nixpkgs", T.pack fp] -- requires that user has forked nixpkgs
_ <- shelly $ run "hub" ["clone", "nixpkgs", T.pack fp] -- requires that user has forked nixpkgs
setCurrentDirectory fp
shelly $
_ <-
shelly $
cmd "git" "remote" "add" "upstream" "https://github.com/NixOS/nixpkgs"
shelly $ cmd "git" "fetch" "upstream"
setCurrentDirectory fp
@ -56,14 +56,6 @@ setupNixpkgs = do
overwriteErrorT :: MonadIO m => Text -> ExceptT Text m a -> ExceptT Text m a
overwriteErrorT t = fmapLT (const t)
rewriteError :: Monad m => Text -> m (Either Text a) -> m (Either Text a)
rewriteError t = fmap (first (const t))
eitherToError :: Monad m => (Text -> m a) -> m (Either Text a) -> m a
eitherToError errorExit s = do
e <- s
either errorExit return e
branchName :: UpdateEnv -> Text
branchName ue = "auto-update/" <> packageName ue
@ -71,8 +63,7 @@ parseUpdates :: Text -> [Either Text (Text, Version, Version)]
parseUpdates = map (toTriple . T.words) . T.lines
where
toTriple :: [Text] -> Either Text (Text, Version, Version)
toTriple [package, oldVersion, newVersion] =
Right (package, oldVersion, newVersion)
toTriple [package, oldVer, newVer] = Right (package, oldVer, newVer)
toTriple line = Left $ "Unable to parse update: " <> T.unwords line
tRead :: Read a => Text -> a

12
src/Version.hs
View File

@ -10,7 +10,7 @@ import qualified Data.Text as T
import Utils
notElemOf :: (Eq a, Foldable t) => t a -> a -> Bool
notElemOf options = not . flip elem options
notElemOf o = not . flip elem o
-- | Similar to @breakOn@, but will not keep the pattern at the beginning of the suffix.
--
@ -49,19 +49,19 @@ clearBreakOn boundary string =
-- >>> versionCompatibleWithPathPin "nodejs-slim-10_x" "10.12.0"
-- True
versionCompatibleWithPathPin :: Text -> Version -> Bool
versionCompatibleWithPathPin attrPath newVersion
versionCompatibleWithPathPin attrPath newVer
| "_x" `T.isSuffixOf` T.toLower attrPath =
versionCompatibleWithPathPin (T.dropEnd 2 attrPath) newVersion
versionCompatibleWithPathPin (T.dropEnd 2 attrPath) newVer
| "_" `T.isInfixOf` attrPath =
let attrVersionPart =
let (name, version) = clearBreakOn "_" attrPath
let (_, version) = clearBreakOn "_" attrPath
in if T.any (notElemOf ('_' : ['0' .. '9'])) version
then Nothing
else Just version
-- Check assuming version part has underscore separators
attrVersionPeriods = T.replace "_" "." <$> attrVersionPart
-- If we don't find version numbers in the attr path, exit success.
in maybe True (`T.isPrefixOf` newVersion) attrVersionPeriods
in maybe True (`T.isPrefixOf` newVer) attrVersionPeriods
| otherwise =
let attrVersionPart =
let version = T.dropWhile (notElemOf ['0' .. '9']) attrPath
@ -70,7 +70,7 @@ versionCompatibleWithPathPin attrPath newVersion
else Just version
-- Check assuming version part is the prefix of the version with dots
-- removed. For example, 91 => "9.1"
noPeriodNewVersion = T.replace "." "" newVersion
noPeriodNewVersion = T.replace "." "" newVer
-- If we don't find version numbers in the attr path, exit success.
in maybe True (`T.isPrefixOf` noPeriodNewVersion) attrVersionPart