diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # Revision history for iridium +## 0.1.5.8 -- 2018-10-02 + + * Add support for -Wcompat + * Reduce dependency footprint by using json endpoint of hackage interface + ## 0.1.5.7 -- 2017-08-01 * Adapt for cabal-2.0 - Note that this is a breaking change; uploading with diff --git a/data/default-iridium.yaml b/data/default-iridium.yaml --- a/data/default-iridium.yaml +++ b/data/default-iridium.yaml @@ -64,6 +64,7 @@ enabled: True compiler-warnings: enabled: True + enable-compat: True # whitelist: [only, these, tests] # not supported yet # blacklist: [omit, these, tests] # not supported yet diff --git a/iridium.cabal b/iridium.cabal --- a/iridium.cabal +++ b/iridium.cabal @@ -1,5 +1,5 @@ name: iridium -version: 0.1.5.7 +version: 0.1.5.8 synopsis: Automated Local Cabal Package Testing and Uploading license: BSD3 license-file: LICENSE @@ -71,7 +71,7 @@ -- other-modules: -- other-extensions: build-depends: - { base >=4.7 && <4.11 + { base >=4.8 && <4.11 , lifted-base >=0.2.3.6 && <0.3 , yaml >=0.8.16 && <0.9 , turtle >=1.3.0 && <1.4 @@ -82,8 +82,9 @@ , unordered-containers >=0.2.5.1 && <0.3 , multistate >=0.7.0.0 && <0.8 , Cabal >=1.22.5.0 && <1.25 - , http-conduit >=2.1.8 && <2.2 - , xmlhtml >=0.2.3.4 && <0.3 + , aeson >=1.4 && <1.5 + , network-uri >=2.6 && <2.7 + , HTTP >=4000.3 && <4000.4 , foldl >=1.1.5 && <1.3 , bytestring >=0.10.4.0 && <0.11 , tagged >=0.8.3 && <0.9 diff --git a/src-main/Main.hs b/src-main/Main.hs --- a/src-main/Main.hs +++ b/src-main/Main.hs @@ -29,8 +29,11 @@ import Paths_iridium +import Control.Exception +import Data.Functor + data Option = OptionHelp | OptionVersion @@ -51,38 +54,46 @@ main = do args <- System.Environment.getArgs let (opts, others, errs) = GetOpt.getOpt GetOpt.Permute optDescrs args - _ <- runMaybeT $ runMultiRWSTNil_ $ withMultiState initialLogState $ do - let - printHelp = do - liftIO $ putStrLn $ GetOpt.usageInfo initNote optDescrs - mzero - printVersion = do - liftIO $ putStrLn $ "iridium version " - ++ showVersion version - ++ ", (c) 2016 Lennart Spitzner" - mzero - when (not $ null errs) printHelp - when (not $ null others) printHelp - when (OptionHelp `elem` opts) printHelp - when (OptionVersion `elem` opts) printVersion - let verbosity = length $ filter (==OptionVerbose) $ opts - let levels = [ LogLevelSilent - , LogLevelPrint - , LogLevelDebug - , LogLevelTrace - , LogLevelWarn - , LogLevelError - , LogLevelThread - ] - ++ [ LogLevelInfo | verbosity > 0 ] - ++ [ LogLevelInfoVerbose | verbosity > 1 ] + let catcher f = (f $> ()) `catch` \e -> putStrLn "" >> print (e :: ErrorCall) + _ <- + catcher $ runMaybeT $ runMultiRWSTNil_ $ withMultiState initialLogState $ do + let printHelp = do + liftIO $ putStrLn $ GetOpt.usageInfo initNote optDescrs + mzero + printVersion = do + liftIO + $ putStrLn + $ "iridium version " + ++ showVersion version + ++ ", (c) 2016 Lennart Spitzner" + mzero + when (not $ null errs) printHelp + when (not $ null others) printHelp + when (OptionHelp `elem` opts) printHelp + when (OptionVersion `elem` opts) printVersion + let verbosity = length $ filter (==OptionVerbose) $ opts + let levels = + [ LogLevelSilent + , LogLevelPrint + , LogLevelDebug + , LogLevelTrace + , LogLevelWarn + , LogLevelError + , LogLevelThread + ] + ++ [ LogLevelInfo | verbosity > 0 ] + ++ [ LogLevelInfoVerbose | verbosity > 1 ] ++ [ LogLevelInfoVerboser | verbosity > 2 ] - ++ [ LogLevelInfoSpam | verbosity > 3 ] - setLogMask levels - let argConfig = if OptionDryRun `elem` opts - then Yaml.Object $ HM.singleton (Text.pack "process") - $ Yaml.Object $ HM.singleton (Text.pack "dry-run") - $ Yaml.Bool $ True - else Yaml.Object $ HM.empty - iridiumMain argConfig + ++ [ LogLevelInfoSpam | verbosity > 3 ] + setLogMask levels + let argConfig = if OptionDryRun `elem` opts + then + Yaml.Object + $ HM.singleton (Text.pack "process") + $ Yaml.Object + $ HM.singleton (Text.pack "dry-run") + $ Yaml.Bool + $ True + else Yaml.Object $ HM.empty + iridiumMain argConfig return () diff --git a/src/Development/Iridium.hs b/src/Development/Iridium.hs --- a/src/Development/Iridium.hs +++ b/src/Development/Iridium.hs @@ -108,14 +108,7 @@ $ PackageDescription.packageDescription $ packageDesc urlStr <- configReadStringM ["setup", "remote-server"] - latestVersionStrM <- retrieveLatestVersion urlStr pkgName - let latestVersionM = latestVersionStrM >>= \latestVersionStr -> - let parseResults = readP_to_S parseVersion latestVersionStr - in fmap fst - $ flip find parseResults - $ \r -> case r of - (_, "") -> True - _ -> False + latestVersionM <- retrieveLatestVersion urlStr pkgName pushLog LogLevelInfoVerbose $ "remote version: " ++ show (liftM showVersion latestVersionM) configDecideStringM ["repository", "type"] [ (,) "none" $ do diff --git a/src/Development/Iridium/Checks.hs b/src/Development/Iridium/Checks.hs --- a/src/Development/Iridium/Checks.hs +++ b/src/Development/Iridium/Checks.hs @@ -21,7 +21,7 @@ import qualified Data.Text.IO as Text.IO import qualified Turtle as Turtle import qualified Control.Foldl as Foldl -import qualified Network.HTTP.Conduit as HTTP +import qualified Network.HTTP as HTTP import qualified Data.ByteString as ByteString import qualified Data.ByteString.Lazy as ByteStringL @@ -36,10 +36,11 @@ import Data.Text ( Text ) import Data.Text.Encoding import Distribution.PackageDescription -import Data.Maybe ( maybeToList ) +import Data.Maybe ( maybeToList, fromMaybe ) import Data.ByteString ( ByteString ) import qualified Data.ByteString as ByteString import Filesystem.Path.CurrentOS hiding ( null ) +import Data.List ( isPrefixOf ) import qualified Distribution.Package import Distribution.Version @@ -74,6 +75,9 @@ "cabal" -> boolToError $ runCheck "Checking package validity" $ do mzeroToFalse $ runCommandSuccessCabal ["check"] + "cabal-new" -> boolToError $ runCheck "Checking package validity" $ do + mzeroToFalse $ + runCommandSuccessCabal ["check"] "stack" -> do -- stack has no "check". -- and no "upload --dry-run either." @@ -258,24 +262,32 @@ checks werror = do buildtool <- configReadStringM ["setup", "buildtool"] testsEnabled <- configIsEnabledM ["checks", "testsuites"] + shouldCompat <- do + c <- configIsTrueMaybeM ["checks", "compiler-warnings", "enable-compat"] + pure $ fromMaybe False c case buildtool of "cabal" -> mzeroToFalse $ do let testsArg = ["--enable-tests" | testsEnabled] let werrorArg = ["--ghc-options=\"-Werror\"" | werror] ++ ["--ghc-options=\"-w\"" | not werror] + let wcompatArg = if shouldCompat + then ["--ghc-options=\"-Wcompat\""] + else [] withDefaultCompiler <- createDefaultCompilerFlag runCommandSuccessCabal ["clean"] runCommandSuccessCabal $ ["install"] ++ withDefaultCompiler ++ ["--dep"] ++ testsArg - runCommandSuccessCabal $ ["configure"] ++ withDefaultCompiler ++ testsArg ++ werrorArg + runCommandSuccessCabal $ ["configure"] ++ withDefaultCompiler ++ testsArg ++ werrorArg ++ wcompatArg runCommandSuccessCabal ["build"] when testsEnabled $ runCommandSuccessCabal ["test"] return True + "cabal-new" -> + error "compile not supported in cabal-new" "stack" -> do pushLog LogLevelError "TODO: stack build" mzero - _ -> mzero + _ -> error "strange buildtool" documentation :: ( MonadIO m @@ -297,10 +309,12 @@ runCommandSuccessCabal $ ["install", "--dep"] ++ withDefaultCompiler runCommandSuccessCabal $ ["configure"] ++ withDefaultCompiler runCommandSuccessCabal $ ["haddock"] + "cabal-new" -> + error "documentation not supported with cabal-new!" "stack" -> do pushLog LogLevelError "TODO: stack build" return False - _ -> error "lkajsdlkjasd" + _ -> error "strange buildtool" compileVersions :: forall m @@ -357,23 +371,47 @@ pushLog LogLevelError $ "Expected string in config for " ++ show confList mzero Just x -> return x + shouldCompat <- do + c <- configIsTrueMaybeM ["checks", "compiler-warnings", "enable-compat"] + pure $ case c of + Just True -> not $ ("ghc-7" `isPrefixOf` compilerStr) + _ -> False mzeroToFalse $ do let testsArg = ["--enable-tests" | testsEnabled] let werrorArg = ["--ghc-options=\"-Werror\"" | werror] ++ ["--ghc-options=\"-w\"" | not werror] + let wcompatArg = if shouldCompat + then ["--ghc-options=\"-Wcompat\""] + else [] runCommandSuccessCabal ["clean"] runCommandSuccessCabal $ ["install", "--dep", "-w" ++ compilerPath] ++ testsArg runCommandSuccessCabal $ ["configure", "-w" ++ compilerPath] ++ testsArg ++ werrorArg + ++ wcompatArg runCommandSuccessCabal ["build"] when testsEnabled $ runCommandSuccessCabal ["test"] + "cabal-new" -> do + let confList = ["setup", "compiler-paths", compilerStr] + compilerPathMaybe <- configReadStringMaybeM confList + compilerPath <- case compilerPathMaybe of + Nothing -> do + pushLog LogLevelError $ "Expected string in config for " ++ show confList + mzero + Just x -> return x + mzeroToFalse $ do + let testsArg = ["--enable-tests" | testsEnabled] + Turtle.rmtree (Turtle.fromString "dist-newstyle/cache") + runCommandSuccessCabal $ ["new-build", "--project-file=cabal.project." ++ compilerStr] + ++ testsArg + when testsEnabled $ + runCommandSuccessCabal $ ["new-test", "-w" ++ compilerPath] ++ testsArg "stack" -> do pushLog LogLevelError "TODO: stack build" mzero - _ -> mzero + _ -> error "strange buildtool" } upperBoundsStackage @@ -410,8 +448,7 @@ cabalConfigContents <- fetchCabalConfig urlStr pName <- liftM (Text.pack . (\(Distribution.Package.PackageName n) -> n)) askPackageName let filteredLines = filter (not . (pName `Text.isInfixOf`)) - $ Text.lines - $ decodeUtf8 cabalConfigContents + $ Text.lines cabalConfigContents -- pushLog LogLevelDebug $ "Writing n lines to cabal.config: " ++ show (length filteredLines) liftIO $ Text.IO.writeFile (encodeString cabalConfigPath) (Text.unlines filteredLines) let testsArg = ["--enable-tests" | testsEnabled] @@ -448,21 +485,27 @@ "stack" -> do pushLog LogLevelError "TODO: stack upper bound check" mzero - _ -> mzero + _ -> error "strange buildtool" where fetchCabalConfig :: forall m0 . ( MonadIO m0 , MonadMultiState LogState m0 + , MonadPlus m0 ) => String - -> m0 ByteString + -> m0 Text fetchCabalConfig urlStr = do pushLog LogLevelInfoVerbose $ "Fetching up-to-date cabal.config from " ++ urlStr -- TODO: exception handling - r <- HTTP.simpleHttp urlStr - return $ ByteString.concat $ ByteStringL.toChunks $ r + e <- liftIO $ HTTP.simpleHTTP (HTTP.getRequest urlStr) + case e of + Left err -> do + pushLog LogLevelError + $ "Error: failed fetching stackage cabal.config! " ++ show err + mzero + Right r -> return $ Text.pack $ HTTP.rspBody r -- url <- case URI.parseURI urlStr of -- Nothing -> do -- pushLog LogLevelError "bad URI" @@ -503,7 +546,12 @@ let sdistName = pName ++ "-" ++ currentVersionStr ++ ".tar.gz" withDefaultCompiler <- createDefaultCompilerFlag runCommandSuccessCabal $ ["install", "dist/" ++ sdistName] ++ withDefaultCompiler + "cabal-new" -> error "not supported in cabal-new" + -- mzeroToFalse $ do + -- runCommandSuccessCabal ["sdist"] + -- Turtle.rmtree (Turtle.fromString "dist-newstyle/cache") + -- runCommandSuccessCabal $ ["new-build", "--project-file=cabal.project.disttest"] "stack" -> do pushLog LogLevelError "TODO: stack upper bound check" mzero - _ -> mzero + _ -> error "strange buildtool" diff --git a/src/Development/Iridium/ExternalProgWrappers.hs b/src/Development/Iridium/ExternalProgWrappers.hs --- a/src/Development/Iridium/ExternalProgWrappers.hs +++ b/src/Development/Iridium/ExternalProgWrappers.hs @@ -87,6 +87,7 @@ -> m () runCommandSuccess c ps = falseToMZero $ do let infoStr = c ++ " " ++ intercalate " " ps + pushLog LogLevelInfo $ infoStr withStack infoStr $ do outListRef <- liftIO $ newIORef [] exitCode <- withStack "" $ do -- the additional stack elem is for @@ -112,7 +113,6 @@ case exitCode of ExitSuccess -> do - pushLog LogLevelInfo $ infoStr return True ExitFailure _ -> do pushLog LogLevelPrint infoStr diff --git a/src/Development/Iridium/Hackage.hs b/src/Development/Iridium/Hackage.hs --- a/src/Development/Iridium/Hackage.hs +++ b/src/Development/Iridium/Hackage.hs @@ -19,9 +19,13 @@ import qualified Turtle as Turtle import System.Exit -import qualified Network.HTTP.Conduit as HTTP -import qualified Text.XmlHtml as Html +import qualified Network.HTTP as HTTP +import qualified Network.URI as URI import qualified Data.Text as Text +import qualified Data.Aeson as Aeson +import qualified Data.HashMap.Strict as HM +import qualified Text.ParserCombinators.ReadP as ReadP +import Data.List (find) import System.Process hiding ( cwd ) @@ -40,52 +44,39 @@ , MonadMultiState LogState m , MonadPlus m ) - => String -> String -> m (Maybe String) + => String -> String -> m (Maybe Version) retrieveLatestVersion remoteUrl pkgName = do let urlStr :: String = remoteUrl ++ "/package/" ++ pkgName ++ "/preferred" pushLog LogLevelInfo $ "Looking up latest version from hackage via url " ++ urlStr - -- url <- case URI.parseURI urlStr of - -- Nothing -> do - -- pushLog LogLevelError "bad URI" - -- mzero - -- Just u -> return u - -- result <- liftIO $ HTTP.simpleHTTP (HTTP.mkRequest HTTP.GET url) - -- rawHtml <- case result of - -- Left _ -> do - -- pushLog LogLevelError "Error: Could not retrieve hackage version" - -- mzero - -- Right x -> return $ HTTP.rspBody x - -- TODO: error handling + uri <- case URI.parseURI urlStr of + Nothing -> do + pushLog LogLevelError "bad URI" + mzero + Just u -> return u + let request = HTTP.insertHeader HTTP.HdrAccept "application/json" + $ HTTP.mkRequest HTTP.GET uri - rawHtmlE <- liftIO $ try $ HTTP.simpleHttp urlStr - case rawHtmlE of - Left (_::HTTP.HttpException) -> return Nothing - Right rawHtml -> case Html.parseHTML "hackage:response" - $ ByteString.concat - $ ByteStringL.toChunks rawHtml of - Left e -> do - pushLog LogLevelError e + rawHtmlE <- liftIO $ HTTP.simpleHTTP request + let parseError = do + pushLog LogLevelError "Could not decode hackage response." mzero - Right x -> do - let mStr = fmap (Text.unpack . Html.nodeText) - $ ( listToMaybe . Html.childNodes ) - =<< listToMaybe - ( reverse - $ Html.descendantElementsTag (Text.pack "a") - ( head - $ Html.docContent - $ x - ) - ) - case mStr of - Nothing -> do - pushLog LogLevelError "Error: Could not decode hackage response." - mzero - Just s -> do - pushLog LogLevelInfoVerbose $ "got: " ++ s - return $ Just s + case rawHtmlE of + Left{} -> return Nothing + Right r -> case Aeson.decode $ HTTP.rspBody r of + Just m -> case HM.lookup (Text.pack "normal-version") m of + Nothing -> parseError + Just [] -> pure Nothing + Just (vs :: [String]) -> do + let v :: Version = maximum $ parseVersionF <$> vs + pure $ Just v + Nothing -> parseError + where + parseVersionF s = case find (null . snd) $ ReadP.readP_to_S parseVersion s of + Nothing -> error "parseVersionF" + Just (v, _) -> v + uploadPackage :: forall m . ( MonadIO m @@ -121,6 +112,28 @@ Nothing Nothing Nothing Nothing Nothing >>= waitForProcess pushLog LogLevelPrint "Upload successful." + "cabal-new" -> do + (PackageName pname) <- askPackageName + pvers <- askPackageVersion + username <- configReadStringMaybeM ["setup", "hackage", "username"] + password <- configReadStringMaybeM ["setup", "hackage", "password"] + + let filePath = "dist/" ++ pname ++ "-" ++ showVersion pvers ++ ".tar.gz" + mzeroIfNonzero $ liftIO $ + runProcess "cabal" ["sdist"] Nothing Nothing Nothing Nothing Nothing + >>= waitForProcess + mzeroIfNonzero $ liftIO $ + runProcess "cabal" + ( [ "upload" + , "--publish" + , filePath + ] + ++ ["-u" ++ u | u <- maybeToList username] + ++ ["-p" ++ p | p <- maybeToList password] + ) + Nothing Nothing Nothing Nothing Nothing + >>= waitForProcess + pushLog LogLevelPrint "Upload successful." "stack" -> do pushLog LogLevelError "TODO: stack upload" mzero @@ -146,6 +159,7 @@ runProcess "cabal" ( [ "upload" , "--doc" + , "--publish" ] ++ ["-u" ++ u | u <- maybeToList username] ++ ["-p" ++ p | p <- maybeToList password] @@ -157,4 +171,4 @@ "stack" -> do pushLog LogLevelError "TODO: stack upload" mzero - _ -> mzero + _ -> error "uploadDocs not supported in cabal-new"