iridium (empty) → 0.1.5.1
raw patch · 18 files changed
+2959/−0 lines, 18 filesdep +Cabaldep +ansi-terminaldep +basesetup-changed
Dependencies added: Cabal, ansi-terminal, base, bytestring, containers, extra, foldl, http-conduit, iridium, lifted-base, monad-control, multistate, process, split, system-filepath, tagged, text, transformers, transformers-base, turtle, unordered-containers, unsafe, vector, xmlhtml, yaml
Files
- ChangeLog.md +30/−0
- LICENSE +30/−0
- README.md +85/−0
- Setup.hs +2/−0
- data/default-iridium.yaml +129/−0
- iridium.cabal +149/−0
- src-main/Main.hs +88/−0
- src/Development/Iridium.hs +233/−0
- src/Development/Iridium/CheckState.hs +133/−0
- src/Development/Iridium/Checks.hs +508/−0
- src/Development/Iridium/Config.hs +334/−0
- src/Development/Iridium/ExternalProgWrappers.hs +288/−0
- src/Development/Iridium/Hackage.hs +160/−0
- src/Development/Iridium/Repo/Git.hs +128/−0
- src/Development/Iridium/Types.hs +182/−0
- src/Development/Iridium/UI/Console.hs +220/−0
- src/Development/Iridium/UI/Prompt.hs +77/−0
- src/Development/Iridium/Utils.hs +183/−0
+ ChangeLog.md view
@@ -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.
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,85 @@+# iridium++[](http://travis-ci.org/lspitzner/iridium)+[](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. |
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ data/default-iridium.yaml view
@@ -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"+...
+ iridium.cabal view
@@ -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+ }+}
+ src-main/Main.hs view
@@ -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 ()
+ src/Development/Iridium.hs view
@@ -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
+ src/Development/Iridium/CheckState.hs view
@@ -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 }
+ src/Development/Iridium/Checks.hs view
@@ -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 "<default>"+ 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
+ src/Development/Iridium/Config.hs view
@@ -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
+ src/Development/Iridium/ExternalProgWrappers.hs view
@@ -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+-- ***********
+ src/Development/Iridium/Hackage.hs view
@@ -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
+ src/Development/Iridium/Repo/Git.hs view
@@ -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
+ src/Development/Iridium/Types.hs view
@@ -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 ()
+ src/Development/Iridium/UI/Console.hs view
@@ -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+
+ src/Development/Iridium/UI/Prompt.hs view
@@ -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
+ src/Development/Iridium/Utils.hs view
@@ -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