diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,30 @@ +# Revision history for iridium + +## 0.1.5.1 -- 2016-03-11 + + * Fix iridium package pvp compliance (lower bounds) + +## 0.1.5.0 -- 2016-03-11 + + * Add package-sdist check + + * Prepare non-static default config + +## 0.1.4.0 -- 2016-02-22 + + * Fix various bugs + + * Make various changes to the default iridium.yaml + + * Fix/Expand basic git functionality; it includes: + * Displaying current branch + * Tagging the current commit + * Pushing tag and branch to remote + +## 0.1.4.0 -- 2016-02-18 + + * Start integrating some git-specific functionality + +## 0.1.2.0 -- 2016-02-17 + + * First release, experimental. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2016, Lennart Spitzner + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Lennart Spitzner nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,85 @@ +# iridium + +[![Build Status](https://secure.travis-ci.org/lspitzner/iridium.svg)](http://travis-ci.org/lspitzner/iridium) +[![Hackage](https://img.shields.io/hackage/v/iridium.svg)](https://hackage.haskell.org/package/iridium) + +# Introduction + +iridium is a fancy wrapper around `cabal upload`. It aims to automate +several typical steps when releasing a new package version to hackage. + +Steps currently include: + +- Compilation and running tests using multiple compiler versions. + (the different compilers must already be installed.) + +- Checking that the changelog mentions the latest version. + +- Checking that the upper bounds of dependencies + are up-to-date by making use of stackage snapshots. + +- Uploading of both the package itself and the documentation. + +# Usage + +Install iridium, run iridium in the directory containing the cabal package. +It won't do anything without confirmation. + +~~~~ +$ iridium +Checking compilation and tests with different compiler versions + Checking with compiler ghc-7.8.4: clear. + Checking with compiler ghc-7.10.3: clear. +Checking upper bounds using stackage: clear. +Checking documentation: clear. +Checking basic compilation: clear. +Checking that all dependencies have upper bounds: clear. +Checking package validity: clear. +Comparing local version to hackage version: clear. +[git] + Testing for uncommitted changes: clear. +Summary: + Package: iridium + Version: 0.1.2.0 + Warning count: 0 + Error count: 0 + Not -Wall clean: + [git] + Branch: master + + Actions: Upload package, Upload documentation + +> Continue [y]es [n]o? > y +Performing upload.. +Building source dist for iridium-0.1.2.0... +Preprocessing library iridium-0.1.2.0... +Preprocessing executable 'iridium' for iridium-0.1.2.0... +Source tarball created: dist/iridium-0.1.2.0.tar.gz +Hackage password: +Uploading dist/iridium-0.1.2.0.tar.gz... +Ok +Upload successful. +Performing doc upload.. +[.. some haddock spam ..] +Documentation tarball created: dist/iridium-0.1.2.0-docs.tar.gz +Hackage password: +Uploading documentation dist/iridium-0.1.2.0-docs.tar.gz... +Ok +Documentation upload successful. +$ +~~~~ + +# Configuration + +An `iridium.yaml` file will be created on first invocation. + +# Tests + +| Test | Description | +| --- | --- | +| hlint | `forM_ hs-source-dirs $ \dir -> (\dir -> call "hlint " ++ dir)` | +| testsuites | run `cabal test` when compiling. | +| upper-bounds-stackage | Check that upper bounds are up-to-date by using a stackage cabal.config. This is not the best way, because not all packages are on stackage, but it is better than nothing. | +| upper-bounds-exist | Check that all dependencies have upper bounds. (You _do_ want to conform with the PVP, right?) | +| documentation | Check that haddocks can be created without problems (calling `cabal haddock`). | +| changelog | Check if the changelog mentions (contains) the latest version. | diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/data/default-iridium.yaml b/data/default-iridium.yaml new file mode 100644 --- /dev/null +++ b/data/default-iridium.yaml @@ -0,0 +1,129 @@ +# see https://github.com/lspitzner/iridium +# +# note that you can add a user-global .iridium.yaml +# into $HOME, containing e.g. +# +# --- +# setup: +# compiler-paths: +# ghc-7.10.3: /opt/ghc-7.10.3/bin/ghc +# ghc-7.8.4: /opt/ghc-7.8.4/bin/ghc +# +# hackage: +# username: user +# ... + +--- +setup: + buildtool-help: | + cannot be changed; stack is not supported (yet). + buildtool: cabal + + cabal-command-help: | + "cabal-command: cabal" + hlint-command-help: | + "hlint-command: $HOME/.cabal/bin/hlint" + + remote-server-help: ! 'This currently only checks that uploads happen to that remote, + it does not change the remote if a different one is configured. + (because that would require modifying `.cabal/config`,)' + remote-server: http://hackage.haskell.org + +process: + dry-run-help: | + only run all checks/tests, omit any side-effects/uploading + dry-run: False + + display-help: True + + upload-docs-help: | + build docs locally and upload them instead of trusting the + docs builder which gets broken every two months. + implies the documentation check. + upload-docs: True + + print-summary: True + + confirmation-help: | + confirm-always always ask for confirmation. + confirm-on-warning don't ask for confirmation if everything is clear. + confirm-on-error only ask for confirmation if there are errors. + confirmation: confirm-always + +checks: + hlint: + enabled: False + testsuites: + enabled: True + compiler-warnings: + enabled: True + + # whitelist: [only, these, tests] # not supported yet + # blacklist: [omit, these, tests] # not supported yet + + package-sdist-help: | + Check that the created source distribution package will + actually work (for other users). This can for example + be not the case when you fail to mention specific files + in your package description. + package-sdist: + enabled: True + + upper-bounds-stackage-help: | + if you are completely unlucky, this might _overwrite_ + an existing cabal.config. if you press ctrl-c in exactly + the right moment or something. + upper-bounds-stackage: + enabled-help: | + for existing upper bounds + enabled: False + use-nightly: False + # blacklist: [omit, check, for, these, packages] # not supported yet + upper-bounds-exist: + enabled: True + lower-bounds-exist: + enabled: True + changelog: + enabled: True + location: ChangeLog.md + compiler-versions: + enabled: False + compilers-help: | + for this to work, cabal will need the paths to the actual + compilers to be configured; see the note about the user-global + config above. + compilers: + - compiler: ghc + version: 7.0.4 + - compiler: ghc + version: 7.2.2 + - compiler: ghc + version: 7.4.2 + - compiler: ghc + version: 7.6.3 + - compiler: ghc + version: 7.8.4 + - compiler: ghc + version: 7.10.3 + documentation: + enabled: True + +repository: + type-help: | + none | git + type: none + git: + display-current-branch: True + release-tag: + enabled: True + content: "$VERSION" + # params: [] # NOT YET SUPPORTED ! + push-remote-help: | + push the current branch (and the tag, if configured) to + a remote repo. + push-remote: + enabled: True + remote-name-help: | + the "remote" configured in git to push the release/tag to. + remote-name: "origin" +... diff --git a/iridium.cabal b/iridium.cabal new file mode 100644 --- /dev/null +++ b/iridium.cabal @@ -0,0 +1,149 @@ +name: iridium +version: 0.1.5.1 +synopsis: Automated Testing and Package Uploading +license: BSD3 +license-file: LICENSE +author: Lennart Spitzner +maintainer: lsp@informatik.uni-kiel.de +copyright: Copyright (C) 2016 Lennart Spitzner +Homepage: https://github.com/lspitzner/iridium +Bug-reports: https://github.com/lspitzner/iridium/issues +category: Development +build-type: Simple +cabal-version: >=1.10 + +description: { + This executable aims to automate several typical steps when + uploading a new package version to hackage. + . + Steps currently include: + . + * Compilation and running tests using multiple compiler versions. + . + * Checking that the changelog mentions the latest version. + . + * Checking that the upper bounds of dependencies + are up-to-date by making use of stackage snapshots. + . + * Uploading of both the package itself and the documentation. + . + The program is configurable using a per-project .yaml file. + . + See the README. +} + + + +data-dir: { + data +} +data-files: { + default-iridium.yaml +} + +extra-source-files: { + README.md + ChangeLog.md +} + +source-repository head { + type: git + location: git@github.com:lspitzner/iridium.git +} + +library { + exposed-modules: { + Development.Iridium.Types + Development.Iridium.Utils + Development.Iridium.ExternalProgWrappers + Development.Iridium.UI.Console + Development.Iridium.UI.Prompt + Development.Iridium.Repo.Git + Development.Iridium.Config + Development.Iridium.Hackage + Development.Iridium.CheckState + Development.Iridium.Checks + Development.Iridium + Paths_iridium + } + -- other-modules: + -- other-extensions: + build-depends: + { base >=4.7 && <4.9 + , lifted-base >=0.2.3.6 && <0.3 + , yaml >=0.8.16 && <0.9 + , turtle >=1.2.5 && <1.3 + , text >=1.2.2.0 && <1.3 + , containers >=0.5.5.1 && <0.6 + , unsafe >=0.0 && <0.1 + , transformers >=0.3.0.0 && <0.5 + , system-filepath >=0.4.13.4 && <0.5 + , unordered-containers >=0.2.5.1 && <0.3 + , multistate >=0.7.0.0 && <0.8 + , Cabal >=1.22.5.0 && <1.23 + , http-conduit >=2.1.8 && <2.2 + , xmlhtml >=0.2.3.4 && <0.3 + , foldl >=1.1.5 && <1.2 + , bytestring >=0.10.4.0 && <0.11 + , tagged >=0.8.3 && <0.9 + , extra >=1.4.3 && <1.5 + , process >=1.2.0.0 && < 1.5 + , vector >=0.11.0.0 && <0.12 + , ansi-terminal >=0.6.2.3 && <0.7 + , transformers-base >=0.4.4 && <0.5 + , monad-control >=1.0.0.5 && <1.1 + , split >=0.2.3 && <0.3 + } + hs-source-dirs: { + src + } + default-language: { + Haskell2010 + } + ghc-options: { + -Wall + -j + -fno-warn-unused-imports + -fno-warn-orphans + } + default-extensions: { + FlexibleContexts + FlexibleInstances + ScopedTypeVariables + MonadComprehensions + } +} + +executable iridium { + main-is: { + Main.hs + } + build-depends: + { iridium + , base >=4.7 && <4.9 + , yaml >=0.8.16 && <0.9 + , transformers >=0.3.0.0 && <0.5 + , unordered-containers >=0.2.5.1 && <0.3 + , multistate >=0.7.0.0 && <0.8 + , extra >=1.4.3 && <1.5 + , text >=1.2.2.0 && <1.3 + } + hs-source-dirs: { + src-main + } + default-language: { + Haskell2010 + } + ghc-options: { + -Wall + -j + -fno-warn-unused-imports + -fno-warn-orphans + } + default-extensions: { + FlexibleContexts + FlexibleInstances + ScopedTypeVariables + MonadComprehensions + } +} diff --git a/src-main/Main.hs b/src-main/Main.hs new file mode 100644 --- /dev/null +++ b/src-main/Main.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ViewPatterns #-} + +module Main + ( main + ) +where + + + +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.MultiRWS +import Data.HList.HList +import Control.Monad.IO.Class + +import Control.Monad + +import qualified System.Environment +import qualified System.Console.GetOpt as GetOpt +import Data.Version ( showVersion ) +import qualified Data.Yaml as Yaml +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as Text + +import Development.Iridium +import Development.Iridium.Config +import Development.Iridium.UI.Console +import Development.Iridium.Types + +import Paths_iridium + + + +data Option + = OptionHelp + | OptionVersion + | OptionVerbose + | OptionDryRun + deriving (Eq) + +optDescrs :: [GetOpt.OptDescr Option] +optDescrs = + [ GetOpt.Option "h" ["help"] (GetOpt.NoArg OptionHelp ) "print help and exit" + , GetOpt.Option "" ["version"] (GetOpt.NoArg OptionVersion) "print version and exit" + , GetOpt.Option "v" ["verbose"] (GetOpt.NoArg OptionVerbose) "control verbosity. Can be used multiple times, -vvvv is max." + , GetOpt.Option "" ["dry-run"] (GetOpt.NoArg OptionDryRun) "stop before firing any rockets." + ] + + +main :: IO () +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 ] + ++ [ 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 + return () diff --git a/src/Development/Iridium.hs b/src/Development/Iridium.hs new file mode 100644 --- /dev/null +++ b/src/Development/Iridium.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} + +module Development.Iridium + ( iridiumMain + , initNote + , retrieveInfos + , runChecks + , displaySummary + , askGlobalConfirmation + ) +where + + + +import qualified Data.Text as Text +import qualified Turtle as Turtle +import qualified Control.Foldl as Foldl + +import Data.Text ( Text ) +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Class +import Control.Monad.IO.Class +import Control.Monad +import Text.Read ( readMaybe ) +import Control.Monad.Extra ( whenM ) +import Control.Monad.Trans.MultiRWS +import Control.Monad.Trans.Control +import Data.Proxy +import Data.Tagged +import Data.List +import Data.HList.HList + +import Data.HList.ContainsType + +import Data.Version ( showVersion, parseVersion ) +import Filesystem.Path.CurrentOS hiding ( null ) +import System.Exit +import Text.ParserCombinators.ReadP +import qualified Distribution.PackageDescription as PackageDescription +import Distribution.PackageDescription.Parse +import qualified Distribution.Package as Package + +import Development.Iridium.Types +import Development.Iridium.Utils +import Development.Iridium.UI.Console +import Development.Iridium.Hackage +import Development.Iridium.Config +import Development.Iridium.UI.Prompt +import Development.Iridium.CheckState +import qualified Development.Iridium.Checks as Checks +import qualified Development.Iridium.Repo.Git as Git +import Development.Iridium.ExternalProgWrappers + + + +initNote :: String +initNote + = "iridium - automated cabal package uploading utility" + +retrieveInfos + :: ( MonadIO m + , MonadPlus m + , MonadMultiState LogState m + , MonadMultiReader Config m + ) + => m Infos +retrieveInfos = do + cabalInvoc <- configReadStringWithDefaultM "cabal" ["setup", "cabal-command"] + cabalVersion <- getExternalProgramVersion cabalInvoc + when (cabalVersion < [1,22,8]) $ do + pushLog LogLevelError "This program requires cabal version 1.22.8 or later. aborting." + mzero + whenM (configIsEnabledM ["checks", "hlint"]) $ do + hlint <- configReadStringWithDefaultM "hlint" ["setup", "hlint-command"] + _ <- getExternalProgramVersion hlint + return () + cwd <- Turtle.pwd + packageDesc <- do + packageFile <- do + allFiles <- Turtle.fold (Turtle.ls cwd) Foldl.list + let cabalFiles = + filter (\p -> Turtle.extension p == Just (Text.pack "cabal")) + allFiles + case cabalFiles of + [f] -> return f + [] -> do + pushLog LogLevelError "Error: Found no cabal package!" + mzero + _ -> do + pushLog LogLevelError "Error: Found more than one cabal package file!" + mzero + pushLog LogLevelInfo $ "Reading cabal package description " ++ encodeString packageFile + content <- Text.unlines `liftM` Turtle.fold (Turtle.input packageFile) Foldl.list + -- pushLog LogLevelDebug $ Text.unpack content + let parseResult = parsePackageDescription $ Text.unpack content + case parseResult of + ParseFailed e -> do + pushLog LogLevelError $ "Error parsing cabal package file: " ++ show e + mzero + ParseOk _ x -> do + -- pushLog LogLevelDebug $ show $ packageDescription x + return x + let pkgName = (\(Package.PackageName n) -> n) + $ Package.pkgName + $ PackageDescription.package + $ 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 + pushLog LogLevelInfoVerbose $ "remote version: " ++ show (liftM showVersion latestVersionM) + configDecideStringM ["repository", "type"] + [ (,) "none" $ do + repoInfo :: NoRepo <- repo_retrieveInfo + return $ Infos cwd packageDesc latestVersionM repoInfo + , (,) "git" $ do + repoInfo :: Git.GitImpl <- repo_retrieveInfo + return $ Infos cwd packageDesc latestVersionM repoInfo + ] + + +runChecks + :: ( MonadIO m0 + , MonadPlus m0 + , MonadBaseControl IO m0 + , ContainsType LogState s + , ContainsType CheckState s + , ContainsType Config r + , ContainsType Infos r + ) + => MultiRWST r w s m0 () +runChecks = do + whenM (configIsEnabledM ["checks", "compiler-versions"]) $ Checks.compileVersions + whenM (configIsEnabledM ["checks", "upper-bounds-stackage"]) $ Checks.upperBoundsStackage + whenM (configIsEnabledM ["checks", "documentation"]) $ Checks.documentation + -- we do this last so that we return in an "everything is compiled" state, + -- if possible. + Checks.compile + whenM (configIsEnabledM ["checks", "hlint"]) Checks.hlint + whenM (configIsEnabledM ["checks", "lower-bounds-exist"]) $ Checks.lowerBounds + whenM (configIsEnabledM ["checks", "upper-bounds-exist"]) $ Checks.upperBounds + whenM (return True) Checks.packageCheck + whenM (configIsEnabledM ["checks", "package-sdist"]) $ Checks.packageSDist + whenM (configIsEnabledM ["checks", "changelog"]) $ Checks.changelog + whenM (return True) Checks.remoteVersion + whenM (return True) repoRunChecks + +displaySummary + :: ( MonadIO m + , MonadPlus m + , MonadMultiState LogState m + , MonadMultiState CheckState m + , MonadMultiReader Config m + , MonadMultiReader Infos m + ) + => m () +displaySummary = do + pushLog LogLevelPrint "Summary:" + withIndentation $ do + Package.PackageName pNameStr <- askPackageName + pushLog LogLevelPrint $ "Package: " ++ pNameStr + pVersion <- askPackageVersion + pushLog LogLevelPrint $ "Version: " ++ showVersion pVersion + latestVersionM <- liftM _i_remote_version mAsk + case latestVersionM of + Nothing -> return () + Just v -> + pushLog LogLevelPrint $ "Latest hackage version: " ++ showVersion v + -- TODO: This should not be printed unless we verify that + -- the information is correct by looking at the .cabal config. + -- remoteServer <- configReadStringM ["setup", "remote-server"] + -- pushLog LogLevelPrint $ "Remote location: " ++ remoteServer + do + CheckState _ errC warnC walls <- mGet + pushLog LogLevelPrint $ "Warning count: " ++ show warnC + pushLog LogLevelPrint $ "Error count: " ++ show errC + let wallStr = if null walls then "[]" else intercalate ", " (reverse walls) + pushLog LogLevelPrint $ "Not -Wall clean: " ++ wallStr + do + repoDisplaySummary + uploadEnabled <- configIsTrueM ["process", "upload-docs"] + repoActions <- repoActionSummary + let actions = repoActions + ++ ["Upload package"] + ++ ["Upload documentation" | uploadEnabled] + pushLog LogLevelPrint "" + pushLog LogLevelPrint $ "Actions: " ++ intercalate + "\n " actions + return () + +askGlobalConfirmation + :: ( MonadIO m + , MonadPlus m + , MonadMultiReader Config m + ) + => Bool + -> m () +askGlobalConfirmation existErrors = do + if existErrors + then promptSpecific "There are errors; write \"override\" to (try) continue anyways " "override" + else promptYesOrNo "Continue [y]es [n]o? " + +iridiumMain + :: Config + -> MultiRWST '[] '[] '[LogState] (MaybeT IO) () +iridiumMain argConfig = do + fileConfig <- parseConfigs + let mergedConfig = mergeConfigs argConfig fileConfig + withMultiReader mergedConfig $ do + infos <- retrieveInfos + withMultiReader infos $ withMultiStateA initCheckState $ do + runChecks + displaySetting <- configIsTrueM ["process", "print-summary"] + existWarnings <- liftM ((/=0) . _check_warningCount) mGet + existErrors <- liftM ((/=0) . _check_errorCount ) mGet + when displaySetting displaySummary + whenM (not `liftM` configIsTrueM ["process", "dry-run"]) $ do + pushLog LogLevelPrint "" + configDecideStringM ["process", "confirmation"] + [ ("confirm-always" , when (True ) $ askGlobalConfirmation existErrors) + , ("confirm-on-warning", when (existWarnings || existErrors) $ askGlobalConfirmation existErrors) + , ("confirm-on-error" , when ( existErrors) $ askGlobalConfirmation existErrors) + ] + repoPerformAction + uploadPackage + whenM (configIsTrueM ["process", "upload-docs"]) uploadDocs diff --git a/src/Development/Iridium/CheckState.hs b/src/Development/Iridium/CheckState.hs new file mode 100644 --- /dev/null +++ b/src/Development/Iridium/CheckState.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ExistentialQuantification #-} + +module Development.Iridium.CheckState + ( initCheckState + , withStack + , logStack + , incWarningCounter + , incErrorCounter + , addNotWallClean + , replaceStackTop + ) +where + + +import Prelude hiding ( FilePath ) + +import qualified Data.Text as Text +import qualified Turtle as Turtle +import qualified Control.Foldl as Foldl + +import qualified Data.Yaml as Yaml +import Control.Monad.Trans.MultiRWS +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Class +import Control.Monad.IO.Class +import Distribution.PackageDescription +import Distribution.Package +import Data.Version ( Version(..) ) +import Data.Proxy +import Data.Tagged +import Control.Applicative +import Control.Monad +import Data.Functor +import Data.List + +-- well, no Turtle, apparently. +-- no way to retrieve stdout, stderr and exitcode. +-- the most generic case, not supported? psshhh. +import System.Process hiding ( cwd ) + +import Data.Maybe ( maybeToList ) + +import qualified Filesystem.Path.CurrentOS as Path + +import Development.Iridium.Types +import Development.Iridium.UI.Console +import Development.Iridium.UI.Prompt + + + +initCheckState :: CheckState +initCheckState = CheckState [] 0 0 [] + +withStack + :: ( MonadIO m + , MonadMultiState LogState m + , MonadMultiState CheckState m + ) + => String + -> m a + -> m a +withStack s m = do + s1 <- mGet + let newStack = s : _check_stack s1 + mSet $ s1 { _check_stack = newStack } + id $ withoutIndentation + $ writeCurLine + $ take 76 + $ intercalate ": " + $ reverse + $ fmap (take 20) + $ newStack + r <- m + s2 <- mGet + mSet $ s2 { _check_stack = _check_stack s1 } + return r + +replaceStackTop + :: ( MonadIO m + , MonadMultiState LogState m + , MonadMultiState CheckState m + ) + => String + -> m () +replaceStackTop s = do + s1 <- mGet + let newStack = s : drop 1 (_check_stack s1) + mSet s1 { _check_stack = newStack } + id $ withoutIndentation + $ writeCurLine + $ take 76 + $ intercalate ": " + $ reverse + $ fmap (take 20) + $ newStack + +logStack + :: ( MonadIO m + , MonadMultiState CheckState m + , MonadMultiState LogState m + ) + => m () +logStack = do + s1 <- mGet + let line = "(" + ++ intercalate ": " (reverse $ _check_stack s1) + ++ ")" + pushLog LogLevelPrint line + +incWarningCounter + :: ( MonadMultiState CheckState m ) + => m () +incWarningCounter = do + s <- mGet + mSet $ s { _check_warningCount = _check_warningCount s + 1 } + +incErrorCounter + :: ( MonadMultiState CheckState m ) + => m () +incErrorCounter = do + s <- mGet + mSet $ s { _check_errorCount = _check_errorCount s + 1 } + +addNotWallClean + :: ( MonadMultiState CheckState m ) + => String + -> m () +addNotWallClean compStr = do + s <- mGet + mSet $ s { _check_notWallClean = compStr : _check_notWallClean s } diff --git a/src/Development/Iridium/Checks.hs b/src/Development/Iridium/Checks.hs new file mode 100644 --- /dev/null +++ b/src/Development/Iridium/Checks.hs @@ -0,0 +1,508 @@ +{-# LANGUAGE TypeFamilies #-} + +module Development.Iridium.Checks + ( packageCheck + , hlint + , changelog + , lowerBounds + , upperBounds + , remoteVersion + , compile + , documentation + , compileVersions + , upperBoundsStackage + , packageSDist + ) +where + + + +import qualified Data.Text as Text +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 Data.ByteString as ByteString +import qualified Data.ByteString.Lazy as ByteStringL + +import Control.Exception.Lifted +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Control +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.MultiRWS + +import Data.Text ( Text ) +import Data.Text.Encoding +import Distribution.PackageDescription +import Data.Maybe ( maybeToList ) +import Data.ByteString ( ByteString ) +import qualified Data.ByteString as ByteString +import Filesystem.Path.CurrentOS hiding ( null ) + +import qualified Distribution.Package +import Distribution.Version + +-- no way to retrieve stdout, stderr and exitcode with turtle. +-- the most generic case, not supported? psshhh. +import System.Process hiding ( cwd ) +import Data.List ( nub ) +import Data.Version ( showVersion ) + +import Development.Iridium.CheckState +import Development.Iridium.Config +import Development.Iridium.Types +import Development.Iridium.UI.Console +import Development.Iridium.UI.Prompt +import Development.Iridium.Utils +import Development.Iridium.ExternalProgWrappers + + + + +packageCheck + :: ( MonadIO m + , MonadMultiReader Config m + , MonadMultiState LogState m + , MonadMultiState CheckState m + ) + => m () +packageCheck = do + buildtool <- configReadStringM ["setup", "buildtool"] + case buildtool of + "cabal" -> boolToError $ runCheck "Checking package validity" $ do + mzeroToFalse $ + runCommandSuccessCabal ["check"] + "stack" -> do + -- stack has no "check". + -- and no "upload --dry-run either." + pushLog LogLevelWarn "stack has no `check` command!" + pushLog LogLevelWarn "package validity could not be determined." + return () + _ -> error "bad config setup.buildtool" + +hlint + :: ( MonadIO m + , MonadMultiReader Config m + , MonadMultiReader Infos m + , MonadMultiState LogState m + , MonadMultiState CheckState m + ) + => m () +hlint = boolToWarning + $ runCheck "Running hlint on hsSourceDirs" + $ do + buildInfos <- askAllBuildInfo + -- pushLog LogLevelDebug $ show buildInfos + let sourceDirs = nub $ buildInfos >>= hsSourceDirs + pushLog LogLevelInfoVerboser $ "hsSourceDirs: " ++ show sourceDirs + liftM and $ sourceDirs `forM` \path -> do + mzeroToFalse $ + runCommandSuccessHLint [path] + +changelog + :: ( MonadIO m + , MonadMultiState LogState m + , MonadMultiState CheckState m + , MonadMultiReader Infos m + , MonadMultiReader Config m + ) + => m () +changelog = boolToWarning + $ runCheck "Testing if the changelog mentions the latest version" + $ do + pathRaw <- configReadStringM ["checks", "changelog", "location"] + cwd <- liftM _i_cwd mAsk + let path = cwd decodeString pathRaw + exists <- Turtle.testfile path + if (not exists) + then do + pushLog LogLevelPrint $ "changelog file (" ++ show path ++ ") does not exist!" + return False + else do + changelogContentLines <- Turtle.fold (Turtle.input path) Foldl.list + currentVersionStr <- liftM showVersion askPackageVersion + if any (Text.pack currentVersionStr `Text.isInfixOf`) changelogContentLines + then return True + else do + pushLog LogLevelError $ "changelog does not contain " ++ currentVersionStr + return False + +lowerBounds + :: ( MonadIO m + , MonadMultiState LogState m + , MonadMultiState CheckState m + , MonadMultiReader Config m + , MonadMultiReader Infos m + ) + => m () +lowerBounds = boolToWarning + $ runCheck "Checking that all dependencies have a lower bound" + $ do + buildInfos <- askAllBuildInfo + pName <- askPackageName + let missingBounds + = [ name + | info <- buildInfos + , Distribution.Package.Dependency name range <- targetBuildDepends info + , name /= pName -- ignore dependencies on the package's library + , let intervals = asVersionIntervals range + , let badLowerBound = LowerBound (Version [0] []) InclusiveBound + , case intervals of + [] -> True + xs | any (\(lwr, _) -> lwr == badLowerBound) xs -> True + _ -> False + ] + if null missingBounds + then return True + else do + pushLog LogLevelError $ "Found dependencies without a lower bound:" + missingBounds `forM_` \(Distribution.Package.PackageName n) -> + pushLog LogLevelError $ " " ++ n + return False + +upperBounds + :: ( MonadIO m + , MonadMultiState LogState m + , MonadMultiState CheckState m + , MonadMultiReader Config m + , MonadMultiReader Infos m + ) + => m () +upperBounds = boolToWarning + $ runCheck "Checking that all dependencies have an upper bound" + $ do + buildInfos <- askAllBuildInfo + pName <- askPackageName + let missingBounds + = [ name + | info <- buildInfos + , Distribution.Package.Dependency name range <- targetBuildDepends info + , name /= pName -- ignore dependencies on the package's library + , let intervals = asVersionIntervals range + , case intervals of + [] -> True + xs | any (\(_, upr) -> upr == NoUpperBound) xs -> True + _ -> False + ] + if null missingBounds + then return True + else do + pushLog LogLevelError $ "Found dependencies without an upper bound:" + missingBounds `forM_` \(Distribution.Package.PackageName n) -> + pushLog LogLevelError $ " " ++ n + return False + +remoteVersion + :: ( MonadIO m + , MonadMultiState LogState m + , MonadMultiState CheckState m + , MonadMultiReader Infos m + ) + => m () +remoteVersion = boolToError + $ runCheck "Comparing local version to hackage version" + $ do + infos <- mAsk + localVersion <- askPackageVersion + -- pushLog LogLevelDebug $ show $ _i_remote_version infos + case _i_remote_version infos of + Nothing -> return True + Just remoteVers -> + if localVersion == remoteVers + then do + pushLog LogLevelError $ "This package version (" ++ showVersion localVersion ++ ") is already on hackage; needs bump?" + return False + else if localVersion < remoteVers + then do + pushLog LogLevelWarn $ "The version on hackage (" + ++ showVersion remoteVers + ++ ") is greater than the local version (" + ++ showVersion localVersion + ++ ")." + return False + else return True + +compile + :: forall m + . ( MonadIO m + , MonadPlus m + , MonadMultiState LogState m + , MonadMultiState CheckState m + , MonadMultiReader Config m + ) + => m () +compile = withStack "basic compilation" $ boolToError $ do + + warningsEnabled <- configIsEnabledM ["checks", "compiler-warnings"] + if warningsEnabled + then fallbackCheck + (do + b <- runCheck "Checking basic compilation" (checks True) + unless b $ do + incWarningCounter + addNotWallClean "" + return b + ) + (do + pushLog LogLevelPrint "Falling back on compilation without warnings." + runCheck "Checking basic compilation -w" (checks False) + ) + else + runCheck "Checking basic compilation" (checks False) + + where + checks :: Bool -> m Bool + checks werror = do + buildtool <- configReadStringM ["setup", "buildtool"] + testsEnabled <- configIsEnabledM ["checks", "testsuites"] + case buildtool of + "cabal" -> + mzeroToFalse $ do + let testsArg = ["--enable-tests" | testsEnabled] + let werrorArg = ["--ghc-options=\"-Werror\"" | werror] + ++ ["--ghc-options=\"-w\"" | not werror] + runCommandSuccessCabal ["clean"] + runCommandSuccessCabal $ ["install", "--dep"] ++ testsArg + runCommandSuccessCabal $ ["configure"] ++ testsArg ++ werrorArg + runCommandSuccessCabal ["build"] + when testsEnabled $ + runCommandSuccessCabal ["test"] + return True + "stack" -> do + pushLog LogLevelError "TODO: stack build" + mzero + _ -> mzero + +documentation + :: ( MonadIO m + , MonadMultiState LogState m + , MonadMultiState CheckState m + , MonadMultiReader Config m + ) + => m () +documentation = boolToError + $ runCheck "Checking documentation" + $ withStack "documentation check" + $ do + buildtool <- configReadStringM ["setup", "buildtool"] + case buildtool of + "cabal" -> + mzeroToFalse $ do + runCommandSuccessCabal ["clean"] + runCommandSuccessCabal ["install", "--dep"] + runCommandSuccessCabal ["configure"] + runCommandSuccessCabal ["haddock"] + "stack" -> do + pushLog LogLevelError "TODO: stack build" + return False + _ -> error "lkajsdlkjasd" + +compileVersions + :: forall m + . ( MonadIO m + , MonadPlus m + , MonadMultiState LogState m + , MonadMultiState CheckState m + , MonadMultiReader Config m + ) + => m () +compileVersions = withStack "compiler checks" $ do + + buildtool <- configReadStringM ["setup", "buildtool"] + testsEnabled <- configIsEnabledM ["checks", "testsuites"] + warningsEnabled <- configIsEnabledM ["checks", "compiler-warnings"] + + case () of { + () -> do + if testsEnabled + then pushLog LogLevelPrint "Checking compilation and tests with different compiler versions" + else pushLog LogLevelPrint "Checking compilation with different compiler versions" + withIndentation $ do + rawList <- configReadListM ["checks", "compiler-versions", "compilers"] + rawList `forM_` \val -> boolToError $ do + let compilerStr = configReadString ["compiler"] val + ++ "-" + ++ configReadString ["version"] val + let checkBaseName = "Checking with compiler " ++ compilerStr + withStack compilerStr $ + if warningsEnabled + then + fallbackCheck + (do + b <- runCheck checkBaseName $ checks compilerStr True + unless b $ do + incWarningCounter + addNotWallClean compilerStr + return b + ) + (do + pushLog LogLevelPrint "Falling back on compilation without warnings." + runCheck (checkBaseName ++ " -w") $ checks compilerStr False + ) + else + runCheck checkBaseName $ checks compilerStr False + + where + checks :: String -> Bool -> m Bool + checks compilerStr werror = case buildtool of + "cabal" -> 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] + let werrorArg = ["--ghc-options=\"-Werror\"" | werror] + ++ ["--ghc-options=\"-w\"" | not werror] + runCommandSuccessCabal ["clean"] + runCommandSuccessCabal $ ["install", "--dep", "-w" ++ compilerPath] + ++ testsArg + runCommandSuccessCabal $ ["configure", "-w" ++ compilerPath] + ++ testsArg + ++ werrorArg + runCommandSuccessCabal ["build"] + when testsEnabled $ + runCommandSuccessCabal ["test"] + "stack" -> do + pushLog LogLevelError "TODO: stack build" + mzero + _ -> mzero + } + +upperBoundsStackage + :: forall m + . ( MonadIO m + , MonadPlus m + , MonadBaseControl IO m + , MonadMultiState LogState m + , MonadMultiState CheckState m + , MonadMultiReader Infos m + , MonadMultiReader Config m + ) + => m () +upperBoundsStackage = withStack "stackage upper bound" $ boolToError $ do + + runCheck "Checking upper bounds using stackage" $ do + buildtool <- configReadStringM ["setup", "buildtool"] + testsEnabled <- configIsEnabledM ["checks", "testsuites"] + case buildtool of + "cabal" -> do + cabalConfigPath <- getLocalFilePath "cabal.config" + cabalConfigBackupPath <- getLocalFilePath "cabal.config.backup" + alreadyExists <- Turtle.testfile cabalConfigPath + -- TODO: make this safe against ctrl-c again. + -- TODO: make sure the backup does not exist yet. (!) + pushLog LogLevelInfo $ "Preparing cabal.config" + when alreadyExists $ do + pushLog LogLevelInfoVerbose $ "Renaming existing cabal.config to cabal.config.backup" + Turtle.mv cabalConfigPath cabalConfigBackupPath + result <- mzeroToFalse $ do + useNightly <- configIsTrueM ["checks", "upper-bounds-stackage", "use-nightly"] + let urlStr = if useNightly + then "http://www.stackage.org/nightly/cabal.config" + else "http://www.stackage.org/lts/cabal.config" + cabalConfigContents <- fetchCabalConfig urlStr + pName <- liftM (Text.pack . (\(Distribution.Package.PackageName n) -> n)) askPackageName + let filteredLines = filter (not . (pName `Text.isInfixOf`)) + $ Text.lines + $ decodeUtf8 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] + runCommandSuccessCabal ["clean"] + runCommandSuccessCabal $ ["install", "--dep", "--force-reinstalls", "--dry-run"] ++ testsArg + pushLog LogLevelInfo $ "Cleanup (cabal.config)" + unless alreadyExists $ Turtle.rm cabalConfigPath + when alreadyExists $ Turtle.mv cabalConfigBackupPath cabalConfigPath + -- let + -- act :: MaybeT m () = do + -- pushLog LogLevelInfo $ "Preparing cabal.config" + -- when alreadyExists $ do + -- pushLog LogLevelInfoVerbose $ "Renaming existing cabal.config to cabal.config.backup" + -- Turtle.mv cabalConfigPath cabalConfigBackupPath + -- useNightly <- configIsTrueM ["checks", "upper-bounds-stackage", "use-nightly"] + -- let urlStr = if useNightly + -- then "http://www.stackage.org/nightly/cabal.config" + -- else "http://www.stackage.org/lts/cabal.config" + -- cabalConfigContents <- fetchCabalConfig urlStr + -- pName <- liftM (Text.pack . (\(Distribution.Package.PackageName n) -> n)) askPackageName + -- let filteredLines = filter (pName `Text.isInfixOf`) + -- $ Text.lines + -- $ decodeUtf8 cabalConfigContents + -- liftIO $ Text.IO.writeFile (encodeString cabalConfigPath) (Text.unlines filteredLines) + -- let testsArg = ["--enable-tests" | testsEnabled] + -- runCommandSuccessCabal ["clean"] + -- runCommandSuccessCabal $ ["install", "--dep"] ++ testsArg + -- fin = do + -- pushLog LogLevelInfo $ "Cleanup (cabal.config)" + -- when alreadyExists $ Turtle.mv cabalConfigBackupPath cabalConfigPath + -- act `finally` fin + return result + "stack" -> do + pushLog LogLevelError "TODO: stack upper bound check" + mzero + _ -> mzero + + where + fetchCabalConfig + :: forall m0 + . ( MonadIO m0 + , MonadPlus m0 + , MonadMultiState LogState m0 + , MonadMultiReader Infos m0 + ) + => String + -> m0 ByteString + 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 + -- 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) + -- case result of + -- Left _ -> do + -- pushLog LogLevelError "Error: Could not retrieve hackage version" + -- mzero + -- Right x -> do + -- pushLog LogLevelInfoVerboser $ show x + -- let body = HTTP.rspBody x + -- pushLog LogLevelInfoVerbose $ "Retrieved " ++ show (ByteString.length body) ++ " bytes." + -- return $ body + +packageSDist + :: forall m + . ( MonadIO m + , MonadPlus m + , MonadMultiState LogState m + , MonadMultiState CheckState m + , MonadMultiReader Infos m + , MonadMultiReader Config m + ) + => m () +packageSDist = withStack "package sdist" $ boolToError $ do + + runCheck "Testing the source distribution package" $ do + + Distribution.Package.PackageName pName <- askPackageName + currentVersionStr <- liftM showVersion askPackageVersion + + buildtool <- configReadStringM ["setup", "buildtool"] + case buildtool of + "cabal" -> mzeroToFalse $ do + runCommandSuccessCabal ["sdist"] + let sdistName = pName ++ "-" ++ currentVersionStr ++ ".tar.gz" + runCommandSuccessCabal ["install", "dist/" ++ sdistName] + "stack" -> do + pushLog LogLevelError "TODO: stack upper bound check" + mzero + _ -> mzero diff --git a/src/Development/Iridium/Config.hs b/src/Development/Iridium/Config.hs new file mode 100644 --- /dev/null +++ b/src/Development/Iridium/Config.hs @@ -0,0 +1,334 @@ +module Development.Iridium.Config + ( parseConfigs + , configIsTrue + , configIsTrueM + , configIsEnabled + , configIsEnabledM + , configReadString + , configReadStringM + , configReadStringMaybe + , configReadStringMaybeM + , configReadList + , configReadListM + , configReadStringWithDefaultM + , configDecideStringM + , mergeConfigs + ) +where + + + +import Prelude hiding ( FilePath ) + +import qualified Data.Yaml as Yaml +import qualified Data.Yaml.Pretty as YamlPretty +import qualified Turtle.Prelude as Turtle +import qualified Data.HashMap.Strict as HM +import qualified Data.ByteString.Char8 as BSChar8 +import qualified Data.Text as Text +import qualified Data.Vector as DV +import qualified Data.List as List +import qualified Data.ByteString as BS +import qualified Data.Vector + +import Control.Monad.Trans.Maybe +import Control.Monad.IO.Class +import Filesystem.Path.CurrentOS +import Control.Monad.Trans.MultiRWS +import Data.Text ( Text ) +import Control.Monad +import Data.Monoid +import Data.Maybe +import Data.Ord ( comparing ) + +import Development.Iridium.UI.Console +import Development.Iridium.Types +import Paths_iridium + + + +readConfFile + :: ( MonadIO m + , MonadMultiState LogState m + , MonadPlus m + ) + => FilePath + -> m Config +readConfFile path = do + pushLog LogLevelInfoVerbose $ "Reading config file " ++ encodeString path + eitherValue <- liftIO $ Yaml.decodeFileEither $ encodeString path + case eitherValue of + Left e -> do + pushLog LogLevelError $ "Error reading config file " ++ encodeString path + pushLog LogLevelError $ show e + mzero + Right o@Yaml.Object{} -> return o + Right _ -> do + pushLog LogLevelError $ "Error reading config file: expecting YAML object." + pushLog LogLevelError $ "(Parsing was successful but returned something else,\nlike a list. or smth.)" + mzero + +writeConfigToFile :: String -> Config -> IO () +writeConfigToFile path config = + writeFile + path + (headerComment ++ "\n---\n" ++ unlines (go Nothing 0 config) ++ "...\n") + where + headerComment :: String + headerComment = unlines + $ map ("# " ++) + $ [ "see https://github.com/lspitzner/iridium" + , "" + , "note that you can add a user-global .iridium.yaml" + , "into $HOME, containing e.g." + , "" + , "---" + , "setup:" + , " compiler-paths:" + , " ghc-7.10.3: /opt/ghc-7.10.3/bin/ghc" + , " ghc-7.8.4: /opt/ghc-7.8.4/bin/ghc" + , "" + , " hackage:" + , " username: user" + , "..." + , "" + ] + -- The reason for this custom pretty-printing is that encodePretty from + -- the yaml package formats strings horribly, which + -- makes the documentation elements more annoying to parse than they + -- are helpful. + go :: Maybe String -> Int -> Config -> [String] + go firstLine indent (Yaml.Object m) + = maybe id (:) firstLine -- (firstLine:) + $ List.sortBy (comparing fst) (HM.toList m) >>= \(k, v) -> + go (Just $ replicate indent ' ' ++ Text.unpack k ++ ":") (indent+2) v + go firstLine indent (Yaml.Array a) + = maybe id (:) firstLine + $ Data.Vector.toList a >>= \v -> + case go Nothing 0 v of + [] -> [] + (x:xr) -> (replicate indent ' ' ++ "- " ++ x) + : (fmap ((replicate (indent+2) ' ')++) xr) + go firstLine indent (Yaml.String s) + = case (lines $ Text.unpack s, firstLine) of + ([], Just l) -> + [l ++ " \"\""] + ([x], Just l) | '"' `notElem` x -> -- " this editor has highlighting problems.. + [l ++ " " ++ show x] + (xs, Just l) -> + ((l ++ " |"):) + $ fmap ((replicate indent ' ') ++) + $ xs + (xs, Nothing) -> + fmap ((replicate indent ' ') ++) xs + go firstLine indent (Yaml.Number i) + = case firstLine of + Just l -> [l ++ " " ++ show i] + Nothing -> [replicate indent ' ' ++ show i] + go firstLine indent (Yaml.Bool b) + = case firstLine of + Just l -> [l ++ " " ++ show b] + Nothing -> [replicate indent ' ' ++ show b] + go _firstLine _indent Yaml.Null + = error "Null" + +determineConfFromStuff + :: ( MonadIO m + , MonadMultiState LogState m + ) + => m Config +determineConfFromStuff = do + return $ Yaml.Object $ HM.empty -- TODO + +parseConfigs + :: ( MonadIO m + , MonadPlus m + , MonadMultiState LogState m + ) + => m Yaml.Value +parseConfigs = do + pushLog LogLevelInfo "Reading config files.." + + home <- Turtle.home + cwd <- Turtle.pwd + let userConfPath = home decodeString ".iridium.yaml" + let userDefaultConfPath = home decodeString ".iridium-default.yaml" + let localConfPath = cwd decodeString "iridium.yaml" + staticDefaultPath <- liftIO $ getDataFileName "default-iridium.yaml" + userConfExists <- Turtle.testfile $ userConfPath + userDefaultConfExists <- Turtle.testfile $ userDefaultConfPath + localConfExists <- Turtle.testfile $ localConfPath + + userConf <- if userConfExists + then do + pushLog LogLevelInfoVerbose $ "Reading user config file from " + ++ encodeString userConfPath + readConfFile userConfPath + else return $ Yaml.Object $ HM.empty + + localConf <- if localConfExists + then readConfFile localConfPath + else do + userDefaultConf <- if userDefaultConfExists + then do + pushLog LogLevelInfoVerbose $ "Reading user default config from " + ++ encodeString userDefaultConfPath + readConfFile userDefaultConfPath + else return $ Yaml.Object $ HM.empty + calculatedConf <- determineConfFromStuff + staticDefaultConf <- do + pushLog LogLevelInfoVerbose $ "Reading static default config from " + ++ staticDefaultPath + readConfFile (decodeString staticDefaultPath) + + let combinedConfig = mergeConfigs + userDefaultConf -- 1. priority + $ mergeConfigs + calculatedConf -- 2. priority + staticDefaultConf -- 3. priority + + pushLog LogLevelInfo $ "Creating default iridium.yaml." + liftIO $ writeConfigToFile (encodeString localConfPath) combinedConfig + + readConfFile localConfPath + + let final = mergeConfigs localConf userConf + let displayStr = unlines + $ fmap (" " ++) + $ lines + $ BSChar8.unpack + $ YamlPretty.encodePretty YamlPretty.defConfig final + pushLog LogLevelInfoVerboser $ "Parsed config: \n" ++ displayStr + return $ final + +-- left-preferring merge; deep merge for objects/arrays +mergeConfigs :: Yaml.Value -> Yaml.Value -> Yaml.Value +mergeConfigs (Yaml.Object o1) (Yaml.Object o2) = Yaml.Object $ HM.unionWith mergeConfigs o1 o2 +mergeConfigs (Yaml.Array a1) (Yaml.Array a2) = Yaml.Array $ a1 <> a2 +mergeConfigs Yaml.Null x = x +mergeConfigs x _ = x + +configIsTrueM + :: MonadMultiReader Config m + => [String] + -> m Bool +configIsTrueM ps'' = configIsTrue ps'' `liftM` mAsk + +configIsTrue :: [String] -> Yaml.Value -> Bool +configIsTrue ps'' = go ps'' + where + go :: [String] -> Yaml.Value -> Bool + go [] v = case v of + Yaml.Bool b -> b + _ -> error $ "error in yaml data: expected Bool, got " ++ show v + go (p:pr) v = case v of + Yaml.Object hm -> case HM.lookup (Text.pack p) hm of + Just v' -> go pr v' + Nothing -> error $ "error in yaml data: no find element " ++ show p ++ " when looking for config " ++ show ps'' + _ -> error $ "error in yaml data: expected Object, got " ++ show v + +configIsTrueMaybe :: [String] -> Yaml.Value -> Maybe Bool +configIsTrueMaybe ps'' = go ps'' + where + go :: [String] -> Yaml.Value -> Maybe Bool + go [] v = case v of + Yaml.Bool b -> Just b + _ -> Nothing + go (p:pr) v = case v of + Yaml.Object hm -> case HM.lookup (Text.pack p) hm of + Just v' -> go pr v' + Nothing -> Nothing + _ -> Nothing + +configIsEnabledM + :: MonadMultiReader Config m + => [String] + -> m Bool +configIsEnabledM ps = configIsEnabled ps `liftM` mAsk + +configIsEnabled :: [String] -> Yaml.Value -> Bool +configIsEnabled ps v = fromMaybe False $ configIsTrueMaybe (ps ++ ["enabled"]) v + +configReadStringM + :: MonadMultiReader Config m + => [String] + -> m String +configReadStringM ps'' = configReadString ps'' `liftM` mAsk + +configReadString :: [String] -> Yaml.Value -> String +configReadString ps'' = go ps'' + where + go :: [String] -> Yaml.Value -> String + go [] v = case v of + Yaml.String b -> Text.unpack b + _ -> error $ "error in yaml data: expected String, got " ++ show v + go (p:pr) v = case v of + Yaml.Object hm -> case HM.lookup (Text.pack p) hm of + Just v' -> go pr v' + Nothing -> error $ "error in yaml data: no find element " ++ show p ++ " when looking for config " ++ show ps'' + _ -> error $ "error in yaml data: expected Object, got " ++ show v + +configReadStringMaybeM + :: MonadMultiReader Config m + => [String] + -> m (Maybe String) +configReadStringMaybeM ps'' = configReadStringMaybe ps'' `liftM` mAsk + +configReadStringMaybe :: [String] -> Yaml.Value -> Maybe String +configReadStringMaybe ps'' = go ps'' + where + go :: [String] -> Yaml.Value -> Maybe String + go [] v = case v of + Yaml.String b -> Just $ Text.unpack b + _ -> Nothing + go (p:pr) v = case v of + Yaml.Object hm -> go pr =<< HM.lookup (Text.pack p) hm + _ -> Nothing + +configReadStringWithDefaultM + :: MonadMultiReader Config m + => String + -> [String] + -> m String +configReadStringWithDefaultM def ps = do + liftM (fromMaybe def) $ configReadStringMaybeM ps + +configReadListM + :: MonadMultiReader Config m + => [String] + -> m [Yaml.Value] +configReadListM ps'' = configReadList ps'' `liftM` mAsk + +configReadList :: [String] -> Yaml.Value -> [Yaml.Value] +configReadList ps'' = go ps'' + where + go :: [String] -> Yaml.Value -> [Yaml.Value] + go [] v = case v of + Yaml.Array a -> DV.toList a + _ -> error $ "error in yaml data: expected Array, got " ++ show v + go (p:pr) v = case v of + Yaml.Object hm -> case HM.lookup (Text.pack p) hm of + Just v' -> go pr v' + Nothing -> error $ "error in yaml data: no find element " ++ show p ++ " when looking for config " ++ show ps'' + _ -> error $ "error in yaml data: expected Object, got " ++ show v + +configDecideStringM + :: ( MonadIO m + , MonadPlus m + , MonadMultiReader Config m + , MonadMultiState LogState m + ) + => [String] + -> [(String, m a)] + -> m a +configDecideStringM ps opts = do + str <- configReadStringM ps + case List.lookup str opts of + Nothing -> do + pushLog LogLevelError $ "Error looking up config value " + ++ show ps + ++ "; expecting one of " + ++ show (fmap fst opts) + ++ "." + mzero + Just k -> k diff --git a/src/Development/Iridium/ExternalProgWrappers.hs b/src/Development/Iridium/ExternalProgWrappers.hs new file mode 100644 --- /dev/null +++ b/src/Development/Iridium/ExternalProgWrappers.hs @@ -0,0 +1,288 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ExistentialQuantification #-} + +module Development.Iridium.ExternalProgWrappers + ( runCommandSuccess + , runCommandStdOut + , observeCreateProcessWithExitCode + , getExternalProgramVersion + , readShellProcessWithExitCode + , runCommandSuccessCabal + , runCommandSuccessHLint + ) +where + + +import Prelude hiding ( FilePath ) + +import qualified Data.Text as Text +import qualified Turtle as Turtle +import qualified Control.Foldl as Foldl +import qualified Control.Exception as C + +import qualified Data.Yaml as Yaml +import Control.Monad.Trans.MultiRWS +import Control.Monad.Trans.MultiState as MultiState +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Class +import Control.Monad.IO.Class +import Distribution.PackageDescription +import Distribution.Package +import Filesystem.Path.CurrentOS hiding ( null ) +import Data.Version ( Version(..) ) +import Data.Proxy +import Data.Tagged +import Control.Applicative +import Control.Monad +import Data.Functor +import Data.List +import System.Exit +import System.IO +import Control.Concurrent.MVar +import Control.Concurrent +import System.IO.Error +import GHC.IO.Exception ( ioException, IOErrorType(..), IOException(..) ) +import Foreign.C +import System.Process.Internals +import Data.IORef +import qualified Data.List.Split as Split +import qualified System.Process as Process +import qualified Data.Char as Char +import Text.Read ( readMaybe ) + +-- well, no Turtle, apparently. +-- no way to retrieve stdout, stderr and exitcode. +-- the most generic case, not supported? psshhh. +import System.Process hiding ( cwd ) + +import Data.Maybe ( maybeToList ) + +import qualified Filesystem.Path.CurrentOS as Path + +import Development.Iridium.Types +import Development.Iridium.Utils +import Development.Iridium.UI.Console +import Development.Iridium.UI.Prompt +import Development.Iridium.CheckState +import Development.Iridium.Config + + + +readShellProcessWithExitCode + :: String + -> [String] + -> IO (ExitCode, String, String) +readShellProcessWithExitCode c ps = + readCreateProcessWithExitCode + (shell $ c ++ " " ++ intercalate " " (fmap show ps)) + "" + +runCommandSuccess + :: ( MonadIO m + , MonadPlus m + , MonadMultiState CheckState m + , MonadMultiState LogState m + ) + => String + -> [String] + -> m () +runCommandSuccess c ps = falseToMZero $ do + let infoStr = c ++ " " ++ intercalate " " ps + withStack infoStr $ do + outListRef <- liftIO $ newIORef [] + exitCode <- withStack "" $ do -- the additional stack elem is for + -- output display stuff. + -- this is evil, because we discard states down there. + -- but .. the alternative is somewhat complex ( to do right ). + s1 :: LogState <- mGet + s2 :: CheckState <- mGet + + let handleLine l = runMultiStateTNil + $ MultiState.withMultiStateA s1 + $ MultiState.withMultiStateA s2 + $ do + liftIO $ atomicModifyIORef outListRef (\x -> (l:x, ())) + replaceStackTop l + + liftIO $ observeCreateProcessWithExitCode + (shell $ c ++ " " ++ intercalate " " (fmap show ps)) + "" + handleLine + handleLine + + case exitCode of + ExitSuccess -> do + pushLog LogLevelInfo $ infoStr + return True + ExitFailure _ -> do + pushLog LogLevelPrint infoStr + outLines <- liftIO $ readIORef outListRef + reverse outLines `forM_` pushLog LogLevelPrint + logStack + return False + +runCommandSuccessCabal + :: ( MonadIO m + , MonadPlus m + , MonadMultiState CheckState m + , MonadMultiState LogState m + , MonadMultiReader Config m + ) + => [String] + -> m () +runCommandSuccessCabal ps = do + cabalInvoc <- configReadStringWithDefaultM "cabal" ["setup", "cabal-command"] + runCommandSuccess cabalInvoc ps + +runCommandSuccessHLint + :: ( MonadIO m + , MonadPlus m + , MonadMultiState CheckState m + , MonadMultiState LogState m + , MonadMultiReader Config m + ) + => [String] + -> m () +runCommandSuccessHLint ps = do + hlintInvoc <- configReadStringWithDefaultM "hlint" ["setup", "hlint-command"] + runCommandSuccess hlintInvoc ps + +runCommandStdOut + :: ( MonadIO m + , MonadPlus m + , MonadMultiState LogState m + ) + => String + -> [String] + -> m String +runCommandStdOut c ps = do + let infoStr = c ++ " " ++ intercalate " " ps + (exitCode, stdOut, _stdErr) <- liftIO $ + readShellProcessWithExitCode c ps + case exitCode of + ExitFailure _ -> do + pushLog LogLevelError $ "Error running command `" ++ infoStr ++ "`." + mzero + ExitSuccess -> do + return stdOut + +getExternalProgramVersion + :: ( MonadIO m + , MonadPlus m + , MonadMultiState LogState m + ) + => String + -> m [Int] +getExternalProgramVersion prog = do + let err = do + pushLog LogLevelError $ "Could not determine version of external program " ++ prog + mzero + (exitCode, stdOut, _stdErr) <- liftIO $ + readShellProcessWithExitCode prog ["--version"] + case exitCode of + ExitSuccess -> do + case lines stdOut of + (line:_) -> case takeWhile (`elem` ".0123456789") + $ dropWhile (not . Char.isNumber) line of + "" -> err + s -> do + pushLog LogLevelInfoVerbose $ "detected " ++ prog ++ " version " ++ s + case mapM readMaybe $ Split.splitOn "." s of + Just vs -> return vs + Nothing -> err + _ -> err + ExitFailure _ -> err + +observeCreateProcessWithExitCode + :: CreateProcess + -> String -- ^ standard input + -> (String -> IO ()) -- ^ stdout line handler + -> (String -> IO ()) -- ^ stderr line handler + -> IO (ExitCode) -- ^ exitcode +observeCreateProcessWithExitCode cp input stdoutHandler stderrHandler = do + let cp_opts = cp { + std_in = CreatePipe, + std_out = CreatePipe, + std_err = CreatePipe + } + withCreateProcess_ "observeCreateProcessWithExitCode" cp_opts $ + \(Just inh) (Just outh) (Just errh) ph -> do + + let processStream :: Handle -> (String -> IO ()) -> IO () + processStream h f = do + catchIOError (forever $ hGetLine h >>= f) (\e -> unless (isEOFError e) (ioError e)) + + -- fork off threads to start consuming stdout & stderr + withForkWait (processStream outh stdoutHandler) $ \waitOut -> + withForkWait (processStream errh stderrHandler) $ \waitErr -> do + + -- now write any input + unless (null input) $ + ignoreSigPipe $ hPutStr inh input + -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE + ignoreSigPipe $ hClose inh + + -- wait on the output + waitOut + waitErr + + -- hClose outh + -- hClose errh + + -- wait on the process + ex <- waitForProcess ph + + return ex + +-- *********** +-- copied from System.Process, because not exposed.. +withForkWait :: IO () -> (IO () -> IO a) -> IO a +withForkWait async body = do + waitVar <- newEmptyMVar :: IO (MVar (Either C.SomeException ())) + C.mask $ \restore -> do + tid <- forkIO $ C.try (restore async) >>= putMVar waitVar + let wait = takeMVar waitVar >>= either C.throwIO return + restore (body wait) `C.onException` killThread tid +withCreateProcess_ + :: String + -> CreateProcess + -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a) + -> IO a +withCreateProcess_ fun c action = + C.bracketOnError (createProcess_ fun c) cleanupProcess + (\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph) +ignoreSigPipe :: IO () -> IO () +ignoreSigPipe = C.handle $ \e -> case e of + IOError { ioe_type = ResourceVanished + , ioe_errno = Just ioe } + | Errno ioe == ePIPE -> return () + _ -> C.throwIO e + +cleanupProcess :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) + -> IO () +cleanupProcess (mb_stdin, mb_stdout, mb_stderr, + ph@(ProcessHandle _ delegating_ctlc)) = do + terminateProcess ph + -- Note, it's important that other threads that might be reading/writing + -- these handles also get killed off, since otherwise they might be holding + -- the handle lock and prevent us from closing, leading to deadlock. + maybe (return ()) (ignoreSigPipe . hClose) mb_stdin + maybe (return ()) hClose mb_stdout + maybe (return ()) hClose mb_stderr + -- terminateProcess does not guarantee that it terminates the process. + -- Indeed on Unix it's SIGTERM, which asks nicely but does not guarantee + -- that it stops. If it doesn't stop, we don't want to hang, so we wait + -- asynchronously using forkIO. + + -- However we want to end the Ctl-C handling synchronously, so we'll do + -- that synchronously, and set delegating_ctlc as False for the + -- waitForProcess (which would otherwise end the Ctl-C delegation itself). + when delegating_ctlc + stopDelegateControlC + _ <- forkIO (waitForProcess (resetCtlcDelegation ph) >> return ()) + return () + where + resetCtlcDelegation (ProcessHandle m _) = ProcessHandle m False +-- *********** diff --git a/src/Development/Iridium/Hackage.hs b/src/Development/Iridium/Hackage.hs new file mode 100644 --- /dev/null +++ b/src/Development/Iridium/Hackage.hs @@ -0,0 +1,160 @@ +module Development.Iridium.Hackage + ( retrieveLatestVersion + , uploadPackage + , uploadDocs + ) +where + + + +import Control.Monad.IO.Class +import Control.Monad.Trans.Maybe +import Control.Monad ( mzero, when ) +import Data.Maybe ( listToMaybe, maybeToList ) +import Control.Monad.Trans.MultiRWS +import Control.Monad +import Control.Exception +import Data.Version +import Distribution.Package ( PackageName(..) ) +import qualified Turtle as Turtle +import System.Exit + +import qualified Network.HTTP.Conduit as HTTP +import qualified Text.XmlHtml as Html +import qualified Data.Text as Text + +import System.Process hiding ( cwd ) + +import Development.Iridium.UI.Console +import Development.Iridium.Types +import Development.Iridium.Config +import Development.Iridium.Utils + +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Lazy as ByteStringL + + + +retrieveLatestVersion + :: ( MonadIO m + , MonadMultiState LogState m + , MonadPlus m + ) + => String -> String -> m (Maybe String) +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 + + 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 + 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 + +uploadPackage + :: forall m + . ( MonadIO m + , MonadPlus m + , MonadMultiReader Config m + , MonadMultiReader Infos m + , MonadMultiState LogState m + ) + => m () +uploadPackage = do + buildtool <- configReadStringM ["setup", "buildtool"] + pushLog LogLevelPrint "Performing upload.." + case buildtool of + "cabal" -> 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" + , 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 + _ -> mzero + +uploadDocs + :: forall m + . ( MonadIO m + , MonadPlus m + , MonadMultiReader Config m + , MonadMultiReader Infos m + , MonadMultiState LogState m + ) + => m () +uploadDocs = do + buildtool <- configReadStringM ["setup", "buildtool"] + pushLog LogLevelPrint "Performing doc upload.." + case buildtool of + "cabal" -> do + username <- configReadStringMaybeM ["setup", "hackage", "username"] + password <- configReadStringMaybeM ["setup", "hackage", "password"] + infoVerbEnabled <- isEnabledLogLevel LogLevelInfoVerbose + mzeroIfNonzero $ liftIO $ + runProcess "cabal" + ( [ "upload" + , "--doc" + ] + ++ ["-u" ++ u | u <- maybeToList username] + ++ ["-p" ++ p | p <- maybeToList password] + ++ ["-v0" | not infoVerbEnabled] + ) + Nothing Nothing Nothing Nothing Nothing + >>= waitForProcess + pushLog LogLevelPrint "Documentation upload successful." + "stack" -> do + pushLog LogLevelError "TODO: stack upload" + mzero + _ -> mzero diff --git a/src/Development/Iridium/Repo/Git.hs b/src/Development/Iridium/Repo/Git.hs new file mode 100644 --- /dev/null +++ b/src/Development/Iridium/Repo/Git.hs @@ -0,0 +1,128 @@ +module Development.Iridium.Repo.Git + ( GitImpl + ) +where + + + +import Control.Monad +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Class +import Control.Monad.IO.Class +import Control.Monad.Trans.MultiRWS +import Control.Monad.Extra ( whenM ) +import Data.List.Extra +import Data.Version +import System.Process hiding ( cwd ) +import Data.Char + +import Development.Iridium.Types +import Development.Iridium.Utils +import Development.Iridium.ExternalProgWrappers +import Development.Iridium.UI.Console +import Development.Iridium.Config +import Development.Iridium.CheckState + + + +data GitImpl = GitImpl + { _git_branchName :: String + } + +instance Repo GitImpl where + repo_retrieveInfo = do + branchStringRaw <- runCommandStdOut "git" ["branch"] + case branchStringRaw of + ('*':' ':branchName) -> + return $ GitImpl $ takeWhile (`notElem` "\n\r") branchName + _ -> do + pushLog LogLevelError "Could not parse current git branch name." + mzero + repo_runChecks _git = withStack "[git]" $ do + pushLog LogLevelPrint "[git]" + withIndentation $ do + uncommittedChangesCheck + repo_displaySummary git = do + pushLog LogLevelPrint $ "[git]" + withIndentation $ do + whenM (configIsTrueM ["repository", "git", "display-current-branch"]) $ + pushLog LogLevelPrint $ "Branch: " ++ _git_branchName git + repo_ActionSummary _git = do + tagEnabled <- configIsEnabledM ["repository", "git", "release-tag"] + tagAction <- if tagEnabled + then do + tagStr <- askTagString + return $ ["Tag the current commit with \"" ++ tagStr ++ "\""] + else + return [] + pushEnabled <- configIsEnabledM ["repository", "git", "push-remote"] + return $ tagAction + ++ ["Push current branch and tag to upstream repo" | pushEnabled] + repo_performAction git = do + tagEnabled <- configIsEnabledM ["repository", "git", "release-tag"] + when tagEnabled $ do + pushLog LogLevelPrint "[git] Tagging this release." + withIndentation $ do + tagStr <- askTagString + curOut <- runCommandStdOut "git" ["tag", "-l", tagStr] + pushLog LogLevelDebug curOut + if all isSpace curOut + then do + mzeroIfNonzero $ liftIO $ + runProcess "git" + ( [ "tag" + , tagStr + ] + ) + Nothing Nothing Nothing Nothing Nothing + >>= waitForProcess + pushLog LogLevelPrint $ "Tagged as " ++ tagStr + else pushLog LogLevelPrint "Tag already exists, leaving it as-is." + pushEnabled <- configIsEnabledM ["repository", "git", "push-remote"] + when pushEnabled $ do + pushLog LogLevelPrint "[git] Pushing to remote." + withIndentation $ do + remote <- configReadStringWithDefaultM "origin" ["repository", "git", "push-remote", "remote-name"] + mzeroIfNonzero $ liftIO $ + runProcess "git" + ( [ "push" + , "--tags" + , remote + , _git_branchName git + ] + ) + Nothing Nothing Nothing Nothing Nothing + >>= waitForProcess + return () + +askTagString + :: ( MonadMultiReader Config m + , MonadMultiReader Infos m + ) + => m String +askTagString = do + tagRawStr <- configReadStringWithDefaultM "$VERSION" ["repository", "git", "release-tag", "content"] + vers <- liftM showVersion askPackageVersion + return $ replace "$VERSION" vers tagRawStr + + +uncommittedChangesCheck + :: ( MonadIO m + , MonadPlus m + , MonadMultiState CheckState m + , MonadMultiState LogState m + ) + => m () +uncommittedChangesCheck = boolToWarning + $ runCheck "Testing for uncommitted changes" + $ withStack "git status -uno" + $ do + changesRaw <- runCommandStdOut "git" ["status", "-uno", "--porcelain"] + let changes = lines changesRaw + if null changes + then + return True + else do + pushLog LogLevelPrint $ "git status reports uncommitted changes:" + withIndentation $ changes `forM_` pushLog LogLevelPrint + return False diff --git a/src/Development/Iridium/Types.hs b/src/Development/Iridium/Types.hs new file mode 100644 --- /dev/null +++ b/src/Development/Iridium/Types.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} + +module Development.Iridium.Types + ( Infos (..) + , Repo (..) + , NoRepo (..) + , LogLevel (..) + , LogState (..) + , Config + , repoRunChecks + , repoDisplaySummary + , repoActionSummary + , repoPerformAction + , CheckState (..) + ) +where + + +import Prelude hiding ( FilePath ) + +import qualified Data.Yaml as Yaml +import Control.Monad.Trans.MultiRWS +import Control.Monad.Trans.MultiState +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Class +import Data.HList.HList +import Control.Monad.IO.Class +import Distribution.PackageDescription +import Data.Version ( Version(..) ) +import Data.Proxy +import Data.Tagged +import Control.Applicative +import Control.Monad +import Data.HList.ContainsType +import Control.Monad.Trans.Control +import Control.Monad.Base + +import qualified Filesystem.Path.CurrentOS as Path + + + +data LogLevel = LogLevelSilent + | LogLevelPrint -- like manual output; should never be filtered + | LogLevelDebug + | LogLevelTrace + | LogLevelWarn + | LogLevelError + | LogLevelInfo + | LogLevelInfoVerbose + | LogLevelInfoVerboser + | LogLevelInfoSpam + | LogLevelThread + deriving (Show, Eq) + +data LogState = LogState + { _log_mask :: [LogLevel] + , _log_indent :: Int + , _log_prepared :: Maybe String + , _log_cur :: String + } + +type Config = Yaml.Value + +data Infos = forall repo . Repo repo => Infos + { _i_cwd :: Path.FilePath + , _i_package :: GenericPackageDescription + , _i_remote_version :: Maybe Version + , _i_repo :: repo + } + +data CheckState = CheckState + { _check_stack :: [String] + , _check_errorCount :: Int + , _check_warningCount :: Int + , _check_notWallClean :: [String] + } + +class Repo a where + -- | the action to retrieve/collect all the + -- data relevant for the later steps. + repo_retrieveInfo :: ( MonadIO m + , MonadPlus m + , MonadMultiReader Config m + , MonadMultiState LogState m + ) + => m a + -- | The checks to be run for this repo type + repo_runChecks :: ( MonadIO m + , MonadPlus m + , MonadMultiReader Config m + , MonadMultiState LogState m + , MonadMultiState CheckState m + ) + => a -> m () + -- | Summary of repository-type-specific information + -- to display to the user, e.g. "current branch: .." + repo_displaySummary :: ( MonadIO m + , MonadMultiReader Config m + , MonadMultiState LogState m + ) + => a -> m () + -- | (Configured) (repository-type-specific) actions + -- that will be taken, e.g. "Tag the current commit" + repo_ActionSummary :: ( MonadMultiReader Config m + , MonadMultiReader Infos m + , MonadMultiState LogState m + ) + => a -> m [String] + -- | Perform repository-type-specific real side-effects. + -- This is post-confirmation by the user, but before + -- doing hackage upload. + repo_performAction :: ( MonadIO m + , MonadPlus m + , MonadMultiReader Config m + , MonadMultiReader Infos m + , MonadMultiState LogState m + ) + => a -> m () + +repoRunChecks + :: ( MonadIO m + , MonadPlus m + , MonadMultiReader Infos m + , MonadMultiReader Config m + , MonadMultiState LogState m + , MonadMultiState CheckState m + ) + => m () +repoRunChecks = do + Infos _ _ _ repo <- mAsk + repo_runChecks repo + +repoDisplaySummary + :: ( MonadIO m + , MonadMultiReader Infos m + , MonadMultiReader Config m + , MonadMultiState LogState m + ) + => m () +repoDisplaySummary = do + Infos _ _ _ repo <- mAsk + repo_displaySummary repo + +repoActionSummary + :: ( MonadIO m + , MonadMultiReader Infos m + , MonadMultiReader Config m + , MonadMultiState LogState m + ) + => m [String] +repoActionSummary = do + Infos _ _ _ repo <- mAsk + repo_ActionSummary repo + +repoPerformAction + :: ( MonadIO m + , MonadPlus m + , MonadMultiReader Infos m + , MonadMultiReader Config m + , MonadMultiState LogState m + ) + => m () +repoPerformAction = do + Infos _ _ _ repo <- mAsk + repo_performAction repo + +-- witnessProxy :: Tagged a b -> (Proxy a -> r) -> r +-- witnessProxy _ f = f Proxy + +data NoRepo = NoRepo + +instance Repo NoRepo where + repo_retrieveInfo = return $ NoRepo + repo_runChecks _ = return () + repo_displaySummary _ = return () + repo_ActionSummary _ = return [] + repo_performAction _ = return () diff --git a/src/Development/Iridium/UI/Console.hs b/src/Development/Iridium/UI/Console.hs new file mode 100644 --- /dev/null +++ b/src/Development/Iridium/UI/Console.hs @@ -0,0 +1,220 @@ +module Development.Iridium.UI.Console + ( LogLevel (..) + , setLogMask + , pushLog + , pushLogPrepare + , pushLogFinalize + , writeCurLine + , pushCurLine + , LogState + , initialLogState + , withIndentation + , withoutIndentation + , isEnabledLogLevel + ) +where + + + +import qualified System.Unsafe as Unsafe +import Data.IORef +import Control.Monad +import Control.Monad.IO.Class + +import Control.Monad.Trans.MultiRWS + +import System.Console.ANSI +import System.IO + +import Development.Iridium.Types + + + +initialLogState :: LogState +initialLogState = LogState + [ LogLevelPrint + , LogLevelWarn + , LogLevelError + , LogLevelInfo + ] + 0 + Nothing + "" + +-- only logmessages that are _in_ the list in this IORef are printed. +-- {-# NOINLINE currentLogMask #-} +-- currentLogMask :: IORef [LogLevel] +-- currentLogMask +-- = Unsafe.performIO +-- $ newIORef +-- $ [ LogLevelPrint +-- , LogLevelWarn +-- , LogLevelError +-- , LogLevelInfo +-- ] + +-- setLogMask :: MonadIO io => [LogLevel] -> io () +-- setLogMask = liftIO . writeIORef currentLogMask + +-- putLog :: MonadIO io => LogLevel -> String -> io () +-- putLog level message = liftIO $ do +-- mask <- readIORef currentLogMask +-- when (level `elem` mask) $ +-- putStrLn message + +setLogMask + :: ( MonadMultiState LogState m ) + => [LogLevel] + -> m () +setLogMask levels = do + s <- mGet + mSet $ s { _log_mask = levels } + +withIndentation + :: MonadMultiState LogState m + => m a + -> m a +withIndentation k = do + s <- mGet + mSet $ s { _log_indent = _log_indent s + 1 } + r <- k + s2 <- mGet + mSet $ s2 { _log_indent = _log_indent s } + return r + +withoutIndentation + :: MonadMultiState LogState m + => m a + -> m a +withoutIndentation k = do + s <- mGet + mSet $ s { _log_indent = 0 } + r <- k + mSet s -- we do a full reset here. this might be evil. + -- but probably just the right thing to do. + return r + +checkWhenLevel + :: ( MonadMultiState LogState m ) + => LogLevel + -> m () + -> m () +checkWhenLevel level m = do + s <- mGet + when (level `elem` _log_mask s) m + +getIndentLine + :: ( MonadMultiState LogState m ) + => String + -> m String +getIndentLine str = do + s <- mGet + return $ replicate (2*_log_indent s) ' ' ++ str + +flushPrepared + :: ( MonadIO m + , MonadMultiState LogState m + ) + => m () +flushPrepared = do + s <- mGet + liftIO $ clearLine >> setCursorColumn 0 >> hFlush stdout + case _log_prepared s of + Nothing -> return () + Just x -> do + liftIO $ putStrLn x + mSet $ s { _log_prepared = Nothing } + +pushLog + :: ( MonadMultiState LogState m + , MonadIO m + ) + => LogLevel + -> String + -> m () +pushLog level message = checkWhenLevel level $ do + flushPrepared + forM_ (lines message) $ + (liftIO . putStrLn =<<) . getIndentLine + +pushLogPrepare + :: ( MonadMultiState LogState m + , MonadIO m + ) + => String + -> m () +pushLogPrepare message = do + s <- mGet + flushPrepared + mess <- getIndentLine message + mSet $ s { _log_prepared = Just mess } + +pushLogFinalize + :: ( MonadMultiState LogState m + , MonadIO m + ) + => Int + -> String + -> m () +pushLogFinalize indent message = do + s <- mGet + liftIO $ clearLine >> setCursorColumn 0 >> hFlush stdout + case _log_prepared s of + Nothing -> do + liftIO $ putStrLn $ replicate indent ' ' ++ message + Just x -> do + liftIO $ if length x > indent + then do + putStrLn x + putStrLn $ replicate indent ' ' ++ message + else do + putStrLn $ x ++ replicate (indent - length x) ' ' ++ message + mSet $ s { _log_prepared = Nothing } + +writeCurLine + :: ( MonadMultiState LogState m + , MonadIO m + ) + => String + -> m () +writeCurLine message = do + liftIO $ clearLine >> setCursorColumn 0 + s <- mGet + imess <- getIndentLine message + liftIO $ putStr $ "> " ++ imess + liftIO $ hFlush stdout + mSet $ s { _log_cur = imess } + +pushCurLine + :: ( MonadMultiState LogState m + , MonadIO m + ) + => LogLevel + -> m () +pushCurLine level = do + s <- mGet + if level `elem` _log_mask s + then liftIO $ putStrLn "" + else liftIO $ clearLine >> setCursorColumn 0 >> hFlush stdout + mSet $ s { _log_cur = "" } + +isEnabledLogLevel + :: ( MonadMultiState LogState m ) + => LogLevel + -> m Bool +isEnabledLogLevel level = do + s <- mGet + return $ level `elem` _log_mask s + +-- putLog +-- :: ( MonadMultiState LogState m +-- , MonadIO m +-- ) +-- => LogLevel +-- -> String +-- -> m () +-- putLog level message = do +-- LogState mask i <- mGet +-- liftIO $ when (level `elem` mask) $ +-- putStrLn $ replicate (2*i) ' ' ++ message + diff --git a/src/Development/Iridium/UI/Prompt.hs b/src/Development/Iridium/UI/Prompt.hs new file mode 100644 --- /dev/null +++ b/src/Development/Iridium/UI/Prompt.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE TypeFamilies #-} + +module Development.Iridium.UI.Prompt + ( askConfirmationOrMZero + , promptYesOrNo + , promptSpecific + ) +where + + + +import qualified Data.Text as Text +import qualified Turtle as Turtle +import qualified Control.Foldl as Foldl + +import Data.Text ( Text ) +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Class +import Control.Monad.IO.Class +import Control.Monad + +import Development.Iridium.Types +import Development.Iridium.UI.Console +import Development.Iridium.Config + +import Control.Monad.Trans.MultiRWS + +-- well, fuck Turtle, apparently. +-- no way to retrieve stdout, stderr and exitcode. +-- the most generic case, not supported? psshhh. +import System.Process +import System.IO ( hFlush, stdout ) +import Control.Concurrent ( threadDelay ) + + + +askConfirmationOrMZero + :: ( MonadIO m + , MonadPlus m + , MonadMultiState LogState m + ) + => m () +askConfirmationOrMZero = do + liftIO $ putStr "> Abort imminent; enter 'i' to overwrite and continue> " + liftIO $ hFlush stdout + s <- liftIO $ getLine + case s of + "i" -> do + pushLog LogLevelPrint " (Remember that you can disable individual tests in iridium.yaml)" + liftIO $ threadDelay 1000000 + return () + _ -> mzero + +promptYesOrNo + :: (MonadIO m, MonadPlus m) + => String + -> m () +promptYesOrNo p = do + liftIO $ putStr $ "> " ++ p ++ "> " + liftIO $ hFlush stdout + s <- liftIO $ getLine + case s of + "y" -> do + return () + "n" -> mzero + _ -> promptYesOrNo p + +promptSpecific + :: (MonadIO m, MonadPlus m) + => String + -> String + -> m () +promptSpecific p cont = do + liftIO $ putStr $ "> " ++ p ++ "> " + liftIO $ hFlush stdout + s <- liftIO $ getLine + if s == cont then return () else mzero diff --git a/src/Development/Iridium/Utils.hs b/src/Development/Iridium/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Development/Iridium/Utils.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ExistentialQuantification #-} + +module Development.Iridium.Utils + ( askAllBuildInfo + , askPackageName + , askPackageVersion + , mzeroToFalse + , falseToMZero + , runCheck + , fallbackCheck + -- , falseToConfirm + , falseToAbort + , ignoreBool + , boolToWarning + , boolToError + , getLocalFilePath + , mzeroIfNonzero + ) +where + + +import Prelude hiding ( FilePath ) + +import qualified Data.Text as Text +import qualified Turtle as Turtle +import qualified Control.Foldl as Foldl +import qualified Control.Exception as C + +import qualified Data.Yaml as Yaml +import Control.Monad.Trans.MultiRWS +import Control.Monad.Trans.MultiState as MultiState +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Class +import Control.Monad.IO.Class +import Distribution.PackageDescription +import Distribution.Package +import Filesystem.Path.CurrentOS hiding ( null ) +import Data.Version ( Version(..) ) +import Data.Proxy +import Data.Tagged +import Control.Applicative +import Control.Monad +import Data.Functor +import Data.List +import System.Exit +import System.IO +import Control.Concurrent.MVar +import Control.Concurrent +import System.IO.Error +import GHC.IO.Exception ( ioException, IOErrorType(..), IOException(..) ) +import Foreign.C +import System.Process.Internals +import Data.IORef +import qualified Data.List.Split as Split +import qualified System.Process as Process +import qualified Data.Char as Char +import Text.Read ( readMaybe ) + +-- well, no Turtle, apparently. +-- no way to retrieve stdout, stderr and exitcode. +-- the most generic case, not supported? psshhh. +import System.Process hiding ( cwd ) + +import Data.Maybe ( maybeToList ) + +import qualified Filesystem.Path.CurrentOS as Path + +import Development.Iridium.Types +import Development.Iridium.UI.Console +import Development.Iridium.UI.Prompt +import Development.Iridium.CheckState +import Development.Iridium.Config + + + +runCheck + :: ( MonadIO m + , MonadMultiState LogState m + ) + => String + -> m Bool + -> m Bool +runCheck s m = do + pushLogPrepare $ s ++ ":" + writeCurLine $ s ++ ":" + r <- withIndentation m + if r + then do + pushLogFinalize 70 "clear." + return True + else do + pushLogFinalize 70 "failed." + pushLog LogLevelPrint $ "(Latest: " ++ s ++ ")" + return False + +askAllBuildInfo :: (MonadMultiReader Infos m) => m [BuildInfo] +askAllBuildInfo = do + Infos _ pDesc _ _ <- mAsk + return $ (libBuildInfo . condTreeData <$> maybeToList (condLibrary pDesc)) + ++ (buildInfo . condTreeData . snd <$> condExecutables pDesc) + ++ (testBuildInfo . condTreeData . snd <$> condTestSuites pDesc) + ++ (benchmarkBuildInfo . condTreeData . snd <$> condBenchmarks pDesc) + +askPackageName :: MonadMultiReader Infos m => m PackageName +askPackageName = do + Infos _ pDesc _ _ <- mAsk + return $ pkgName $ package $ packageDescription pDesc + +askPackageVersion :: MonadMultiReader Infos m => m Version +askPackageVersion = do + Infos _ pDesc _ _ <- mAsk + return $ pkgVersion $ package $ packageDescription pDesc + +mzeroToFalse :: Monad m => MaybeT m a -> m Bool +mzeroToFalse m = do + x <- runMaybeT m + case x of + Nothing -> return False + Just _ -> return True + +falseToMZero :: MonadPlus m => m Bool -> m () +falseToMZero m = m >>= guard + +-- mzeroToFalse :: MonadPlus m => m a -> m Bool +-- mzeroToFalse m = liftM (const True) m `mplus` return False + +-- falseToConfirm +-- :: (MonadMultiState LogState m, MonadPlus m, MonadIO m) => m Bool -> m Bool +-- falseToConfirm m = m >>= \x -> if x +-- then return True +-- else askConfirmationOrMZero >> return False + +falseToAbort :: MonadPlus m => m Bool -> m Bool +falseToAbort m = m >>= guard >> return True + +fallbackCheck :: Monad m => m Bool -> m Bool -> m Bool +fallbackCheck m1 m2 = do + x <- m1 + if x + then return True + else m2 + +mzeroIfNonzero + :: ( MonadPlus m ) + => m ExitCode + -> m () +mzeroIfNonzero k = do + r <- k + case r of + ExitSuccess -> return () + ExitFailure _ -> mzero + +ignoreBool :: Monad m => m Bool -> m () +ignoreBool = liftM (const ()) + +boolToWarning + :: ( MonadMultiState CheckState m ) + => m Bool + -> m () +boolToWarning m = do + b <- m + unless b incWarningCounter + + +boolToError + :: ( MonadMultiState CheckState m ) + => m Bool + -> m () +boolToError m = do + b <- m + unless b incErrorCounter + + +getLocalFilePath + :: ( MonadMultiReader Infos m ) + => String + -> m Turtle.FilePath +getLocalFilePath s = do + infos <- mAsk + return $ _i_cwd infos decodeString s