├── .gitignore ├── .travis.yml ├── ChangeLog.md ├── LICENSE ├── Readme.md ├── Setup.hs ├── doc └── jenga.jpg ├── jenga.cabal ├── main └── jenga.hs ├── src ├── Jenga.hs └── Jenga │ ├── Cabal.hs │ ├── Config.hs │ ├── Git.hs │ ├── Git │ ├── Command.hs │ ├── Process.hs │ └── SubModules.hs │ ├── HTTP.hs │ ├── IO.hs │ ├── Merge.hs │ ├── PackageList.hs │ ├── Render.hs │ ├── Stack.hs │ └── Types.hs └── test ├── Test └── Jenga │ ├── Config.hs │ ├── Gen.hs │ └── Stack.hs ├── cli ├── core │ └── runner ├── git-extra-dep │ ├── data │ │ ├── git-extra-dep.cabal │ │ ├── init-simple.cabal │ │ └── stack.yaml │ ├── expected │ │ ├── git-extra-dep.lock-8.0.2 │ │ └── jenga.yaml │ └── run ├── init-drop-deps │ ├── data │ │ ├── init-drop-deps.cabal │ │ └── stack.yaml │ ├── expected │ │ ├── init-drop-deps.lock-8.0.2 │ │ └── jenga.yaml │ └── run ├── init-extra-deps │ ├── data │ │ ├── init-extra-deps.cabal │ │ └── stack.yaml │ ├── expected │ │ ├── init-extra-deps.lock-8.0.2 │ │ └── jenga.yaml │ └── run ├── init-freeze │ ├── data │ │ ├── init-freeze.cabal │ │ └── stack.yaml │ ├── expected │ │ ├── cabal.config │ │ └── jenga.yaml │ └── run ├── init-simple │ ├── data │ │ ├── init-simple.cabal │ │ └── stack.yaml │ ├── expected │ │ ├── init-simple.lock-8.0.2 │ │ └── jenga.yaml │ └── run ├── init-specific │ ├── data │ │ ├── init-specific.cabal │ │ ├── stack-specific.yaml │ │ └── stack.yaml │ ├── expected │ │ ├── init-specific.lock-8.2.2 │ │ └── jenga.yaml │ └── run ├── init-submodules-dir │ ├── data │ │ ├── init-submodules-dir.cabal │ │ ├── lib │ │ │ └── dummy.txt │ │ └── stack.yaml │ └── run ├── init-submodules │ ├── data │ │ ├── init-submodules.cabal │ │ └── stack.yaml │ ├── expected │ │ ├── init-submodules.lock-8.0.2 │ │ └── jenga.yaml │ └── run ├── parse-jenga-config │ ├── data │ │ ├── jenga-0001.yaml │ │ └── jenga-0002.yaml │ ├── expected │ │ ├── jenga-0001.json │ │ ├── jenga-0002.json │ │ ├── stack-0001.json │ │ ├── stack-0002.json │ │ ├── stack-0003.json │ │ ├── stack-0004.json │ │ └── stack-0005.json │ └── run ├── parse-stack-config │ ├── data │ │ ├── stack-0001.yaml │ │ ├── stack-0002.yaml │ │ ├── stack-0003.yaml │ │ ├── stack-0004.yaml │ │ └── stack-0005.yaml │ ├── expected │ │ ├── stack-0001.json │ │ ├── stack-0002.json │ │ ├── stack-0003.json │ │ ├── stack-0004.json │ │ └── stack-0005.json │ └── run └── update │ ├── data │ ├── stack-7.0.yaml │ ├── stack-9.1.yaml │ └── update.cabal │ ├── expected │ ├── jenga-7.0.yaml │ ├── jenga-9.1.yaml │ ├── update.lock-8.0.1 │ └── update.lock-8.0.2 │ └── run ├── test-cli.hs └── test.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .cabal-sandbox/ 2 | cabal.sandbox.config 3 | dist/ 4 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # language: haskell 2 | 3 | env: 4 | # - GHCVER=7.6.3 5 | # - GHCVER=7.8.4 6 | - GHCVER=7.10.3 7 | - GHCVER=8.0.2 8 | - GHCVER=8.2.2 9 | - GHCVER=8.4.2 10 | 11 | before_install: 12 | - sudo add-apt-repository -y ppa:hvr/ghc 13 | - sudo apt-get update 14 | - sudo apt-get install cabal-install-2.0 ghc-$GHCVER happy 15 | - export PATH=/opt/cabal/2.0/bin:/opt/ghc/$GHCVER/bin:$PATH 16 | 17 | install: 18 | - cabal update 19 | - cabal sandbox init 20 | - cabal install --only-dependencies --enable-tests 21 | 22 | script: 23 | - cabal configure --enable-tests 24 | - cabal build 25 | - dist/build/test/test 26 | - dist/build/test-cli/test-cli 27 | - cabal haddock 28 | - cabal sdist 29 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for jenga 2 | 3 | ## 0.1.1.0 -- 2017-05-14 4 | 5 | * Make it build with ghc 8.2.0rc2 and later. 6 | 7 | ## 0.1.0.0 -- 2017-03-05 8 | 9 | * First version. Released on an unsuspecting world. 10 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017, Erik de Castro Lopo 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are 6 | met: 7 | 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the 14 | distribution. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 17 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 18 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 19 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 20 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 21 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 22 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 23 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 24 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 25 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | -------------------------------------------------------------------------------- /Readme.md: -------------------------------------------------------------------------------- 1 | # Jenga 2 | 3 | 4 | [![Build Status](https://secure.travis-ci.org/erikd/jenga.svg?branch=master)](http://travis-ci.org/erikd/jenga) 5 | 6 | ![jenga](doc/jenga.jpg) 7 | 8 | A trivial Haskell program that hopefully makes a 9 | [Haskell Stack](https://docs.haskellstack.org/en/stable/README/) project with 10 | poorly defined package dependencies buildable with standard tools like cabal 11 | or [mafia](https://github.com/ambiata/mafia/). 12 | 13 | 14 | # Using it 15 | 16 | For example, I wanted to build 17 | [haskellnews](https://github.com/haskellnews/haskellnews/) but its cabal file 18 | had close to zero dependency bounds. With `jenga` at least I could install the 19 | basic dependencies: 20 | 21 | ``` 22 | git clone https://github.com/haskellnews/haskellnews/ 23 | cd haskellnews 24 | jenga -i haskellnews.cabal > cabal.config 25 | # Manually remove the dependency on `base` 26 | cabal sandbox init 27 | cabal install --dependencies-only 28 | ``` 29 | 30 | It wasn't enough to actually build the project but it got me a lot closer. 31 | 32 | 33 | # How it works 34 | 35 | You run it in Haskell project directory that contains both the projects cabal 36 | file and the `stack.yaml` file. It then: 37 | 38 | 1. Reads the cabal file to extract the dependent library names. 39 | 2. Reads the `stack.yaml` file to extract the Stack resolver version. 40 | 3. Queries the Stackage server with the resolver version to get a JSON blob 41 | containing the packages and the versions for that resolver version and 42 | converts it into a `Map` from package name to package info. 43 | 4. For each of the package names read in step 1. it looks up the package name in 44 | the `Map` from step 3. 45 | 5. Prints the package and version info from step 4. to `stdout` in the form of 46 | a cabal freeze file (should be named `cabal.config` for cabal to recognise 47 | it). 48 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /doc/jenga.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/erikd/jenga/1eea61841f904bff018934fb58024c94fa77ffd7/doc/jenga.jpg -------------------------------------------------------------------------------- /jenga.cabal: -------------------------------------------------------------------------------- 1 | -- Initial jenga.cabal generated by cabal init. For further documentation, 2 | -- see http://haskell.org/cabal/users-guide/ 3 | 4 | name: jenga 5 | version: 0.1.1.0 6 | synopsis: Generate a cabal freeze file from a stack.yaml 7 | description: 8 | Jenga is a tool that allows Haskell projects that are developed using the 9 | Stack tool and infrastructure to be built using plain Cabal or alternatives 10 | like Mafia. It works by reading the stack.yaml file to get the stack version, 11 | querying the Stackage server for the package version for that stack version 12 | and then generating a cabal freeze or mafia lock file. 13 | 14 | homepage: https://github.com/erikd/jenga 15 | license: BSD2 16 | license-file: LICENSE 17 | author: Erik de Castro Lopo 18 | maintainer: erikd@mega-nerd.com 19 | copyright: Copyright (c) 2017 Erik de Castro Lopo 20 | category: Development 21 | build-type: Simple 22 | extra-source-files: ChangeLog.md 23 | cabal-version: >= 1.10 24 | 25 | library 26 | ghc-options: -Wall -fwarn-tabs 27 | default-language: Haskell2010 28 | hs-source-dirs: src 29 | 30 | build-depends: base >= 4.8 && < 5 31 | , aeson >= 1.1 && < 1.4 32 | , aeson-pretty == 0.8.* 33 | , async == 2.2.* 34 | , bytestring == 0.10.* 35 | , Cabal == 2.2.* 36 | , containers == 0.5.* 37 | , directory == 1.3.* 38 | , exceptions == 0.8.* && < 0.11 39 | , extra == 1.6.* 40 | , filepath == 1.4.* 41 | , HsYAML >= 0.1.1 && < 0.2 42 | , http-conduit == 2.3.* 43 | , http-types >= 0.9 && < 0.13 44 | , process == 1.6.* 45 | , text == 1.2.* 46 | , transformers >= 0.4 && < 0.7 47 | , transformers-either == 0.1.* 48 | , unix == 2.7.* 49 | , vector == 0.12.* 50 | 51 | exposed-modules: Jenga 52 | 53 | other-modules: Jenga.Cabal 54 | , Jenga.Config 55 | , Jenga.PackageList 56 | , Jenga.Git 57 | , Jenga.Git.Command 58 | , Jenga.Git.Process 59 | , Jenga.Git.SubModules 60 | , Jenga.HTTP 61 | , Jenga.IO 62 | , Jenga.Merge 63 | , Jenga.Render 64 | , Jenga.Stack 65 | , Jenga.Types 66 | 67 | other-extensions: OverloadedStrings 68 | 69 | 70 | executable jenga 71 | ghc-options: -Wall -fwarn-tabs 72 | default-language: Haskell2010 73 | hs-source-dirs: main 74 | main-is: jenga.hs 75 | 76 | build-depends: base 77 | , ansi-wl-pprint == 0.6.* 78 | , bytestring 79 | , containers 80 | , directory 81 | , extra 82 | , filepath 83 | , jenga 84 | , optparse-applicative == 0.14.* 85 | , text 86 | , transformers 87 | , transformers-either 88 | 89 | test-suite test 90 | type: exitcode-stdio-1.0 91 | ghc-options: -Wall -fwarn-tabs 92 | default-language: Haskell2010 93 | hs-source-dirs: test 94 | main-is: test.hs 95 | 96 | other-modules: Test.Jenga.Config 97 | Test.Jenga.Gen 98 | Test.Jenga.Stack 99 | 100 | build-depends: base 101 | , filepath 102 | , hedgehog == 0.6.* 103 | , hedgehog-corpus == 0.1.* 104 | , jenga 105 | , text 106 | 107 | test-suite test-cli 108 | type: exitcode-stdio-1.0 109 | ghc-options: -Wall -fwarn-tabs 110 | default-language: Haskell2010 111 | hs-source-dirs: test 112 | main-is: test-cli.hs 113 | 114 | build-depends: base 115 | , directory 116 | , process 117 | -------------------------------------------------------------------------------- /main/jenga.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import Control.Monad (forM_, unless) 4 | import Control.Monad.Extra (concatMapM) 5 | import Control.Monad.IO.Class (liftIO) 6 | import Control.Monad.Trans.Either (EitherT, left, runEitherT) 7 | import Control.Monad.Trans.Either.Exit (orDie) 8 | 9 | import qualified Data.ByteString.Char8 as BS 10 | import Data.Either (partitionEithers) 11 | import qualified Data.List as List 12 | import Data.Maybe (fromMaybe) 13 | import Data.Monoid ((<>)) 14 | import Data.Text (Text) 15 | import qualified Data.Text as Text 16 | import qualified Data.Text.IO as Text 17 | 18 | import Jenga 19 | 20 | import Options.Applicative 21 | ( CommandFields, Mod, Parser, ParserInfo, ParserPrefs, (<**>) 22 | , help, helper, long, metavar, short, strOption) 23 | import qualified Options.Applicative as O 24 | 25 | import System.FilePath ((), takeDirectory) 26 | import System.IO (stderr) 27 | 28 | import Text.PrettyPrint.ANSI.Leijen (Doc) 29 | 30 | main :: IO () 31 | main = 32 | O.customExecParser p opts >>= commandHandler 33 | where 34 | opts :: ParserInfo Command 35 | opts = O.info (helper <*> pCommand) 36 | ( O.fullDesc <> O.header "jenga - A tool for helping to build Stack projects" 37 | ) 38 | p :: ParserPrefs 39 | p = O.prefs O.showHelpOnEmpty 40 | 41 | -- ----------------------------------------------------------------------------- 42 | 43 | data Command 44 | = Initialize JengaConfig (Maybe StackFilePath) 45 | | Update 46 | | ParseStack StackFilePath 47 | | ParseJenga FilePath 48 | 49 | 50 | pCommand :: Parser Command 51 | pCommand = O.subparser $ mconcat 52 | [ subCommand "init" 53 | ( "Initialize a project to be built with Mafia. Specifically that means:\n" 54 | <> " * Add all git locations in the stack file as git submodules\n" 55 | <> " * Find all the cabal files that are not submodules and generate a lock file for each\n" 56 | <> "This command assumes that it is being run in a Git repo and that that 'stack.yaml' file is in the top level directory of the Git repo." 57 | <> "This command will also generate a '.jenga' file in the top level directory.") 58 | (Initialize <$> jengaConfigP <*> O.optional stackFilePathP) 59 | 60 | , subCommand "update" 61 | ( "Update a previously initialized a project. A typical use case would be doing a" 62 | <> "git pull on a project (which may have changed stack resolvers, exxtra dependencies" 63 | <> "or other things) and want to build is the new updated project. This sub command" 64 | <> "expects a '.jenga' file in the same directory as the 'stack.yaml' file.") 65 | (pure Update) 66 | , subCommand "parse-stack" 67 | ( "Parse a 'stack.yaml' file and dump out the relevant bits as JSON. This is " 68 | <> "mostly useful for testing and debugging.") 69 | (ParseStack <$> stackFilePathP) 70 | , subCommand "parse-jenga" 71 | ( "Parse the '.jenga' file and dump out the relevant bits as JSON. This is " 72 | <> "mostly useful for testing and debugging.") 73 | (ParseJenga <$> jengaFilePathP) 74 | ] 75 | where 76 | subCommand :: String -> Doc -> Parser a -> Mod CommandFields a 77 | subCommand label description parser = 78 | O.command label (O.info (parser <**> helper) (O.progDescDoc $ Just description)) 79 | 80 | jengaConfigP :: Parser JengaConfig 81 | jengaConfigP = 82 | JengaConfig <$> subModulesDirP <*> lockFormatP <*> dropDepsP <*> pure [] 83 | 84 | subModulesDirP :: Parser ModulesDirPath 85 | subModulesDirP = 86 | fmap (ModulesDirPath . fromMaybe "lib") <$> O.optional $ strOption 87 | ( short 'm' 88 | <> long "modules" 89 | <> metavar "MODULES_DIRECTORY" 90 | <> help "The optional directory in which to put git submodules (defaults to '/lib/')." 91 | ) 92 | 93 | dropDepsP :: Parser [Text] 94 | dropDepsP = 95 | fmap (maybe [] (Text.split (== ',') . Text.pack)) <$> O.optional $ strOption 96 | ( short 'd' 97 | <> long "drop-deps" 98 | <> metavar "DROP_DEPENDENCIES" 99 | <> help "Comma separated list of dependencies to drop from the lock/freeze file. These will be saved to the '.jenga' file." 100 | ) 101 | 102 | lockFormatP :: Parser LockFormat 103 | lockFormatP = O.flag MafiaLock CabalFreeze 104 | ( short 'f' 105 | <> long "cabal-freeze" 106 | <> help "Generate cabal freeze file (cabal.config) instead of mafia lock file." 107 | ) 108 | 109 | stackFilePathP :: Parser StackFilePath 110 | stackFilePathP = 111 | fmap (StackFilePath . fromMaybe "stack.yaml") <$> O.optional $ strOption 112 | ( short 's' 113 | <> long "stack-file" 114 | <> metavar "STACK_FILE" 115 | <> help "The 'stack.yaml' file. (defaults to './stack.yaml')." 116 | ) 117 | 118 | jengaFilePathP :: Parser FilePath 119 | jengaFilePathP = 120 | fmap (fromMaybe ".jenga") <$> O.optional $ strOption 121 | ( short 'j' 122 | <> long "jenga-file" 123 | <> metavar "JENGA_FILE" 124 | <> help "The '.jenga' file. (defaults to './.jenga')." 125 | ) 126 | 127 | -- ----------------------------------------------------------------------------- 128 | 129 | commandHandler :: Command -> IO () 130 | commandHandler cmd = 131 | orDie renderJengaError $ 132 | case cmd of 133 | Initialize cfg mscfg -> initialize cfg mscfg 134 | Update -> update 135 | ParseStack scfg -> dumpStackToJSON scfg 136 | ParseJenga jcfg -> dumpJengaToJSON jcfg 137 | 138 | initialize :: JengaConfig -> Maybe StackFilePath -> EitherT JengaError IO () 139 | initialize jcfg mscfg = do 140 | scfg <- readStackConfig $ fromMaybe (StackFilePath "stack.yaml") mscfg 141 | ejcfg <- liftIO $ runEitherT readJengaConfig 142 | case ejcfg of 143 | Left JengaConfigMissing -> do 144 | runSetup scfg jcfg 145 | Left err -> 146 | left err 147 | Right _ -> do 148 | liftIO $ Text.putStrLn "Found existing Jenga config file and using that." 149 | runUpdate scfg jcfg 150 | 151 | update :: EitherT JengaError IO () 152 | update = do 153 | scfg <- readStackConfig (StackFilePath "stack.yaml") 154 | jcfg <- readJengaConfig 155 | runUpdate scfg jcfg 156 | 157 | runUpdate :: StackConfig -> JengaConfig -> EitherT JengaError IO () 158 | runUpdate scfg jcfg = do 159 | runSetup scfg jcfg 160 | let (newConfig, oldSubmods) = mergeGitSubmodules jcfg $ stackGitRepos scfg 161 | forM_ oldSubmods $ \ sm -> gitRemove (jsmPath sm) 162 | writeJengaConfig newConfig 163 | 164 | runSetup :: StackConfig -> JengaConfig -> EitherT JengaError IO () 165 | runSetup scfg jcfg = do 166 | checkModulesDirPath (jcModulesDirPath jcfg) 167 | cfiles <- findProjectCabalFiles (StackFilePath "stack.yaml") (jcModulesDirPath jcfg) 168 | setupGitSubmodules (jcModulesDirPath jcfg) $ stackGitRepos scfg 169 | deps <- List.nub . fmap dependencyName <$> concatMapM readPackageDependencies cfiles 170 | plist <- getStackageResolverPkgList scfg 171 | subMods <- findSubmodules 172 | let pkgs = mergePackages (processPackageList deps plist) (stackExtraDeps scfg) subMods (jcDropDeps jcfg) 173 | liftIO . Text.hPutStrLn stderr $ "GHC version: " <> ghcVersion plist 174 | forM_ cfiles $ \ cabalpath -> do 175 | writeLockFile (toLockPath (jcMafiaLock jcfg) cabalpath $ ghcVersion plist) pkgs 176 | writeJengaConfig $ fst (mergeGitSubmodules jcfg $ stackGitRepos scfg) 177 | 178 | dumpStackToJSON :: StackFilePath -> EitherT JengaError IO () 179 | dumpStackToJSON stackFile = do 180 | scfg <- readStackConfig stackFile 181 | liftIO . BS.putStrLn $ renderStackConfig scfg 182 | 183 | dumpJengaToJSON :: FilePath -> EitherT JengaError IO () 184 | dumpJengaToJSON file = do 185 | jcfg <- readJengaConfigFrom file 186 | liftIO . BS.putStrLn $ renderJengaConfig jcfg 187 | 188 | -- ----------------------------------------------------------------------------- 189 | 190 | checkModulesDirPath :: ModulesDirPath -> EitherT JengaError IO () 191 | checkModulesDirPath (ModulesDirPath modsDir) = do 192 | noFiles <- List.null <$> liftIO (listFiles modsDir) 193 | unless noFiles $ 194 | left $ JengaSubmodFules modsDir 195 | 196 | -- Find cabal files belong to this project, which specifically means 197 | -- not cabal files in git submodules, or in a cabal sandbox or the 198 | -- new style sandboxes. 199 | findProjectCabalFiles :: StackFilePath -> ModulesDirPath -> EitherT JengaError IO [CabalFilePath] 200 | findProjectCabalFiles (StackFilePath stackFile) (ModulesDirPath modsDir) = 201 | fmap CabalFilePath . filter predicate <$> listDirectoryRecursive (takeDirectory stackFile) 202 | where 203 | predicate f = 204 | isCabalFile f 205 | && not (("." modsDir) `List.isPrefixOf` f) 206 | && not (".cabal-sandbox/" `List.isInfixOf` f) 207 | && not ("dist-newstyle/" `List.isInfixOf` f) 208 | 209 | -- ----------------------------------------------------------------------------- 210 | 211 | processPackageList :: [Text] -> PackageList -> [Package] 212 | processPackageList deps plist = do 213 | map snd . snd $ partitionEithers $ lookupPackages plist deps 214 | -------------------------------------------------------------------------------- /src/Jenga.hs: -------------------------------------------------------------------------------- 1 | module Jenga 2 | ( module X 3 | ) where 4 | 5 | import Jenga.Cabal as X 6 | import Jenga.Config as X 7 | import Jenga.PackageList as X 8 | import Jenga.Git as X 9 | import Jenga.Git.Command as X 10 | import Jenga.Git.Process as X 11 | import Jenga.Git.SubModules as X 12 | import Jenga.HTTP as X 13 | import Jenga.IO as X 14 | import Jenga.Merge as X 15 | import Jenga.Render as X 16 | import Jenga.Stack as X 17 | import Jenga.Types as X 18 | -------------------------------------------------------------------------------- /src/Jenga/Cabal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Jenga.Cabal 3 | ( CabalFilePath (..) 4 | , dependencyName 5 | , readPackageDependencies 6 | , readPackageFromCabalFile 7 | ) where 8 | 9 | -- You would think that since the Cabal file exposes its cabal parser you would 10 | -- think it would be a simple matter to extract the list of dependencies. 11 | -- Unfortunately its much more work than it should be. See: 12 | -- https://hackage.haskell.org/package/Cabal-1.24.2.0/docs/Distribution-PackageDescription.html#v:buildDepends 13 | 14 | import Control.Monad.Trans.Either (EitherT, handleIOEitherT) 15 | 16 | import qualified Data.Map.Strict as Map 17 | import Data.Text (Text) 18 | import qualified Data.Text as Text 19 | 20 | import Distribution.Package (Dependency (..), PackageIdentifier (..), unPackageName) 21 | import Distribution.PackageDescription 22 | ( Benchmark, CondTree (..), ConfVar, Executable, GenericPackageDescription (..) 23 | , PackageDescription (..), Library, TestSuite 24 | ) 25 | import Distribution.PackageDescription.Parsec (readGenericPackageDescription) 26 | import Distribution.Verbosity (normal) 27 | 28 | import Jenga.Types 29 | 30 | 31 | newtype CabalFilePath = CabalFilePath FilePath 32 | 33 | 34 | readPackageDependencies :: CabalFilePath -> EitherT JengaError IO [Dependency] 35 | readPackageDependencies (CabalFilePath fpath) = do 36 | handleIOEitherT (JengaIOError "readPackageDependencies" fpath) $ do 37 | genpkg <- readGenericPackageDescription normal fpath 38 | pure 39 | . sortNubByName 40 | . filterPackageName (package $ packageDescription genpkg) 41 | $ extractLibraryDeps (condLibrary genpkg) 42 | ++ extractExecutableDeps (condExecutables genpkg) 43 | ++ extractTestSuiteDeps (condTestSuites genpkg) 44 | ++ extractBenchmarkDeps (condBenchmarks genpkg) 45 | 46 | 47 | readPackageFromCabalFile :: CabalFilePath -> EitherT JengaError IO Package 48 | readPackageFromCabalFile (CabalFilePath fpath) = 49 | handleIOEitherT (JengaIOError "readPackageFromCabalFile" fpath) $ do 50 | pkgId <- package . packageDescription <$> readGenericPackageDescription normal fpath 51 | pure $ Package (Text.pack . unPackageName $ pkgName pkgId) (pkgVersion pkgId) 52 | 53 | 54 | -- ----------------------------------------------------------------------------- 55 | 56 | sortNubByName :: [Dependency] -> [Dependency] 57 | sortNubByName = fmap toDep . Map.toList . Map.fromList . fmap fromDep 58 | where 59 | fromDep (Dependency n v) = (n, v) 60 | toDep (n, v) = Dependency n v 61 | 62 | filterPackageName :: PackageIdentifier -> [Dependency] -> [Dependency] 63 | filterPackageName (PackageIdentifier pname _) = 64 | filter (\dep -> pname /= pName dep ) 65 | where 66 | pName (Dependency pn _) = pn 67 | 68 | dependencyName :: Dependency -> Text 69 | dependencyName (Dependency name _) = Text.pack $ unPackageName name 70 | 71 | 72 | extractLibraryDeps :: Maybe (CondTree ConfVar [Dependency] Library) -> [Dependency] 73 | extractLibraryDeps Nothing = [] 74 | extractLibraryDeps (Just x) = condTreeConstraints x 75 | 76 | extractExecutableDeps :: [(a, CondTree ConfVar [Dependency] Executable)] -> [Dependency] 77 | extractExecutableDeps = concatMap (condTreeConstraints . snd) 78 | 79 | extractTestSuiteDeps :: [(a, CondTree ConfVar [Dependency] TestSuite)] -> [Dependency] 80 | extractTestSuiteDeps = concatMap (condTreeConstraints . snd) 81 | 82 | extractBenchmarkDeps :: [(a, CondTree ConfVar [Dependency] Benchmark)] -> [Dependency] 83 | extractBenchmarkDeps = concatMap (condTreeConstraints . snd) 84 | -------------------------------------------------------------------------------- /src/Jenga/Config.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Jenga.Config 3 | ( JengaConfig (..) 4 | , ModulesDirPath (..) 5 | , JengaSubmodule (..) 6 | , readJengaConfig 7 | , readJengaConfigFrom 8 | , mergeGitSubmodules 9 | , parseJengaConfig 10 | , renderJengaConfig 11 | , writeJengaConfig 12 | ) where 13 | 14 | import Control.Monad.Trans.Either (EitherT, handleIOEitherT, hoistEither) 15 | 16 | import Data.Aeson (ToJSON (..), (.=)) 17 | import qualified Data.Aeson as Aeson 18 | import qualified Data.Aeson.Encode.Pretty as Aeson 19 | import Data.ByteString (ByteString) 20 | import qualified Data.ByteString as BS 21 | import qualified Data.ByteString.Lazy as LBS 22 | import qualified Data.List as List 23 | import Data.Text (Text) 24 | import qualified Data.Text as Text 25 | import Data.YAML (FromYAML(..), Node (..), Parser, Scalar (..), (.:), (.:?)) 26 | import qualified Data.YAML as Yaml 27 | 28 | import Jenga.Stack 29 | import Jenga.Types 30 | 31 | import System.FilePath (()) 32 | import System.IO.Error (isDoesNotExistError) 33 | 34 | 35 | newtype ModulesDirPath 36 | = ModulesDirPath { unModulesDirPath :: FilePath } 37 | deriving (Eq, Show) 38 | 39 | data JengaConfig = JengaConfig 40 | { jcModulesDirPath :: !ModulesDirPath 41 | , jcMafiaLock :: !LockFormat 42 | , jcDropDeps :: ![Text] 43 | , jcSubmodules :: ![JengaSubmodule] 44 | } 45 | deriving (Eq, Show) 46 | 47 | data JengaSubmodule = JengaSubmodule 48 | { jsmUrl :: !Text 49 | , jsmPath :: !FilePath 50 | , jsmHash :: Text 51 | } 52 | deriving (Eq, Show) 53 | 54 | instance FromYAML JengaConfig where 55 | parseYAML = Yaml.withMap "JengaConfig" $ \o -> 56 | JengaConfig 57 | <$> o .: "submodule-dir" 58 | <*> ((o .: "mafia-lock") >>= toLockFormat) 59 | <*> ((o .: "drop-deps") >>= parseDropDeps) 60 | <*> (maybe (pure []) parseSubmodules =<< (o .:? "submodules")) 61 | 62 | instance FromYAML ModulesDirPath where 63 | parseYAML = Yaml.withStr "ModulesDirPath" (pure . ModulesDirPath . Text.unpack) 64 | 65 | toLockFormat :: Bool -> Parser LockFormat 66 | toLockFormat b = 67 | pure $ if b then MafiaLock else CabalFreeze 68 | 69 | instance ToJSON JengaConfig where 70 | toJSON cfg = 71 | Aeson.object 72 | [ "submodule-dir" .= unModulesDirPath (jcModulesDirPath cfg) 73 | , "mafia-lock" .= (jcMafiaLock cfg == MafiaLock) 74 | , "drop-deps" .= jcDropDeps cfg 75 | , "submodules" .= jcSubmodules cfg 76 | ] 77 | 78 | instance ToJSON JengaSubmodule where 79 | toJSON jsm = 80 | Aeson.object 81 | [ "url" .= jsmUrl jsm 82 | , "path" .= Text.pack (jsmPath jsm) 83 | , "hash" .= jsmHash jsm 84 | ] 85 | 86 | parseDropDeps :: Node -> Parser [Text] 87 | parseDropDeps = 88 | Yaml.withSeq "parseDropDeps" $ \a -> 89 | mapM parseDropDep a 90 | where 91 | parseDropDep :: Node -> Parser Text 92 | parseDropDep (Scalar (SStr s)) = pure s 93 | parseDropDep invalid = Yaml.typeMismatch "parseDropDep" invalid 94 | 95 | parseSubmodules :: Node -> Parser [JengaSubmodule] 96 | parseSubmodules = 97 | Yaml.withSeq "parseSubmodules" $ \a -> 98 | mapM parseSubMod a 99 | where 100 | parseSubMod = 101 | Yaml.withMap "JengaSubmodule" $ \o -> 102 | JengaSubmodule 103 | <$> o .: "url" 104 | <*> fmap Text.unpack (o .: "path") 105 | <*> o .: "hash" 106 | 107 | parseJengaConfig :: ByteString -> Either JengaError JengaConfig 108 | parseJengaConfig bs = 109 | case Yaml.decodeStrict bs of 110 | Right [cfg] -> Right cfg 111 | Right [] -> Left $ JengaConfigError "empty configuration" 112 | Right (_:_:_) -> Left $ JengaConfigError "multiple documents in configuration" 113 | Left s -> Left $ JengaConfigError (Text.pack s) 114 | 115 | renderJengaConfig :: JengaConfig -> ByteString 116 | renderJengaConfig cfg = 117 | LBS.toStrict $ LBS.append (Aeson.encodePretty cfg) "\n" -- Yaml.encode 118 | 119 | readJengaConfig :: EitherT JengaError IO JengaConfig 120 | readJengaConfig = 121 | readJengaConfigFrom configFilePath 122 | 123 | -- Mainly for debugging and testing. 124 | readJengaConfigFrom :: FilePath -> EitherT JengaError IO JengaConfig 125 | readJengaConfigFrom path = do 126 | bs <- handleIOEitherT handler $ BS.readFile path 127 | hoistEither $ parseJengaConfig bs 128 | where 129 | handler err 130 | | isDoesNotExistError err = JengaConfigMissing 131 | | otherwise = JengaConfigError $ Text.pack (show err) 132 | 133 | 134 | writeJengaConfig :: JengaConfig -> EitherT JengaError IO () 135 | writeJengaConfig cfg = 136 | handleIOEitherT handler $ BS.writeFile configFilePath (renderJengaConfig cfg) 137 | where 138 | handler = 139 | JengaIOError "writeJengaConfig" configFilePath 140 | 141 | 142 | configFilePath :: FilePath 143 | configFilePath = ".jenga" 144 | 145 | 146 | mergeGitSubmodules :: JengaConfig -> [StackGitRepo] -> (JengaConfig, [JengaSubmodule]) 147 | mergeGitSubmodules jc sgrs = 148 | (newConfig, deleteSubmodules) 149 | where 150 | newConfig :: JengaConfig 151 | newConfig = jc { jcSubmodules = newSubmodules } 152 | 153 | convert :: StackGitRepo -> JengaSubmodule 154 | convert sgr = 155 | JengaSubmodule 156 | (sgrUrl sgr) 157 | (unModulesDirPath (jcModulesDirPath jc) Text.unpack (sgrName sgr)) 158 | (sgrCommit sgr) 159 | 160 | oldSubmodules, newSubmodules, deleteSubmodules :: [JengaSubmodule] 161 | oldSubmodules = jcSubmodules jc 162 | newSubmodules = map convert sgrs 163 | deleteSubmodules = 164 | filter (\ osm -> jsmPath osm `List.notElem` map jsmPath newSubmodules) oldSubmodules 165 | -------------------------------------------------------------------------------- /src/Jenga/Git.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Jenga.Git 4 | ( setupGitSubmodules 5 | ) where 6 | 7 | import Control.Monad.IO.Class (liftIO) 8 | import Control.Monad.Trans.Either (EitherT, handleIOEitherT) 9 | 10 | import qualified Data.Text as Text 11 | 12 | import Jenga.Config 13 | import Jenga.Git.Command 14 | import Jenga.Stack 15 | import Jenga.Types 16 | 17 | import System.Directory (createDirectoryIfMissing, doesDirectoryExist) 18 | import System.FilePath (()) 19 | 20 | 21 | setupGitSubmodules :: ModulesDirPath -> [StackGitRepo] -> EitherT JengaError IO () 22 | setupGitSubmodules smp = 23 | mapM_ (setupSubmodule smp) 24 | 25 | 26 | setupSubmodule :: ModulesDirPath -> StackGitRepo -> EitherT JengaError IO () 27 | setupSubmodule smp gitrepo = do 28 | handleIOEitherT (JengaIOError "setupSubmodule" (unModulesDirPath smp)) $ do 29 | createDirectoryIfMissing False $ unModulesDirPath smp 30 | let dir = buildSubmoduleDir smp gitrepo 31 | exists <- liftIO $ doesDirectoryExist dir 32 | if exists 33 | then updateSubmodule dir gitrepo 34 | else addSubmodule dir gitrepo 35 | 36 | 37 | buildSubmoduleDir :: ModulesDirPath -> StackGitRepo -> FilePath 38 | buildSubmoduleDir (ModulesDirPath smp) gitrepo = 39 | smp Text.unpack (sgrName gitrepo) 40 | 41 | updateSubmodule :: FilePath -> StackGitRepo -> EitherT JengaError IO () 42 | updateSubmodule dir gitrepo = do 43 | liftIO . putStrLn $ "Updating submodule '" ++ dir ++ "' to commit " ++ Text.unpack (Text.take 10 $ sgrCommit gitrepo) 44 | gitUpdate dir 45 | gitCheckoutCommit dir $ Text.unpack (sgrCommit gitrepo) 46 | 47 | addSubmodule :: FilePath -> StackGitRepo -> EitherT JengaError IO () 48 | addSubmodule dir gitrepo = do 49 | liftIO . putStrLn $ "Adding submodule '" ++ dir ++ "' at commit " ++ Text.unpack (Text.take 10 $ sgrCommit gitrepo) 50 | gitAddSubmodule dir $ Text.unpack (sgrUrl gitrepo) 51 | gitCheckoutCommit dir $ Text.unpack (sgrCommit gitrepo) 52 | -------------------------------------------------------------------------------- /src/Jenga/Git/Command.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Jenga.Git.Command 4 | ( gitAddSubmodule 5 | , gitCheckoutCommit 6 | , gitHeadHash 7 | , gitRemove 8 | , gitUpdate 9 | ) where 10 | 11 | import Control.Monad.Trans.Either (EitherT) 12 | 13 | import Data.Text (Text) 14 | 15 | import Jenga.Git.Process 16 | import Jenga.Types 17 | 18 | 19 | gitAddSubmodule :: FilePath -> String -> EitherT JengaError IO () 20 | gitAddSubmodule dest repo = 21 | gitHush ["submodule", "add", "--force", repo, dest] 22 | 23 | gitCheckoutCommit :: FilePath -> String -> EitherT JengaError IO () 24 | gitCheckoutCommit dir hash = 25 | gitHush ["-C", dir, "checkout", hash] 26 | 27 | gitUpdate :: FilePath -> EitherT JengaError IO () 28 | gitUpdate dir = do 29 | gitHush ["-C", dir, "fetch"] 30 | gitHush ["-C", dir, "submodule", "update"] 31 | 32 | gitHeadHash :: FilePath -> EitherT JengaError IO Text 33 | gitHeadHash dir = 34 | gitOut ["-C", dir, "rev-parse", "HEAD"] 35 | 36 | gitRemove :: FilePath -> EitherT JengaError IO () 37 | gitRemove path = 38 | gitHush ["rm", path] 39 | 40 | -- ----------------------------------------------------------------------------- 41 | 42 | gitHush :: [Argument] -> EitherT JengaError IO () 43 | gitHush args = do 44 | Hush <- call (JengaGitError . renderProcessError) "git" args 45 | pure () 46 | 47 | gitOut :: [Argument] -> EitherT JengaError IO Text 48 | gitOut args = 49 | unOut <$> call (JengaGitError . renderProcessError) "git" args 50 | -------------------------------------------------------------------------------- /src/Jenga/Git/Process.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE PatternSynonyms #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | 8 | -- This module was stolen from https://github.com/ambiata/mafia and modified 9 | -- slightly for use in Jenga. 10 | 11 | module Jenga.Git.Process 12 | ( -- * Inputs 13 | File 14 | , Directory 15 | , Argument 16 | , EnvKey 17 | , EnvValue 18 | , Process(..) 19 | 20 | -- * Outputs 21 | , Pass(..) 22 | , PassErr(..) 23 | , PassErrAnnihilate(..) 24 | , Clean(..) 25 | , Hush(..) 26 | , Out(..) 27 | , Err(..) 28 | , OutErr(..) 29 | , OutErrCode(..) 30 | , renderOutErrCode 31 | 32 | -- * Errors 33 | , ProcessError(..) 34 | , ExitStatus 35 | , ExitCode(..) 36 | , renderProcessError 37 | 38 | -- * Running Processes 39 | , ProcessResult(..) 40 | , call 41 | , call_ 42 | , callFrom 43 | , callFrom_ 44 | , capture 45 | , exec 46 | , execFrom 47 | 48 | -- * Internal (exported for testing) 49 | , cleanLines 50 | ) where 51 | 52 | import Control.Concurrent.Async (Async, async, waitCatch) 53 | import Control.Exception (SomeException, IOException, toException) 54 | import Control.Monad.Catch (MonadCatch(..), handle, bracket_) 55 | import Control.Monad.IO.Class (MonadIO(..)) 56 | import Control.Monad.Trans.Either (EitherT, firstEitherT, hoistEither, left, newEitherT) 57 | 58 | import Data.ByteString (ByteString) 59 | import qualified Data.ByteString.Char8 as BS 60 | import qualified Data.List as List 61 | import Data.Map (Map) 62 | import qualified Data.Map as Map 63 | import Data.Maybe (fromMaybe) 64 | import Data.Monoid ((<>)) 65 | import Data.Text (Text) 66 | import qualified Data.Text as Text 67 | import qualified Data.Text.Encoding as Text 68 | 69 | import System.Directory (setCurrentDirectory) 70 | import System.Exit (ExitCode(..)) 71 | import System.IO (Handle, BufferMode(..)) 72 | import qualified System.IO as IO 73 | import qualified System.Process as Process 74 | import qualified System.Process.Internals as ProcessInternals 75 | import qualified System.Posix.Types as Posix 76 | import qualified System.Posix.Process as Posix 77 | import qualified System.Posix.Signals as Signals 78 | 79 | 80 | 81 | type File = FilePath 82 | type Directory = FilePath 83 | 84 | type Argument = String 85 | type EnvKey = String 86 | type EnvValue = String 87 | 88 | data Process = Process 89 | { processCommand :: File 90 | , processArguments :: [Argument] 91 | , processDirectory :: Maybe Directory 92 | , processEnvironment :: Maybe (Map EnvKey EnvValue) 93 | } deriving (Eq, Ord, Show) 94 | 95 | ------------------------------------------------------------------------ 96 | 97 | -- | Pass @stdout@ and @stderr@ through to the console. 98 | data Pass = 99 | Pass 100 | deriving (Eq, Ord, Show) 101 | 102 | -- | Pass @stdout@ and @stderr@ through to the console, but redirect @stdout@ > @stderr. 103 | data PassErr = 104 | PassErr 105 | deriving (Eq, Ord, Show) 106 | 107 | -- | Pass @stdout@ and @stderr@ through to the console, but redirect @stdout@ > @stderr; also kill *everything* on Ctrl-C. 108 | data PassErrAnnihilate = 109 | PassErrAnnihilate 110 | deriving (Eq, Ord, Show) 111 | 112 | -- | Pass @stdout@ and @stderr@ through to the console, but process control 113 | -- characters (such as \b, \r) prior to emitting each line of output. 114 | data Clean = 115 | Clean 116 | deriving (Eq, Ord, Show) 117 | 118 | -- | Capture @stdout@ and @stderr@ but ignore them. 119 | data Hush = 120 | Hush 121 | deriving (Eq, Ord, Show) 122 | 123 | -- | Capture @stdout@ and pass @stderr@ through to the console. 124 | newtype Out a = 125 | Out { 126 | unOut :: a 127 | } deriving (Eq, Ord, Show, Functor) 128 | 129 | -- | Capture @stderr@ and pass @stdout@ through to the console. 130 | newtype Err a = 131 | Err { 132 | unErr :: a 133 | } deriving (Eq, Ord, Show, Functor) 134 | 135 | -- | Capture both @stdout@ and @stderr@. 136 | data OutErr a = 137 | OutErr !a !a 138 | deriving (Eq, Ord, Show, Functor) 139 | 140 | -- | Capture @stdout@, @stderr@ and the 'ExitCode'. 141 | -- /This never causes a @ProcessFailure@/ 142 | data OutErrCode a = 143 | OutErrCode !a !a !ExitCode 144 | deriving (Eq, Ord, Show, Functor) 145 | 146 | renderOutErrCode :: OutErrCode Text -> Text 147 | renderOutErrCode (OutErrCode out0 err0 exit) = 148 | let 149 | out = 150 | Text.strip out0 151 | 152 | err = 153 | Text.strip err0 154 | 155 | output = 156 | out <> (if Text.null out then "" else "\n") <> 157 | err 158 | in 159 | case exit of 160 | ExitFailure code -> 161 | "Process failed with exit code: " <> Text.pack (show code) <> "\n" <> 162 | output 163 | ExitSuccess -> 164 | "Process finished successfully:\n" <> 165 | output 166 | 167 | ------------------------------------------------------------------------ 168 | 169 | type ExitStatus = 170 | Int 171 | 172 | data ProcessError = 173 | ProcessFailure !Process !ExitStatus 174 | | ProcessException !Process !SomeException 175 | deriving (Show) 176 | 177 | renderProcessError :: ProcessError -> Text 178 | renderProcessError = \case 179 | ProcessFailure p code -> Text.pack $ 180 | "Process failed: " <> List.intercalate " " (processCommand p : processArguments p) <> 181 | " (exit code: " <> show code <> ")" 182 | 183 | ProcessException p ex -> Text.pack $ 184 | "Process failed: " <> List.intercalate " " (processCommand p : processArguments p) <> 185 | "\n" <> show ex 186 | 187 | ------------------------------------------------------------------------ 188 | 189 | createProcess :: MonadIO m => Process.CreateProcess -> m (Maybe Handle, Maybe Handle, Maybe Handle, Process.ProcessHandle) 190 | createProcess = liftIO . Process.createProcess 191 | 192 | -- Spawn a new process, and if we get a ctrl-c, make absolutely sure everything we started is finished. 193 | createProcessAnnihilate :: (MonadIO m, MonadCatch m) => Process.CreateProcess -> m (Maybe Handle, Maybe Handle, Maybe Handle, Process.ProcessHandle) 194 | createProcessAnnihilate cp = do 195 | (a, b, c, ph) <- createProcess cp { Process.create_group = True } 196 | pgid <- tryProcessGroupOfProcessHandle ph 197 | fromMaybe (return ()) (installInterruptHandler <$> pgid) 198 | return (a, b, c, ph) 199 | 200 | tryPosixPidOfProcessHandle :: MonadIO m => Process.ProcessHandle -> m (Maybe Posix.ProcessID) 201 | tryPosixPidOfProcessHandle ph = 202 | liftIO $ ProcessInternals.withProcessHandle ph $ 203 | \case 204 | ProcessInternals.OpenHandle i -> return $ Just i 205 | ProcessInternals.ClosedHandle _ -> return $ Nothing 206 | ProcessInternals.OpenExtHandle _ _ _ -> return Nothing 207 | 208 | tryProcessGroupOfProcessHandle :: (MonadIO m, MonadCatch m) => Process.ProcessHandle -> m (Maybe Posix.ProcessGroupID) 209 | tryProcessGroupOfProcessHandle ph = do 210 | pid <- tryPosixPidOfProcessHandle ph 211 | case pid of 212 | Nothing -> return Nothing 213 | Just h -> handle ignoreIOE $ do 214 | pgid <- liftIO (Posix.getProcessGroupIDOf h) 215 | return $ Just pgid 216 | where 217 | ignoreIOE (_ :: IOException) = return Nothing 218 | 219 | installInterruptHandler :: MonadIO m => Posix.ProcessGroupID -> m () 220 | installInterruptHandler pgid = do 221 | _ <- liftIO $ Signals.installHandler Signals.keyboardSignal (Signals.Catch $ Signals.signalProcessGroup Signals.keyboardTermination pgid) Nothing 222 | return () 223 | 224 | 225 | class ProcessResult a where 226 | callProcess :: (MonadIO m, MonadCatch m) 227 | => Process -> EitherT ProcessError m a 228 | 229 | instance ProcessResult Pass where 230 | callProcess p = withProcess p $ do 231 | let cp = fromProcess p 232 | 233 | (Nothing, Nothing, Nothing, pid) <- createProcess cp 234 | 235 | code <- liftIO (Process.waitForProcess pid) 236 | return (code, Pass) 237 | 238 | instance ProcessResult PassErr where 239 | callProcess p = withProcess p $ do 240 | let cp = (fromProcess p) { Process.std_out = Process.UseHandle IO.stderr } 241 | 242 | (Nothing, Nothing, Nothing, pid) <- createProcess cp 243 | 244 | code <- liftIO (Process.waitForProcess pid) 245 | return (code, PassErr) 246 | 247 | instance ProcessResult PassErrAnnihilate where 248 | callProcess p = withProcess p $ do 249 | let cp = (fromProcess p) { Process.std_out = Process.UseHandle IO.stderr } 250 | 251 | (Nothing, Nothing, Nothing, pid) <- createProcessAnnihilate cp 252 | 253 | code <- liftIO (Process.waitForProcess pid) 254 | return (code, PassErrAnnihilate) 255 | 256 | instance ProcessResult (Out ByteString) where 257 | callProcess p = withProcess p $ do 258 | let cp = (fromProcess p) { Process.std_out = Process.CreatePipe } 259 | 260 | (Nothing, Just hOut, Nothing, pid) <- createProcess cp 261 | 262 | out <- liftIO (BS.hGetContents hOut) 263 | code <- liftIO (Process.waitForProcess pid) 264 | 265 | return (code, Out out) 266 | 267 | instance ProcessResult (Err ByteString) where 268 | callProcess p = withProcess p $ do 269 | let cp = (fromProcess p) { Process.std_err = Process.CreatePipe } 270 | 271 | (Nothing, Nothing, Just hErr, pid) <- createProcess cp 272 | 273 | err <- liftIO (BS.hGetContents hErr) 274 | code <- liftIO (Process.waitForProcess pid) 275 | 276 | return (code, Err err) 277 | 278 | instance ProcessResult (OutErr ByteString) where 279 | callProcess p = withProcess p $ do 280 | let cp = (fromProcess p) { Process.std_out = Process.CreatePipe 281 | , Process.std_err = Process.CreatePipe } 282 | 283 | (Nothing, Just hOut, Just hErr, pid) <- createProcess cp 284 | 285 | asyncOut <- liftIO (async (BS.hGetContents hOut)) 286 | asyncErr <- liftIO (async (BS.hGetContents hErr)) 287 | 288 | out <- waitCatchE p asyncOut 289 | err <- waitCatchE p asyncErr 290 | code <- liftIO (Process.waitForProcess pid) 291 | 292 | return (code, OutErr out err) 293 | 294 | instance ProcessResult (OutErrCode ByteString) where 295 | callProcess p = withProcess p $ do 296 | let cp = (fromProcess p) { Process.std_out = Process.CreatePipe 297 | , Process.std_err = Process.CreatePipe } 298 | 299 | (Nothing, Just hOut, Just hErr, pid) <- createProcess cp 300 | 301 | asyncOut <- liftIO (async (BS.hGetContents hOut)) 302 | asyncErr <- liftIO (async (BS.hGetContents hErr)) 303 | 304 | out <- waitCatchE p asyncOut 305 | err <- waitCatchE p asyncErr 306 | code <- liftIO (Process.waitForProcess pid) 307 | 308 | return (ExitSuccess, OutErrCode out err code) 309 | 310 | instance ProcessResult Hush where 311 | callProcess p = do 312 | OutErr (_ :: ByteString) (_ :: ByteString) <- callProcess p 313 | return Hush 314 | 315 | instance ProcessResult Clean where 316 | callProcess p = withProcess p $ do 317 | let cp = (fromProcess p) { Process.std_out = Process.CreatePipe 318 | , Process.std_err = Process.CreatePipe } 319 | 320 | (Nothing, Just hOut, Just hErr, pid) <- createProcess cp 321 | 322 | asyncOut <- liftIO (async (clean hOut IO.stdout)) 323 | asyncErr <- liftIO (async (clean hErr IO.stderr)) 324 | 325 | () <- waitCatchE p asyncOut 326 | () <- waitCatchE p asyncErr 327 | code <- liftIO (Process.waitForProcess pid) 328 | 329 | return (code, Clean) 330 | 331 | instance ProcessResult (Out Text) where 332 | callProcess p = fmap Text.decodeUtf8 <$> callProcess p 333 | 334 | instance ProcessResult (Err Text) where 335 | callProcess p = fmap Text.decodeUtf8 <$> callProcess p 336 | 337 | instance ProcessResult (OutErr Text) where 338 | callProcess p = fmap Text.decodeUtf8 <$> callProcess p 339 | 340 | instance ProcessResult (OutErrCode Text) where 341 | callProcess p = fmap Text.decodeUtf8 <$> callProcess p 342 | 343 | ------------------------------------------------------------------------ 344 | 345 | -- | Call a command with arguments. 346 | -- 347 | call :: (ProcessResult a, MonadIO m, MonadCatch m) 348 | => (ProcessError -> e) 349 | -> File 350 | -> [Argument] 351 | -> EitherT e m a 352 | 353 | call up cmd args = firstEitherT up (callProcess process) 354 | where 355 | process = Process { processCommand = cmd 356 | , processArguments = args 357 | , processDirectory = Nothing 358 | , processEnvironment = Nothing } 359 | 360 | -- | Call a command with arguments, passing the output through to stdout/stderr. 361 | -- 362 | call_ :: (MonadIO m, MonadCatch m) 363 | => (ProcessError -> e) 364 | -> File 365 | -> [Argument] 366 | -> EitherT e m () 367 | 368 | call_ up cmd args = do 369 | Pass <- call up cmd args 370 | return () 371 | 372 | -- | Call a command with arguments from inside a working directory. 373 | -- 374 | callFrom :: (ProcessResult a, MonadIO m, MonadCatch m) 375 | => (ProcessError -> e) 376 | -> Directory 377 | -> File 378 | -> [Argument] 379 | -> EitherT e m a 380 | 381 | callFrom up dir cmd args = firstEitherT up (callProcess process) 382 | where 383 | process = Process { processCommand = cmd 384 | , processArguments = args 385 | , processDirectory = Just dir 386 | , processEnvironment = Nothing } 387 | 388 | -- | Call a command with arguments from inside a working directory. 389 | -- 390 | callFrom_ :: (MonadIO m, MonadCatch m) 391 | => (ProcessError -> e) 392 | -> Directory 393 | -> File 394 | -> [Argument] 395 | -> EitherT e m () 396 | 397 | callFrom_ up dir cmd args = do 398 | Pass <- callFrom up dir cmd args 399 | return () 400 | 401 | -- | Capture the output of a process when it fails. 402 | -- 403 | capture :: 404 | (OutErrCode Text -> x) -> 405 | EitherT x IO (OutErrCode Text) -> 406 | EitherT x IO () 407 | capture fromOutput p = do 408 | output@(OutErrCode _ _ code) <- p 409 | case code of 410 | ExitFailure _ -> 411 | left $ fromOutput output 412 | ExitSuccess -> 413 | pure () 414 | 415 | ------------------------------------------------------------------------ 416 | 417 | -- | Execute a process, this call never returns. 418 | -- 419 | execProcess :: (MonadIO m, MonadCatch m) => Process -> EitherT ProcessError m a 420 | execProcess p = handleIO p $ do 421 | case processDirectory p of 422 | Nothing -> return () 423 | Just dir -> liftIO $ setCurrentDirectory dir 424 | liftIO (Posix.executeFile cmd True args env) 425 | where 426 | (cmd, args, _, env) = fromProcess' p 427 | 428 | -- | Execute a command with arguments, this call never returns. 429 | -- 430 | exec :: (MonadIO m, MonadCatch m) 431 | => (ProcessError -> e) 432 | -> File 433 | -> [Argument] 434 | -> EitherT e m a 435 | 436 | exec up cmd args = firstEitherT up (execProcess process) 437 | where 438 | process = Process { processCommand = cmd 439 | , processArguments = args 440 | , processDirectory = Nothing 441 | , processEnvironment = Nothing } 442 | 443 | -- | Execute a command with arguments, this call never returns. 444 | -- 445 | execFrom :: (MonadIO m, MonadCatch m) 446 | => (ProcessError -> e) 447 | -> Directory 448 | -> File 449 | -> [Argument] 450 | -> EitherT e m a 451 | 452 | execFrom up dir cmd args = firstEitherT up (execProcess process) 453 | where 454 | process = Process { processCommand = cmd 455 | , processArguments = args 456 | , processDirectory = Just dir 457 | , processEnvironment = Nothing } 458 | 459 | ------------------------------------------------------------------------ 460 | 461 | withProcess :: (MonadIO m, MonadCatch m) 462 | => Process 463 | -> EitherT ProcessError m (ExitCode, a) 464 | -> EitherT ProcessError m a 465 | 466 | withProcess p io = handleIO p $ do 467 | (code, result) <- io 468 | case code of 469 | ExitSuccess -> return result 470 | ExitFailure x -> hoistEither (Left (ProcessFailure p x)) 471 | 472 | fromProcess :: Process -> Process.CreateProcess 473 | fromProcess p = Process.CreateProcess 474 | { Process.cmdspec = Process.RawCommand cmd args 475 | , Process.cwd = cwd 476 | , Process.env = env 477 | , Process.std_in = Process.Inherit 478 | , Process.std_out = Process.Inherit 479 | , Process.std_err = Process.Inherit 480 | , Process.close_fds = False 481 | , Process.create_group = False 482 | , Process.delegate_ctlc = False 483 | , Process.detach_console = False 484 | , Process.create_new_console = False 485 | , Process.new_session = False 486 | , Process.child_group = Nothing 487 | , Process.child_user = Nothing 488 | , Process.use_process_jobs = False 489 | } 490 | where 491 | (cmd, args, cwd, env) = fromProcess' p 492 | 493 | fromProcess' :: Process -> (FilePath, [String], Maybe FilePath, Maybe [(String, String)]) 494 | fromProcess' p = (cmd, args, cwd, env) 495 | where 496 | cmd = processCommand p 497 | args = processArguments p 498 | cwd = processDirectory p 499 | 500 | env = fmap Map.toList (processEnvironment p) 501 | 502 | ------------------------------------------------------------------------ 503 | 504 | handleIO :: MonadCatch m => Process -> EitherT ProcessError m a -> EitherT ProcessError m a 505 | handleIO p = 506 | let fromIO = toException :: IOException -> SomeException 507 | in handle (hoistEither . Left . ProcessException p . fromIO) 508 | 509 | waitCatchE :: MonadIO m => Process -> Async a -> EitherT ProcessError m a 510 | waitCatchE p = firstEitherT (ProcessException p) . newEitherT . liftIO . waitCatch 511 | 512 | ------------------------------------------------------------------------ 513 | 514 | clean :: Handle -> Handle -> IO () 515 | clean input output = do 516 | ibuf <- IO.hGetBuffering input 517 | obuf <- IO.hGetBuffering output 518 | 519 | let setLineBuffering = do 520 | IO.hSetBuffering input LineBuffering 521 | IO.hSetBuffering output LineBuffering 522 | 523 | ignoreIOE (_ :: IOException) = return () 524 | 525 | -- the handles may be closed by the time we 526 | -- try to reset the buffer mode, so we need 527 | -- to catch exceptions 528 | resetBuffering = do 529 | handle ignoreIOE (IO.hSetBuffering input ibuf) 530 | handle ignoreIOE (IO.hSetBuffering output obuf) 531 | 532 | bracket_ setLineBuffering resetBuffering $ do 533 | xs <- IO.hGetContents input 534 | IO.hPutStr output (cleanLines [] xs) 535 | 536 | 537 | cleanLines :: [Char] -- ^ current line 538 | -> [Char] -- ^ input 539 | -> [Char] -- ^ output 540 | 541 | -- backspace - delete previous character 542 | cleanLines (_ : line) ('\b' : xs) = cleanLines line xs 543 | cleanLines [] ('\b' : xs) = cleanLines [] xs 544 | 545 | -- carriage return - delete the whole line 546 | cleanLines _ ('\r' : xs) = cleanLines [] xs 547 | 548 | -- line feed - emit the current line 549 | cleanLines line ('\n' : xs) = reverse ('\n' : line) <> cleanLines [] xs 550 | 551 | -- normal character - add to current line 552 | cleanLines line (x : xs) = cleanLines (x : line) xs 553 | 554 | -- end of stream - emit the current line 555 | cleanLines line [] = line 556 | -------------------------------------------------------------------------------- /src/Jenga/Git/SubModules.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Jenga.Git.SubModules 3 | ( GitSubmodule (..) 4 | , findSubmodules 5 | , isCabalFile 6 | ) where 7 | 8 | import Control.Monad (forM) 9 | import Control.Monad.Catch (handleIOError) 10 | import Control.Monad.Extra (concatMapM) 11 | import Control.Monad.IO.Class (liftIO) 12 | import Control.Monad.Trans.Either (EitherT, left) 13 | 14 | import Data.Char (isSpace) 15 | import qualified Data.List as List 16 | 17 | import Jenga.Cabal 18 | import Jenga.IO 19 | import Jenga.Types 20 | 21 | import System.Directory (doesDirectoryExist, getCurrentDirectory) 22 | import System.FilePath ((), takeDirectory, takeExtension) 23 | 24 | 25 | data GitSubmodule = GitSubmodule 26 | { smDirectory :: FilePath 27 | , smCabalFile :: CabalFilePath 28 | , smPackage :: Package 29 | } 30 | 31 | 32 | findSubmodules :: EitherT JengaError IO [GitSubmodule] 33 | findSubmodules = do 34 | topdir <- findGitTopLevel 35 | concatMapM mkGitSubmodule =<< liftIO (readSubmodules topdir) 36 | where 37 | mkGitSubmodule dir = do 38 | files <- filter isCabalFile <$> listDirectoryRecursive dir 39 | forM files $ \ x -> do 40 | let cf = CabalFilePath x 41 | GitSubmodule dir cf <$> readPackageFromCabalFile cf 42 | 43 | isCabalFile :: FilePath -> Bool 44 | isCabalFile file = 45 | takeExtension file == ".cabal" 46 | 47 | readSubmodules :: FilePath -> IO [FilePath] 48 | readSubmodules fpath = 49 | handleIOError handler $ do 50 | xs <- lines <$> readFile (fpath ".gitmodules") 51 | pure $ map clean $ filter isPathLine xs 52 | where 53 | isPathLine xs = List.isPrefixOf "path" $ dropWhile isSpace xs 54 | 55 | clean = dropWhile isSpace . drop 1 . dropWhile (/= '=') 56 | 57 | -- This should only be needed if the '.gitmodules' file does not exist. 58 | -- In that case we silently drop the error and return an empty list. 59 | handler :: IOError -> IO [a] 60 | handler _ = pure [] 61 | 62 | 63 | 64 | findGitTopLevel :: EitherT JengaError IO FilePath 65 | findGitTopLevel = 66 | loop =<< liftIO getCurrentDirectory 67 | where 68 | loop "/" = left JengaGitDirMissing 69 | loop cur = do 70 | exists <- liftIO . doesDirectoryExist $ cur ".git" 71 | if exists 72 | then pure cur 73 | else loop (takeDirectory cur) 74 | 75 | 76 | -------------------------------------------------------------------------------- /src/Jenga/HTTP.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | module Jenga.HTTP 4 | ( getStackageResolverPkgList 5 | ) where 6 | 7 | import Control.Monad.Catch (Handler (..)) 8 | import Control.Monad.Trans.Either (EitherT, firstEitherT, handleIOEitherT 9 | , handlesEitherT, hoistEither, left) 10 | 11 | import Data.Aeson (eitherDecode') 12 | import Data.ByteString.Lazy (ByteString) 13 | import qualified Data.Text as Text 14 | 15 | import Jenga.PackageList 16 | import Jenga.Stack 17 | import Jenga.Types 18 | 19 | import Network.HTTP.Simple (HttpException, Request) 20 | import qualified Network.HTTP.Simple as Http 21 | import Network.HTTP.Types.Header (hAccept) 22 | import Network.HTTP.Types.Status (status200) 23 | 24 | 25 | 26 | stackageUrl :: String 27 | stackageUrl = "https://www.stackage.org/" 28 | 29 | 30 | getStackageResolverPkgList :: StackConfig -> EitherT JengaError IO PackageList 31 | getStackageResolverPkgList scfg = do 32 | request <- parseRequestEitherT scfg 33 | body <- runRequest request 34 | firstEitherT JengaJsonError $ hoistEither (eitherDecode' body) 35 | 36 | 37 | runRequest :: Request -> EitherT JengaError IO ByteString 38 | runRequest request = 39 | either left pure =<< handlesEitherT handlers action 40 | where 41 | action = do 42 | response <- Http.httpLbs request 43 | pure $ 44 | if Http.getResponseStatus response /= status200 45 | then Left $ JengaHttpStatus "getStackageResolverPkgList: " (show $ Http.getResponseStatus response) 46 | else Right $ Http.getResponseBody response 47 | 48 | handlers = 49 | [ Handler (pure . JengaHttpIOError) 50 | , Handler (\(e :: HttpException) -> pure $ JengaHttpException (show e)) 51 | ] 52 | 53 | 54 | parseRequestEitherT :: StackConfig -> EitherT JengaError IO Request 55 | parseRequestEitherT scfg = do 56 | fmap modify . handleIOEitherT handler $ Http.parseRequest stackUrl 57 | where 58 | stackUrl = 59 | stackageUrl ++ Text.unpack (stackResolver scfg) 60 | handler = 61 | const . JengaParseUrl $ Text.pack stackUrl 62 | modify req = 63 | Http.setRequestHeader hAccept ["application/json"] req 64 | -------------------------------------------------------------------------------- /src/Jenga/IO.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Jenga.IO 3 | ( listDirectoryRecursive 4 | , listFiles 5 | ) where 6 | 7 | import Control.Monad (filterM) 8 | import Control.Monad.IO.Class (liftIO) 9 | import Control.Monad.Trans.Either (EitherT, handleIOEitherT, secondEitherT) 10 | 11 | import Jenga.Types 12 | 13 | import System.Directory (doesDirectoryExist, doesFileExist, listDirectory) 14 | import System.FilePath (()) 15 | 16 | import System.IO.Error (tryIOError) 17 | 18 | 19 | -- | Generate a list of all files in the specified directory. The file paths 20 | -- returned are relative to the provided directory. 21 | -- If the staring directory does not exist, a JengaError will be returned. 22 | listDirectoryRecursive :: FilePath -> EitherT JengaError IO [FilePath] 23 | listDirectoryRecursive path = do 24 | entries <- secondEitherT (fmap (path )) $ handleIOEitherT handler (listDirectory path) 25 | subEntries <- mapM recurse entries 26 | pure . concat $ entries : subEntries 27 | where 28 | handler = 29 | JengaIOError "listDirectoryRecursive" path 30 | recurse entry = do 31 | isDir <- liftIO $ doesDirectoryExist entry 32 | if isDir 33 | then listDirectoryRecursive entry 34 | else pure [] 35 | 36 | -- | List files in a specified directory. 37 | -- If an IOExceptions occurs (eg directory does not exist) an empty list is returned. 38 | listFiles :: FilePath -> IO [FilePath] 39 | listFiles dir = do 40 | xs <- either (const []) id <$> tryIOError (listDirectory dir) 41 | filterM doesFileExist $ fmap (dir ) xs 42 | -------------------------------------------------------------------------------- /src/Jenga/Merge.hs: -------------------------------------------------------------------------------- 1 | module Jenga.Merge 2 | ( mergePackages 3 | ) where 4 | 5 | import qualified Data.List as List 6 | import Data.Map.Strict (Map) 7 | import qualified Data.Map.Strict as Map 8 | import Data.Text (Text) 9 | 10 | import Jenga.Git.SubModules 11 | import Jenga.Stack 12 | import Jenga.Types 13 | 14 | 15 | -- Merge the packages from the resolver, the extra-deps and the git 16 | -- submodules. 17 | mergePackages :: [Package] -> [StackExtraDep] -> [GitSubmodule] -> [Text] -> [Package] 18 | mergePackages pkgs deps submods dropDeps = 19 | -- Start with a `Map PkgName PkgVersion` generated from the packages listed 20 | -- by the stack resolver. 21 | let pkgMap0 = Map.fromList $ List.map (\p -> (packageName p, packageVersion p)) pkgs 22 | 23 | -- Now add the extra-dep packages from the stack file. Any package name in 24 | -- pkgMap0 may have its version number overridden here. 25 | pkgMap1 = List.foldl' insertExtraDep pkgMap0 deps 26 | -- Finally add any packages that were listed as git repositories in the stack 27 | -- file. Again, these versions will override any existing package versions. 28 | pkgMap2 = List.foldl' insertPackage pkgMap1 $ List.map smPackage submods 29 | 30 | -- Now remove all packages listed as drop dependencies. 31 | pkgMap3 = List.foldl' dropPackage pkgMap2 dropDeps 32 | in List.map (uncurry Package) $ Map.toList pkgMap3 33 | where 34 | insertExtraDep :: Map Text Version -> StackExtraDep -> Map Text Version 35 | insertExtraDep pmap sed = 36 | case sed of 37 | StackExtraDep name version -> Map.insert name version pmap 38 | 39 | insertPackage :: Map Text Version -> Package -> Map Text Version 40 | insertPackage pmap pkg = 41 | Map.insert (packageName pkg) (packageVersion pkg) pmap 42 | 43 | dropPackage :: Map Text Version -> Text -> Map Text Version 44 | dropPackage pmap name = 45 | Map.delete name pmap 46 | -------------------------------------------------------------------------------- /src/Jenga/PackageList.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Jenga.PackageList 4 | ( Package (..) 5 | , PackageList (..) 6 | , lookupPackages 7 | ) where 8 | 9 | import Data.Aeson (FromJSON (..), Value (..), (.:)) 10 | import Data.Aeson.Types (Parser, typeMismatch) 11 | 12 | import Data.Map.Strict (Map) 13 | import qualified Data.Map.Strict as Map 14 | 15 | import Data.Text (Text) 16 | 17 | import Jenga.Types 18 | 19 | 20 | data PackageList = PackageList 21 | { ghcVersion :: Text 22 | , creatDate :: Text 23 | , resolverName :: Text 24 | , packageMap :: Map Text Package 25 | } 26 | deriving Show 27 | 28 | data PackageTemp = PackageTemp -- Not exported 29 | { _pkgName :: Text 30 | , _pkgVer :: Version 31 | , _pkgSyn :: Text 32 | , _pkgCCore :: Bool 33 | } 34 | 35 | -- Temporary data type. Not exported. 36 | data Snapshot = Snapshot 37 | { snapshotGhc :: Text 38 | , snapshotCreated :: Text 39 | , snapshotName :: Text 40 | } 41 | 42 | 43 | instance FromJSON PackageTemp where 44 | parseJSON (Object v) = 45 | PackageTemp <$> v .: "name" 46 | <*> (parseVersion =<< v .: "version") 47 | <*> v .: "synopsis" 48 | <*> v .: "isCore" 49 | parseJSON invalid = typeMismatch "PackageTemp" invalid 50 | 51 | parseVersion :: Text -> Parser Version 52 | parseVersion = 53 | pure . readVersion 54 | 55 | instance FromJSON Snapshot where 56 | parseJSON (Object v) = 57 | Snapshot <$> v .: "ghc" 58 | <*> v .: "created" 59 | <*> v .: "name" 60 | parseJSON invalid = typeMismatch "Snapshot" invalid 61 | 62 | instance FromJSON PackageList where 63 | parseJSON (Object v) = do 64 | s <- v .: "snapshot" 65 | pkgs <- v .: "packages" 66 | pure $ PackageList (snapshotGhc s) (snapshotCreated s) (snapshotName s) $ mkPackageTempMap pkgs 67 | 68 | parseJSON invalid = typeMismatch "PackageList" invalid 69 | 70 | mkPackageTempMap :: [PackageTemp] -> Map Text Package 71 | mkPackageTempMap = 72 | Map.fromList . fmap convert 73 | where 74 | convert (PackageTemp nam ver _ _) = 75 | (nam, Package nam ver) 76 | 77 | lookupPackages :: PackageList -> [Text] -> [Either Text (Text, Package)] 78 | lookupPackages plist deps = 79 | fmap plookup deps 80 | where 81 | pmap = packageMap plist 82 | plookup k = 83 | case Map.lookup k pmap of 84 | Nothing -> Left k 85 | Just x -> Right (k, x) 86 | 87 | -------------------------------------------------------------------------------- /src/Jenga/Render.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Jenga.Render 3 | ( LockFilePath (..) 4 | , writeLockFile 5 | , toLockPath 6 | , toMafiaLockPath 7 | ) where 8 | 9 | import Control.Monad.Trans.Either (EitherT, handleIOEitherT) 10 | 11 | import qualified Data.List as List 12 | import Data.Text (Text) 13 | import qualified Data.Text as Text 14 | import qualified Data.Text.Lazy as LazyText 15 | import qualified Data.Text.Lazy.IO as LazyText 16 | 17 | import Jenga.PackageList 18 | import Jenga.Cabal 19 | import Jenga.Types 20 | 21 | import System.FilePath.Posix ((), addExtension, dropExtension, takeDirectory) 22 | 23 | 24 | data LockFilePath 25 | = MafiaLockPath !FilePath 26 | | CabalFreezePath !FilePath 27 | 28 | 29 | writeLockFile :: LockFilePath -> [Package] -> EitherT JengaError IO () 30 | writeLockFile lockPath = 31 | case lockPath of 32 | MafiaLockPath mpath -> writeMafiaLock mpath 33 | CabalFreezePath cpath -> writeCabalConfig cpath 34 | 35 | toLockPath :: LockFormat -> CabalFilePath -> Text -> LockFilePath 36 | toLockPath lockFormat cfpath ghcVer = 37 | case lockFormat of 38 | MafiaLock -> toMafiaLockPath cfpath ghcVer 39 | CabalFreeze -> toCabalFreezePath cfpath 40 | 41 | writeCabalConfig :: FilePath -> [Package] -> EitherT JengaError IO () 42 | writeCabalConfig fpath pkgs = 43 | -- Generating the cabal freeze file that cabal will actually accept is a 44 | -- pain in the neck. 45 | writeFileEitherT fpath $ LazyText.fromChunks (cabalLines ++ ["\n"]) 46 | where 47 | cabalLines = 48 | case pkgs of 49 | [] -> ["constraints:"] 50 | (x:xs) -> List.intersperse ",\n " 51 | $ Text.concat ("constraints: " : renderPackage x) 52 | : List.map (Text.concat . renderPackage) xs 53 | 54 | 55 | writeMafiaLock :: FilePath -> [Package] -> EitherT JengaError IO () 56 | writeMafiaLock mpath pkgs = 57 | writeFileEitherT mpath . LazyText.unlines $ List.map LazyText.fromChunks mafiaLines 58 | where 59 | mafiaLines = ["# mafia-lock-file-version: 0"] : List.map renderPackage pkgs 60 | 61 | renderPackage :: Package -> [Text] 62 | renderPackage pkg = 63 | [ packageName pkg, " == ", renderVersion (packageVersion pkg) ] 64 | 65 | toMafiaLockPath :: CabalFilePath -> Text -> LockFilePath 66 | toMafiaLockPath (CabalFilePath fp) ghcVer = 67 | MafiaLockPath . addExtension (dropExtension fp) $ "lock-" ++ Text.unpack ghcVer 68 | 69 | toCabalFreezePath :: CabalFilePath -> LockFilePath 70 | toCabalFreezePath (CabalFilePath fp) = 71 | CabalFreezePath $ takeDirectory fp "cabal.config" 72 | 73 | 74 | writeFileEitherT :: FilePath -> LazyText.Text -> EitherT JengaError IO () 75 | writeFileEitherT path = 76 | handleIOEitherT handler . LazyText.writeFile path 77 | where 78 | handler = 79 | JengaIOError "writeFileEitherT" path 80 | -------------------------------------------------------------------------------- /src/Jenga/Stack.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Jenga.Stack 4 | ( ConfigExtraDep (..) 5 | , StackLocalDir (..) 6 | , StackConfig 7 | , StackExtraDep (..) 8 | , StackFilePath (..) 9 | , StackGitRepo (..) 10 | , mkStackConfig 11 | , parseStackConfig 12 | , readStackConfig 13 | , renderStackConfig 14 | , stackExtraDeps 15 | , stackGitRepos 16 | , stackLocalDirs 17 | , stackResolver 18 | ) where 19 | 20 | import Control.Applicative (optional) 21 | import Control.Monad.Extra (mapMaybeM) 22 | import Control.Monad.Trans.Either (EitherT, handleIOEitherT, hoistEither) 23 | 24 | import Data.Aeson (ToJSON (..), Value (..), (.=)) 25 | import qualified Data.Aeson as Aeson 26 | import Data.Aeson.Encode.Pretty (encodePretty', defConfig) 27 | 28 | import Data.Bifunctor (first) 29 | import Data.ByteString.Char8 (ByteString) 30 | import qualified Data.ByteString.Char8 as BS 31 | import qualified Data.ByteString.Lazy.Char8 as LBS 32 | import qualified Data.List as List 33 | import Data.Maybe (fromMaybe) 34 | import Data.Monoid ((<>)) 35 | 36 | import Data.Text (Text) 37 | import qualified Data.Text as Text 38 | import Data.YAML (FromYAML (..), Mapping, Node (..), Parser, Scalar (..), (.:), (.:?)) 39 | import qualified Data.YAML as Yaml 40 | 41 | import Jenga.Types 42 | 43 | import System.IO.Error (isDoesNotExistError) 44 | 45 | newtype StackFilePath 46 | = StackFilePath { unstackFilePath :: FilePath } 47 | 48 | -- | StackConfig needs to be an opaque type because git repos (with hashes) can 49 | -- be listed in either the 'extra-deps` field of the 'locations' field (which 50 | -- ends up in `cfgGitRepos`. To keep round trip testing of the parser working 51 | -- we keep `cfgExtraDeps` separate and then provide accessors below that can 52 | -- correctly separate the components. 53 | data StackConfig = StackConfig 54 | { cfgResolver :: !Text 55 | , cfgExtraDeps :: ![ConfigExtraDep] 56 | , cfgLocalDirs :: ![StackLocalDir] 57 | , cfgGitRepos :: ![StackGitRepo] 58 | } 59 | deriving (Eq, Show) 60 | 61 | -- | The public StackConfig constructor. Destructors are not provided except 62 | -- via the accessors below. 63 | mkStackConfig :: Text -> [ConfigExtraDep] -> [StackLocalDir] -> [StackGitRepo] -> StackConfig 64 | mkStackConfig = StackConfig 65 | 66 | stackResolver :: StackConfig -> Text 67 | stackResolver = cfgResolver 68 | 69 | -- | Return only the 'extra-deps' package names and versions from the config. 70 | stackExtraDeps :: StackConfig -> [StackExtraDep] 71 | stackExtraDeps cfg = 72 | [ dep | ConfigExtraDep dep <- cfgExtraDeps cfg ] 73 | 74 | stackLocalDirs :: StackConfig -> [StackLocalDir] 75 | stackLocalDirs = cfgLocalDirs 76 | 77 | -- | Return all git repos (with their hashes) from the config, regardless of 78 | -- whether the git repo was listed on 'extra-deps' or 'locations'. 79 | stackGitRepos :: StackConfig -> [StackGitRepo] 80 | stackGitRepos cfg = 81 | cfgGitRepos cfg 82 | ++ [ r | ConfigExtraDepRepo r <- cfgExtraDeps cfg ] 83 | 84 | -- ----------------------------------------------------------------------------- 85 | 86 | instance FromYAML StackConfig where 87 | parseYAML = Yaml.withMap "StackConfig" $ \o -> 88 | StackConfig 89 | <$> o .: "resolver" 90 | <*> ((o .:? "extra-deps") >>= maybe (pure []) (parseArray "StackExtraDep" parseYAML)) 91 | -- The objects in the "packages" can be two different types, so we have 92 | -- to futz around quite a bit. 93 | <*> ((o .:? "packages") >>= maybe (pure []) (parseMaybeArray "StackLocalDir" parseMaybeStackLocalDir)) 94 | <*> ((o .:? "packages") >>= maybe (pure []) (parseMaybeArray "StackGitRepo" parseMaybeStackGitRepo)) 95 | 96 | instance ToJSON StackConfig where 97 | toJSON cfg = 98 | Aeson.object 99 | [ "resolver" .= cfgResolver cfg 100 | , "extra-deps" .= cfgExtraDeps cfg 101 | , "packages" .= (fmap toJSON (cfgLocalDirs cfg) ++ fmap toJSON (cfgGitRepos cfg)) 102 | ] 103 | 104 | parseArray :: String -> (Node -> Parser a) -> Node -> Parser [a] 105 | parseArray name parser v = 106 | case v of 107 | Scalar SNull -> pure [] 108 | _ -> Yaml.withSeq name (mapM parser) v 109 | 110 | parseMaybeArray :: String -> (Node -> Parser (Maybe a)) -> Node -> Parser [a] 111 | parseMaybeArray name parser v = 112 | case v of 113 | Scalar SNull -> pure [] 114 | _ -> Yaml.withSeq name (mapMaybeM parser) v 115 | 116 | data ConfigExtraDep 117 | = ConfigExtraDep !StackExtraDep 118 | | ConfigExtraDepRepo !StackGitRepo 119 | deriving (Eq, Show) 120 | 121 | data StackExtraDep 122 | = StackExtraDep !Text !Version 123 | deriving (Eq, Show) 124 | 125 | instance FromYAML ConfigExtraDep where 126 | parseYAML (Scalar (SStr s)) = ConfigExtraDep <$> parseStackExtraDep s 127 | parseYAML (Mapping _ o) = ConfigExtraDepRepo <$> mkStackGitRepo True [] o 128 | 129 | parseYAML invalid = Yaml.typeMismatch "StackExtraDep" invalid 130 | 131 | parseStackExtraDep :: Text -> Parser StackExtraDep 132 | parseStackExtraDep str = do 133 | -- Extra-deps are of the form 'packageName-version' where packageName itself 134 | -- may have a dash in it. 135 | let xs = Text.splitOn "-" str 136 | if List.length xs >= 2 137 | then pure $ StackExtraDep (Text.intercalate "-" $ init xs) (readVersion $ last xs) 138 | else fail $ "Can't find version number in extra-dep : " <> Text.unpack str 139 | 140 | instance ToJSON ConfigExtraDep where 141 | toJSON (ConfigExtraDep (StackExtraDep name version)) = 142 | Aeson.String $ Text.concat [name, "-", renderVersion version] 143 | toJSON (ConfigExtraDepRepo sgr) = 144 | Aeson.object 145 | [ "git" .= sgrUrl sgr 146 | , "commit" .= sgrCommit sgr 147 | ] 148 | 149 | data StackGitRepo = StackGitRepo 150 | { sgrUrl :: !Text 151 | , sgrName :: !Text 152 | , sgrCommit :: !Text 153 | -- Following two fields can only be present when a git repo is provided 154 | -- as a "location" rather than an "extra-dep". 155 | , sgrSubDirs :: ![Text] 156 | , sgrExtraDep :: !Bool 157 | } deriving (Eq, Show) 158 | 159 | 160 | mkStackGitRepo :: Bool -> [Text] -> Mapping -> Parser StackGitRepo 161 | mkStackGitRepo extraDep subdirs node = do 162 | url <- node .: "git" 163 | StackGitRepo url (repoName url) <$> node .: "commit" <*> pure subdirs <*> pure extraDep 164 | where 165 | repoName repo = 166 | let mname = List.last $ Text.splitOn "/" repo 167 | len = Text.length mname in 168 | if ".git" `Text.isSuffixOf` mname 169 | then Text.take (len - 4) mname 170 | else mname 171 | 172 | instance ToJSON StackGitRepo where 173 | toJSON sgr = 174 | Aeson.object 175 | [ "location" .= 176 | Aeson.object 177 | [ "git" .= sgrUrl sgr 178 | , "commit" .= sgrCommit sgr 179 | ] 180 | , "subdirs" .= sgrSubDirs sgr 181 | , "extra-dep" .= sgrExtraDep sgr 182 | ] 183 | 184 | parseMaybeStackGitRepo :: Node -> Parser (Maybe StackGitRepo) 185 | parseMaybeStackGitRepo v = 186 | case v of 187 | Mapping _ o -> 188 | (o .: "location") >>= \case 189 | Mapping _ q -> do 190 | ed <- o .: "extra-dep" 191 | sd <- fromMaybe [] <$> o .:? "subdirs" 192 | Just <$> mkStackGitRepo ed sd q 193 | _ -> pure Nothing 194 | _ -> pure Nothing 195 | 196 | 197 | newtype StackLocalDir 198 | = StackLocalDir Text 199 | deriving (Eq, Show) 200 | 201 | instance FromYAML StackLocalDir where 202 | parseYAML = Yaml.withStr "StackLocalDir" (pure . StackLocalDir) 203 | 204 | instance ToJSON StackLocalDir where 205 | toJSON (StackLocalDir s) = String s 206 | 207 | parseMaybeStackLocalDir :: Node -> Parser (Maybe StackLocalDir) 208 | parseMaybeStackLocalDir = 209 | optional . parseYAML 210 | 211 | -- ----------------------------------------------------------------------------- 212 | 213 | parseStackConfig :: ByteString -> Either JengaError StackConfig 214 | parseStackConfig bs = 215 | case Yaml.decodeStrict bs of 216 | Right [cfg] -> Right cfg 217 | Right [] -> Left $ JengaStackError "?" "empty stack configuration file" 218 | Right (_:_:_) -> Left $ JengaStackError "?" "Multiple documents encountered in stack configuration file" 219 | Left s -> Left $ JengaStackError "?" $ Text.pack s 220 | 221 | readStackConfig :: StackFilePath -> EitherT JengaError IO StackConfig 222 | readStackConfig (StackFilePath stackYamlFile) = do 223 | bs <- handleIOEitherT handler $ BS.readFile stackYamlFile 224 | hoistEither $ first correctFilePath (parseStackConfig bs) 225 | where 226 | handler err 227 | | isDoesNotExistError err = JengaStackMissing 228 | | otherwise = JengaStackError "?" $ Text.pack (show err) 229 | correctFilePath se = 230 | case se of 231 | JengaStackError _ e -> JengaStackError stackYamlFile e 232 | other -> other 233 | 234 | renderStackConfig :: StackConfig -> ByteString 235 | renderStackConfig = 236 | LBS.toStrict . encodePretty' defConfig 237 | -------------------------------------------------------------------------------- /src/Jenga/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Jenga.Types 4 | ( JengaError (..) 5 | , LockFormat (..) 6 | , Package (..) 7 | , readVersion 8 | , renderJengaError 9 | , renderVersion 10 | 11 | -- Re-export these from the Cabal library. 12 | , Version 13 | , mkVersion 14 | , versionNumbers 15 | ) where 16 | 17 | import Control.Exception (IOException) 18 | 19 | import qualified Data.List as List 20 | import Data.Monoid ((<>)) 21 | import Data.Text (Text) 22 | import qualified Data.Text as Text 23 | 24 | import Distribution.Pretty (prettyShow) 25 | import Distribution.Version (Version, mkVersion, versionNumbers) 26 | 27 | 28 | data LockFormat 29 | = MafiaLock 30 | | CabalFreeze 31 | deriving (Eq, Show) 32 | 33 | data Package = Package 34 | { packageName :: Text 35 | , packageVersion :: Version 36 | } 37 | deriving Show 38 | 39 | readVersion :: Text -> Version 40 | readVersion = 41 | mkVersion . List.map (read . Text.unpack) . Text.split (== '.') 42 | 43 | renderVersion :: Version -> Text 44 | renderVersion = Text.pack . prettyShow 45 | 46 | data JengaError 47 | = JengaConfigMissing 48 | | JengaConfigError !Text 49 | | JengaStackMissing 50 | | JengaStackError !FilePath !Text 51 | | JengaIOError !Text !FilePath !IOException 52 | | JengaGitDirMissing 53 | | JengaParseUrl !Text 54 | | JengaHttpStatus !Text !String 55 | | JengaHttpException !String 56 | | JengaJsonError !String 57 | | JengaHttpIOError !IOException 58 | | JengaSubmodFules !FilePath 59 | | JengaGitError !Text 60 | deriving (Eq, Show) 61 | 62 | 63 | renderJengaError :: JengaError -> Text 64 | renderJengaError je = 65 | case je of 66 | JengaConfigMissing -> 67 | "Jenga config file ('.jenga') is missing." 68 | JengaConfigError t -> 69 | "Error parsing '.jenga' file: " <> t 70 | JengaStackMissing -> 71 | "Missing 'stack.yaml' file." 72 | JengaStackError fp t -> 73 | Text.concat [ "Error parsing '", Text.pack fp, "': ", t ] 74 | JengaIOError f fp ioe -> 75 | f <> ": Error accessing '" <> Text.pack fp <> "': " <> renderIOException ioe 76 | JengaGitDirMissing -> 77 | "Unable to find '.git' directory." 78 | JengaParseUrl u -> 79 | "Not able to parse URL: " <> u 80 | JengaHttpStatus f s -> 81 | f <> " received HTTP response: " <> Text.pack s 82 | JengaHttpException s -> 83 | "HTTP exception: " <> Text.pack s 84 | JengaJsonError s -> 85 | "Error reading stackage JSON response: " <> Text.pack s 86 | JengaHttpIOError ioe -> 87 | "IOError during HTTP request: " <> renderIOException ioe 88 | JengaSubmodFules modsDir -> 89 | "Found files in submodules directory '" <> Text.pack modsDir <> "' which should only have other directories." 90 | JengaGitError msg -> 91 | msg 92 | 93 | renderIOException :: IOException -> Text 94 | renderIOException = 95 | Text.pack . show 96 | -------------------------------------------------------------------------------- /test/Test/Jenga/Config.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Test.Jenga.Config 3 | ( tests 4 | ) where 5 | 6 | import Hedgehog (Property, discover) 7 | import qualified Hedgehog as H 8 | 9 | import Jenga 10 | 11 | import Test.Jenga.Gen 12 | 13 | prop_round_trip :: Property 14 | prop_round_trip = 15 | H.withTests 500 . H.property $ do 16 | cfg <- H.forAll genJengaConfig 17 | H.tripping cfg renderJengaConfig parseJengaConfig 18 | 19 | tests :: IO Bool 20 | tests = 21 | H.checkParallel $$(discover) 22 | -------------------------------------------------------------------------------- /test/Test/Jenga/Gen.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Test.Jenga.Gen 3 | ( genJengaConfig 4 | , genStackConfig 5 | ) where 6 | 7 | import qualified Data.List as DL 8 | import Data.Text (Text) 9 | import qualified Data.Text as Text 10 | 11 | import Hedgehog (Gen) 12 | import qualified Hedgehog.Corpus as Corpus 13 | import qualified Hedgehog.Gen as Gen 14 | import qualified Hedgehog.Range as Range 15 | 16 | import Jenga 17 | 18 | import System.FilePath (joinPath) 19 | 20 | genJengaConfig :: Gen JengaConfig 21 | genJengaConfig = 22 | JengaConfig 23 | <$> localPath 24 | <*> Gen.element [ MafiaLock, CabalFreeze ] 25 | <*> Gen.list (Range.linear 0 5) genPackageName 26 | <*> Gen.list (Range.linear 0 5) genJengaSubmodule 27 | where 28 | localPath = 29 | ModulesDirPath . joinPath <$> Gen.list (Range.linear 1 5) pathName 30 | 31 | pathName = 32 | Gen.list (Range.linear 1 10) $ 33 | Gen.frequency 34 | [ (5, Gen.alphaNum) 35 | , (1, Gen.element ".-+@$%^& ") 36 | ] 37 | 38 | genStackConfig :: Gen StackConfig 39 | genStackConfig = 40 | mkStackConfig 41 | <$> genResolver 42 | <*> Gen.list (Range.linear 0 5) genStackExtraDep 43 | <*> Gen.list (Range.linear 0 5) genStackLocalDir 44 | <*> Gen.list (Range.linear 0 5) genStackGitRepo 45 | 46 | 47 | genResolver :: Gen Text 48 | genResolver = 49 | Text.pack . DL.take 4 . show . (`div` 100) <$> Gen.int (Range.linear 100 9999) 50 | 51 | genStackExtraDep :: Gen ConfigExtraDep 52 | genStackExtraDep = 53 | Gen.choice 54 | [ ConfigExtraDep <$> (StackExtraDep <$> genPackageName <*> genPackageVersion) 55 | , ConfigExtraDepRepo <$> fmap simplify genStackGitRepo 56 | ] 57 | where 58 | -- Git repos listed as an "extra-dep" cannot specify "subdirs" or "extra-dep" 59 | simplify (StackGitRepo u n c _ _) = StackGitRepo u n c [] True 60 | 61 | genStackLocalDir :: Gen StackLocalDir 62 | genStackLocalDir = 63 | StackLocalDir . Text.pack <$> genFilePath 64 | 65 | genStackGitRepo :: Gen StackGitRepo 66 | genStackGitRepo = do 67 | (location, owner, repoName, ext) <- getGitRepoUrlParts 68 | StackGitRepo (Text.concat [location, owner, "/", repoName, ext]) repoName 69 | <$> genCommitHash 70 | <*> Gen.list (Range.linear 0 5) (Gen.element Corpus.southpark) 71 | <*> Gen.bool 72 | 73 | getGitRepoUrlParts :: Gen (Text, Text, Text, Text) 74 | getGitRepoUrlParts = 75 | (,,,) <$> Gen.element ["https://github.com/", "git@github.com:", "https://bitbucket.org/"] 76 | <*> Gen.element Corpus.simpsons 77 | <*> Gen.element ["a", "xyz", "this-n-that"] 78 | <*> Gen.element [mempty, ".git"] 79 | 80 | genGitUrl :: Gen Text 81 | genGitUrl = do 82 | (location, owner, repoName, ext) <- getGitRepoUrlParts 83 | pure $ Text.concat [location, owner, "/", repoName, ext] 84 | 85 | genCommitHash :: Gen Text 86 | genCommitHash = 87 | Text.pack <$> Gen.list (Range.singleton 32) (Gen.element "0123456789abcdef") 88 | 89 | genFilePath :: Gen FilePath 90 | genFilePath = 91 | Gen.list (Range.linear 1 10) $ 92 | Gen.frequency 93 | [ (5, Gen.alphaNum) 94 | , (1, Gen.element ".-+@$%^& ") 95 | ] 96 | 97 | genPackageName :: Gen Text 98 | genPackageName = 99 | Text.pack . DL.intercalate "-" 100 | <$> Gen.list (Range.linear 1 3) (Gen.list (Range.linear 1 20) Gen.alphaNum) 101 | 102 | genPackageVersion :: Gen Version 103 | genPackageVersion = 104 | mkVersion <$> Gen.list (Range.linear 1 4) (Gen.int $ Range.linear 1 20) 105 | 106 | genJengaSubmodule :: Gen JengaSubmodule 107 | genJengaSubmodule = 108 | JengaSubmodule 109 | <$> genGitUrl 110 | <*> genFilePath 111 | <*> genCommitHash 112 | -------------------------------------------------------------------------------- /test/Test/Jenga/Stack.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Test.Jenga.Stack 3 | ( tests 4 | ) where 5 | 6 | import Hedgehog (Property, discover) 7 | import qualified Hedgehog as H 8 | 9 | import Jenga 10 | 11 | import Test.Jenga.Gen 12 | 13 | 14 | prop_round_trip :: Property 15 | prop_round_trip = 16 | H.withTests 500 . H.property $ do 17 | cfg <- H.forAll genStackConfig 18 | H.tripping cfg renderStackConfig parseStackConfig 19 | 20 | tests :: IO Bool 21 | tests = 22 | H.checkParallel $$(discover) 23 | -------------------------------------------------------------------------------- /test/cli/core/runner: -------------------------------------------------------------------------------- 1 | JENGA="$(pwd)/${1:-./dist/build/jenga/jenga}" 2 | 3 | DIFF=${USE_DIFF:-diff -u} 4 | 5 | # Failure is the default! 6 | RESULT="FAILED" 7 | 8 | type "$JENGA" > /dev/null 2>&1 || { 9 | echo "No jenga executable specified on command line or on path." 10 | exit 1 11 | } 12 | 13 | ROOT=$(dirname "$0")/../../.. 14 | ROOT=$(cd "$ROOT" > /dev/null 2>&1 && pwd) 15 | TMP=${ROOT}/tmp 16 | TEST=${TMP}/test/$$ 17 | mkdir -p ${TEST} 18 | 19 | cleanup () { 20 | echo "Cleaning up (${TEST})" 21 | rm -rf "${TEST}" 22 | echo ${RESULT} 23 | echo 24 | } 25 | 26 | trap cleanup EXIT 27 | 28 | banner () { 29 | echo 30 | echo == "$*" == 31 | echo == "Running in ${TEST}" == 32 | } 33 | 34 | assert_file_exists () { 35 | if test ! -f "$1" ; then 36 | echo "Output file '$1' is missing." 37 | error=1 38 | fi 39 | } 40 | 41 | assert_file_absent () { 42 | if test -f "$1" ; then 43 | echo "File '$1' is present but should not be." 44 | error=1 45 | fi 46 | } 47 | 48 | pass_test () { 49 | RESULT="PASSED [ ${testname} ]" 50 | exit 0 51 | } 52 | 53 | 54 | fail_test () { 55 | RESULT="FAILED [ ${testname} ]" 56 | exit 1 57 | } 58 | 59 | sort_diff () { 60 | EXP="$1" 61 | ACTUAL="$2" 62 | EXPECTED_SORTED=${OUTPUT_DIR}/sort_diff.expected.$(basename $EXP) 63 | ACTUAL_SORTED=${OUTPUT_DIR}/sort_diff.actual.$(basename $ACTUAL) 64 | sort ${EXP} > ${EXPECTED_SORTED} 65 | sort ${ACTUAL} > ${ACTUAL_SORTED} 66 | diff ${EXPECTED_SORTED} ${ACTUAL_SORTED} 67 | } 68 | 69 | compare_files () { 70 | actual="$1" 71 | expect="$2" 72 | 73 | test -f ${expect} || echo "New file" > ${expect} 74 | 75 | local rc=0 76 | cmp ${actual} ${expect} > /dev/null || rc=1 77 | if test ${rc} -ne 0 ; then 78 | ${DIFF} ${actual} ${expect} || error=1 79 | fi 80 | } 81 | -------------------------------------------------------------------------------- /test/cli/git-extra-dep/data/git-extra-dep.cabal: -------------------------------------------------------------------------------- 1 | name: git-extra-dep 2 | version: 0.0.0 3 | synopsis: A test project for jenga 4 | 5 | description: The simple combination of a cabal file and a stack.yaml 6 | file with the stack.yaml file specifying a git repo and 7 | a git commit as an extra dependency. 8 | 9 | license: MIT 10 | license-file: LICENSE 11 | author: Erik de Castro Lopo 12 | maintainer: erikd@mega-nerd.com 13 | category: Test 14 | build-type: Simple 15 | cabal-version: >= 1.10 16 | 17 | library 18 | ghc-options: -Wall -fwarn-tabs 19 | default-language: Haskell2010 20 | hs-source-dirs: src 21 | 22 | exposed-modules: Test.Jenga.GitExtraDep 23 | 24 | build-depends: base 25 | , binary 26 | , bytestring 27 | , containers 28 | , directory 29 | , exceptions 30 | , extra 31 | , filepath 32 | , time 33 | , transformers 34 | , wide-word 35 | -------------------------------------------------------------------------------- /test/cli/git-extra-dep/data/init-simple.cabal: -------------------------------------------------------------------------------- 1 | name: init-simple 2 | version: 0.0.0 3 | synopsis: A test project for jenga 4 | 5 | description: The simplest possible combination of a cabal file and a 6 | stack.yaml file. The stack file specifies the stack 7 | resolver version and nothing more. 8 | 9 | license: MIT 10 | license-file: LICENSE 11 | author: Erik de Castro Lopo 12 | maintainer: erikd@mega-nerd.com 13 | category: Test 14 | build-type: Simple 15 | cabal-version: >= 1.10 16 | 17 | library 18 | ghc-options: -Wall -fwarn-tabs 19 | default-language: Haskell2010 20 | hs-source-dirs: src 21 | 22 | exposed-modules: Test.Jenga.Init.Simple 23 | 24 | build-depends: base 25 | , binary 26 | , bytestring 27 | , containers 28 | , directory 29 | , exceptions 30 | , extra 31 | , filepath 32 | , time 33 | -------------------------------------------------------------------------------- /test/cli/git-extra-dep/data/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-8.12 2 | 3 | extra-deps: 4 | - transformers-0.5.5.0 5 | - { git: "https://github.com/erikd/wide-word" 6 | , commit: "354f9decd7019c026080820d2b120bf1b7c5f296" 7 | } 8 | 9 | packages: 10 | - '.' 11 | -------------------------------------------------------------------------------- /test/cli/git-extra-dep/expected/git-extra-dep.lock-8.0.2: -------------------------------------------------------------------------------- 1 | # mafia-lock-file-version: 0 2 | base == 4.9.1.0 3 | binary == 0.8.3.0 4 | bytestring == 0.10.8.1 5 | containers == 0.5.7.1 6 | directory == 1.3.0.0 7 | exceptions == 0.8.3 8 | extra == 1.5.2 9 | filepath == 1.4.1.1 10 | time == 1.6.0.1 11 | transformers == 0.5.5.0 12 | wide-word == 0.1.0.4 13 | -------------------------------------------------------------------------------- /test/cli/git-extra-dep/expected/jenga.yaml: -------------------------------------------------------------------------------- 1 | { 2 | "submodule-dir": "lib", 3 | "mafia-lock": true, 4 | "submodules": [ 5 | { 6 | "hash": "354f9decd7019c026080820d2b120bf1b7c5f296", 7 | "path": "lib/wide-word", 8 | "url": "https://github.com/erikd/wide-word" 9 | } 10 | ], 11 | "drop-deps": [] 12 | } 13 | -------------------------------------------------------------------------------- /test/cli/git-extra-dep/run: -------------------------------------------------------------------------------- 1 | #!/bin/sh -eu 2 | 3 | # Run 'jenga init' with a git repo listed in the 'extra-deps' section of 4 | # the 'stack.yaml' file. 5 | 6 | . $(dirname $0)/../core/runner 7 | 8 | testname="git-extra-dep" 9 | 10 | banner "${testname}" 11 | #---------- 12 | 13 | INPUT_DIR=$(dirname $0)/data 14 | OUTPUT_DIR=${TEST} 15 | EXPECTED_DIR=$(dirname $0)/expected 16 | 17 | mkdir -p ${OUTPUT_DIR} 18 | 19 | cp -f ${INPUT_DIR}/* ${OUTPUT_DIR}/ 20 | 21 | (cd ${OUTPUT_DIR} && \ 22 | git init && \ 23 | git add stack.yaml ${testname}.cabal && \ 24 | git commit -m "Initial commit" -- . && \ 25 | ${JENGA} init ) 26 | 27 | assert_file_exists ${OUTPUT_DIR}/lib/wide-word/wide-word.cabal 28 | assert_file_exists ${OUTPUT_DIR}/${testname}.lock-8.0.2 29 | assert_file_exists ${OUTPUT_DIR}/.jenga 30 | 31 | error=0 32 | compare_files ${OUTPUT_DIR}/${testname}.lock-8.0.2 ${EXPECTED_DIR}/${testname}.lock-8.0.2 33 | compare_files ${OUTPUT_DIR}/.jenga ${EXPECTED_DIR}/jenga.yaml 34 | 35 | if test "${error}" = "0"; then 36 | pass_test 37 | else 38 | fail_test 39 | fi 40 | -------------------------------------------------------------------------------- /test/cli/init-drop-deps/data/init-drop-deps.cabal: -------------------------------------------------------------------------------- 1 | name: init-extra-deps 2 | version: 0.0.0 3 | synopsis: A test project for jenga 4 | 5 | description: The simple combination of a simple cabal file and a stack.yaml file, 6 | but the the stack file specifies the stack resolver and some extra 7 | dependencies. 8 | 9 | license: MIT 10 | license-file: LICENSE 11 | author: Erik de Castro Lopo 12 | maintainer: erikd@mega-nerd.com 13 | category: Test 14 | build-type: Simple 15 | cabal-version: >= 1.10 16 | 17 | library 18 | ghc-options: -Wall -fwarn-tabs 19 | default-language: Haskell2010 20 | hs-source-dirs: src 21 | 22 | exposed-modules: Test.Jenga.Init.ExtraDeps 23 | 24 | build-depends: base 25 | , binary 26 | , bytestring 27 | , containers 28 | , directory 29 | , exceptions 30 | , extra 31 | , filepath 32 | , time 33 | , wide-word 34 | -------------------------------------------------------------------------------- /test/cli/init-drop-deps/data/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-9.0 2 | 3 | extra-deps: [] 4 | 5 | packages: 6 | - '.' 7 | -------------------------------------------------------------------------------- /test/cli/init-drop-deps/expected/init-drop-deps.lock-8.0.2: -------------------------------------------------------------------------------- 1 | # mafia-lock-file-version: 0 2 | base == 4.9.1.0 3 | binary == 0.8.3.0 4 | bytestring == 0.10.8.1 5 | containers == 0.5.7.1 6 | exceptions == 0.8.3 7 | extra == 1.5.3 8 | time == 1.6.0.1 9 | -------------------------------------------------------------------------------- /test/cli/init-drop-deps/expected/jenga.yaml: -------------------------------------------------------------------------------- 1 | { 2 | "submodule-dir": "lib", 3 | "mafia-lock": true, 4 | "submodules": [], 5 | "drop-deps": [ 6 | "directory", 7 | "filepath" 8 | ] 9 | } 10 | -------------------------------------------------------------------------------- /test/cli/init-drop-deps/run: -------------------------------------------------------------------------------- 1 | #!/bin/sh -eu 2 | 3 | # Run 'jenga init' with a couple of explicitly dropped (ignored) dependencies. 4 | 5 | . $(dirname $0)/../core/runner 6 | 7 | testname="init-drop-deps" 8 | 9 | banner "${testname}" 10 | #---------- 11 | 12 | INPUT_DIR=$(dirname $0)/data 13 | OUTPUT_DIR=${TEST} 14 | EXPECTED_DIR=$(dirname $0)/expected 15 | 16 | mkdir -p ${OUTPUT_DIR} 17 | 18 | cp -f ${INPUT_DIR}/* ${OUTPUT_DIR}/ 19 | 20 | (cd ${OUTPUT_DIR} && \ 21 | git init && \ 22 | git add stack.yaml ${testname}.cabal && \ 23 | git commit -m "Initial commit" -- . && \ 24 | ${JENGA} init --drop-deps directory,filepath ) 25 | 26 | assert_file_exists ${OUTPUT_DIR}/${testname}.lock-8.0.2 27 | assert_file_exists ${OUTPUT_DIR}/.jenga 28 | 29 | error=0 30 | compare_files ${OUTPUT_DIR}/${testname}.lock-8.0.2 ${EXPECTED_DIR}/${testname}.lock-8.0.2 31 | compare_files ${OUTPUT_DIR}/.jenga ${EXPECTED_DIR}/jenga.yaml 32 | 33 | if test "${error}" = "0"; then 34 | pass_test 35 | else 36 | fail_test 37 | fi 38 | -------------------------------------------------------------------------------- /test/cli/init-extra-deps/data/init-extra-deps.cabal: -------------------------------------------------------------------------------- 1 | name: init-extra-deps 2 | version: 0.0.0 3 | synopsis: A test project for jenga 4 | 5 | description: The simple combination of a simple cabal file and a stack.yaml file, 6 | but the the stack file specifies the stack resolver and some extra 7 | dependencies. 8 | 9 | license: MIT 10 | license-file: LICENSE 11 | author: Erik de Castro Lopo 12 | maintainer: erikd@mega-nerd.com 13 | category: Test 14 | build-type: Simple 15 | cabal-version: >= 1.10 16 | 17 | library 18 | ghc-options: -Wall -fwarn-tabs 19 | default-language: Haskell2010 20 | hs-source-dirs: src 21 | 22 | exposed-modules: Test.Jenga.Init.ExtraDeps 23 | 24 | build-depends: base 25 | , binary 26 | , bytestring 27 | , containers 28 | , directory 29 | , exceptions 30 | , extra 31 | , filepath 32 | , time 33 | , wide-word 34 | -------------------------------------------------------------------------------- /test/cli/init-extra-deps/data/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-9.0 2 | 3 | extra-deps: 4 | # Override the defaul version of directory provided by this resolver. 5 | - directory-1.3.1.0 6 | # Add wide-word which (probably) isn't available in this resolver. 7 | - wide-word-0.1.0.5 8 | 9 | packages: 10 | - '.' 11 | -------------------------------------------------------------------------------- /test/cli/init-extra-deps/expected/init-extra-deps.lock-8.0.2: -------------------------------------------------------------------------------- 1 | # mafia-lock-file-version: 0 2 | base == 4.9.1.0 3 | binary == 0.8.3.0 4 | bytestring == 0.10.8.1 5 | containers == 0.5.7.1 6 | directory == 1.3.1.0 7 | exceptions == 0.8.3 8 | extra == 1.5.3 9 | filepath == 1.4.1.1 10 | time == 1.6.0.1 11 | wide-word == 0.1.0.5 12 | -------------------------------------------------------------------------------- /test/cli/init-extra-deps/expected/jenga.yaml: -------------------------------------------------------------------------------- 1 | { 2 | "submodule-dir": "lib", 3 | "mafia-lock": true, 4 | "submodules": [], 5 | "drop-deps": [] 6 | } 7 | -------------------------------------------------------------------------------- /test/cli/init-extra-deps/run: -------------------------------------------------------------------------------- 1 | #!/bin/sh -eu 2 | 3 | . $(dirname $0)/../core/runner 4 | 5 | testname="init-extra-deps" 6 | 7 | banner "${testname}" 8 | #---------- 9 | 10 | INPUT_DIR=$(dirname $0)/data 11 | OUTPUT_DIR=${TEST} 12 | EXPECTED_DIR=$(dirname $0)/expected 13 | 14 | mkdir -p ${OUTPUT_DIR} 15 | 16 | cp -f ${INPUT_DIR}/* ${OUTPUT_DIR}/ 17 | 18 | (cd ${OUTPUT_DIR} && \ 19 | git init && \ 20 | git add stack.yaml ${testname}.cabal && \ 21 | git commit -m "Initial commit" -- . && \ 22 | ${JENGA} init ) 23 | 24 | assert_file_exists ${OUTPUT_DIR}/${testname}.lock-8.0.2 25 | assert_file_exists ${OUTPUT_DIR}/.jenga 26 | 27 | error=0 28 | compare_files ${OUTPUT_DIR}/${testname}.lock-8.0.2 ${EXPECTED_DIR}/${testname}.lock-8.0.2 29 | compare_files ${OUTPUT_DIR}/.jenga ${EXPECTED_DIR}/jenga.yaml 30 | 31 | if test "${error}" = "0"; then 32 | pass_test 33 | else 34 | fail_test 35 | fi 36 | -------------------------------------------------------------------------------- /test/cli/init-freeze/data/init-freeze.cabal: -------------------------------------------------------------------------------- 1 | name: init-freeze 2 | version: 0.0.0 3 | synopsis: A test project for jenga 4 | 5 | description: The combination of a simple cabal file and a stack.yaml file, 6 | but jenga is supposed to generate a 'cabal.config' file instead 7 | of a mafia lock file. 8 | 9 | license: MIT 10 | license-file: LICENSE 11 | author: Erik de Castro Lopo 12 | maintainer: erikd@mega-nerd.com 13 | category: Test 14 | build-type: Simple 15 | cabal-version: >= 1.10 16 | 17 | library 18 | ghc-options: -Wall -fwarn-tabs 19 | default-language: Haskell2010 20 | hs-source-dirs: src 21 | 22 | exposed-modules: Test.Jenga.Init.Freeze 23 | 24 | build-depends: base 25 | , binary 26 | , bytestring 27 | , containers 28 | , directory 29 | , exceptions 30 | , extra 31 | , filepath 32 | , time 33 | -------------------------------------------------------------------------------- /test/cli/init-freeze/data/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-9.1 2 | 3 | extra-deps: [] 4 | 5 | packages: 6 | - '.' 7 | 8 | - location: 9 | git: https://github.com/erikd/wide-word 10 | commit: 354f9decd7019c026080820d2b120bf1b7c5f296 11 | extra-dep: true 12 | -------------------------------------------------------------------------------- /test/cli/init-freeze/expected/cabal.config: -------------------------------------------------------------------------------- 1 | constraints: base == 4.9.1.0, 2 | binary == 0.8.3.0, 3 | bytestring == 0.10.8.1, 4 | containers == 0.5.7.1, 5 | directory == 1.3.0.0, 6 | exceptions == 0.8.3, 7 | extra == 1.5.3, 8 | filepath == 1.4.1.1, 9 | time == 1.6.0.1, 10 | wide-word == 0.1.0.4 11 | -------------------------------------------------------------------------------- /test/cli/init-freeze/expected/jenga.yaml: -------------------------------------------------------------------------------- 1 | { 2 | "submodule-dir": "lib", 3 | "mafia-lock": false, 4 | "submodules": [ 5 | { 6 | "hash": "354f9decd7019c026080820d2b120bf1b7c5f296", 7 | "path": "lib/wide-word", 8 | "url": "https://github.com/erikd/wide-word" 9 | } 10 | ], 11 | "drop-deps": [] 12 | } 13 | -------------------------------------------------------------------------------- /test/cli/init-freeze/run: -------------------------------------------------------------------------------- 1 | #!/bin/sh -eu 2 | 3 | # Create a repo using a know stack.yaml file. 4 | # Run `jenga init` to initialize the submodule ('wide-word`). 5 | # Check that the local '.jenga' file is as expected. 6 | # Check that the cabal freeze file is as expected. 7 | 8 | . $(dirname $0)/../core/runner 9 | 10 | testname="init-freeze" 11 | 12 | banner "${testname}" 13 | #---------- 14 | 15 | INPUT_DIR=$(dirname $0)/data 16 | OUTPUT_DIR=${TEST} 17 | EXPECTED_DIR=$(dirname $0)/expected 18 | 19 | mkdir -p ${OUTPUT_DIR} 20 | 21 | cp -f ${INPUT_DIR}/* ${OUTPUT_DIR}/ 22 | 23 | (cd ${OUTPUT_DIR} && \ 24 | git init && \ 25 | git add stack.yaml ${testname}.cabal && \ 26 | git commit -m "Initial commit" -- . && \ 27 | ${JENGA} init --cabal-freeze ) 28 | 29 | assert_file_exists ${OUTPUT_DIR}/cabal.config 30 | assert_file_exists ${OUTPUT_DIR}/lib/wide-word/wide-word.cabal 31 | assert_file_exists ${OUTPUT_DIR}/.jenga 32 | 33 | # If the freeze file is invalid this will fail. 34 | cabal sandbox init 35 | 36 | error=0 37 | compare_files ${OUTPUT_DIR}/cabal.config ${EXPECTED_DIR}/cabal.config 38 | compare_files ${OUTPUT_DIR}/.jenga ${EXPECTED_DIR}/jenga.yaml 39 | 40 | if test "${error}" = "0"; then 41 | pass_test 42 | else 43 | fail_test 44 | fi 45 | -------------------------------------------------------------------------------- /test/cli/init-simple/data/init-simple.cabal: -------------------------------------------------------------------------------- 1 | name: init-simple 2 | version: 0.0.0 3 | synopsis: A test project for jenga 4 | 5 | description: The simplest possible combination of a cabal file and a 6 | stack.yaml file. The stack file specifies the stack 7 | resolver version and nothing more. 8 | 9 | license: MIT 10 | license-file: LICENSE 11 | author: Erik de Castro Lopo 12 | maintainer: erikd@mega-nerd.com 13 | category: Test 14 | build-type: Simple 15 | cabal-version: >= 1.10 16 | 17 | library 18 | ghc-options: -Wall -fwarn-tabs 19 | default-language: Haskell2010 20 | hs-source-dirs: src 21 | 22 | exposed-modules: Test.Jenga.Init.Simple 23 | 24 | build-depends: base 25 | , binary 26 | , bytestring 27 | , containers 28 | , directory 29 | , exceptions 30 | , extra 31 | , filepath 32 | , time 33 | -------------------------------------------------------------------------------- /test/cli/init-simple/data/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-8.12 2 | 3 | extra-deps: [] 4 | 5 | packages: 6 | - '.' 7 | -------------------------------------------------------------------------------- /test/cli/init-simple/expected/init-simple.lock-8.0.2: -------------------------------------------------------------------------------- 1 | # mafia-lock-file-version: 0 2 | base == 4.9.1.0 3 | binary == 0.8.3.0 4 | bytestring == 0.10.8.1 5 | containers == 0.5.7.1 6 | directory == 1.3.0.0 7 | exceptions == 0.8.3 8 | extra == 1.5.2 9 | filepath == 1.4.1.1 10 | time == 1.6.0.1 11 | -------------------------------------------------------------------------------- /test/cli/init-simple/expected/jenga.yaml: -------------------------------------------------------------------------------- 1 | { 2 | "submodule-dir": "lib", 3 | "mafia-lock": true, 4 | "submodules": [], 5 | "drop-deps": [] 6 | } 7 | -------------------------------------------------------------------------------- /test/cli/init-simple/run: -------------------------------------------------------------------------------- 1 | #!/bin/sh -eu 2 | 3 | # Create a repo using a know stack.yaml file. 4 | # Run `jenga init` to initialize the submodule ('wide-word`). 5 | # Check that the local '.jenga' file is as expected. 6 | # Check that the mafia lock file is as expected. 7 | # Also make sure that cabal files in the 'dist-newstyle' and '.cabal-sandbox' 8 | # are ignored. 9 | 10 | . $(dirname $0)/../core/runner 11 | 12 | testname="init-simple" 13 | 14 | banner "${testname}" 15 | #---------- 16 | 17 | INPUT_DIR=$(dirname $0)/data 18 | OUTPUT_DIR=${TEST} 19 | EXPECTED_DIR=$(dirname $0)/expected 20 | 21 | mkdir -p ${OUTPUT_DIR} 22 | 23 | cp -f ${INPUT_DIR}/* ${OUTPUT_DIR}/ 24 | 25 | # Add some invalid cabal files to make sure they are ignored. 26 | mkdir ${OUTPUT_DIR}/dist-newstyle ${OUTPUT_DIR}/.cabal-sandbox/ 27 | echo "Invalid cabal file" > ${OUTPUT_DIR}/dist-newstyle/invalid.cabal 28 | echo "Invalid cabal file" > ${OUTPUT_DIR}/.cabal-sandbox/invalid.cabal 29 | 30 | (cd ${OUTPUT_DIR} && \ 31 | git init && \ 32 | git add stack.yaml ${testname}.cabal && \ 33 | git commit -m "Initial commit" -- . && \ 34 | ${JENGA} init ) 35 | 36 | assert_file_exists ${OUTPUT_DIR}/${testname}.lock-8.0.2 37 | assert_file_exists ${OUTPUT_DIR}/.jenga 38 | 39 | error=0 40 | compare_files ${OUTPUT_DIR}/${testname}.lock-8.0.2 ${EXPECTED_DIR}/${testname}.lock-8.0.2 41 | compare_files ${OUTPUT_DIR}/.jenga ${EXPECTED_DIR}/jenga.yaml 42 | 43 | if test "${error}" = "0"; then 44 | pass_test 45 | else 46 | fail_test 47 | fi 48 | -------------------------------------------------------------------------------- /test/cli/init-specific/data/init-specific.cabal: -------------------------------------------------------------------------------- 1 | name: init-specific 2 | version: 0.0.0 3 | synopsis: A test project for jenga 4 | 5 | description: The simplest possible combination of a cabal file and a 6 | stack.yaml file. The stack file specifies the stack 7 | resolver version and nothing more. 8 | 9 | license: MIT 10 | license-file: LICENSE 11 | author: Erik de Castro Lopo 12 | maintainer: erikd@mega-nerd.com 13 | category: Test 14 | build-type: Simple 15 | cabal-version: >= 1.10 16 | 17 | library 18 | ghc-options: -Wall -fwarn-tabs 19 | default-language: Haskell2010 20 | hs-source-dirs: src 21 | 22 | exposed-modules: Test.Jenga.Init.Simple 23 | 24 | build-depends: base 25 | , binary 26 | , bytestring 27 | , containers 28 | , directory 29 | , exceptions 30 | , extra 31 | , filepath 32 | , time 33 | -------------------------------------------------------------------------------- /test/cli/init-specific/data/stack-specific.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-11.13 2 | 3 | extra-deps: [] 4 | 5 | packages: 6 | - '.' 7 | -------------------------------------------------------------------------------- /test/cli/init-specific/data/stack.yaml: -------------------------------------------------------------------------------- 1 | This is not a valid stack.yaml file and should be ignored. 2 | -------------------------------------------------------------------------------- /test/cli/init-specific/expected/init-specific.lock-8.2.2: -------------------------------------------------------------------------------- 1 | # mafia-lock-file-version: 0 2 | base == 4.10.1.0 3 | binary == 0.8.5.1 4 | bytestring == 0.10.8.2 5 | containers == 0.5.10.2 6 | directory == 1.3.0.2 7 | exceptions == 0.8.3 8 | extra == 1.6.8 9 | filepath == 1.4.1.2 10 | time == 1.8.0.2 11 | -------------------------------------------------------------------------------- /test/cli/init-specific/expected/jenga.yaml: -------------------------------------------------------------------------------- 1 | { 2 | "submodule-dir": "lib", 3 | "mafia-lock": true, 4 | "submodules": [], 5 | "drop-deps": [] 6 | } 7 | -------------------------------------------------------------------------------- /test/cli/init-specific/run: -------------------------------------------------------------------------------- 1 | #!/bin/sh -eu 2 | 3 | # Create a repo using a known stack-specific.yaml file. 4 | # Run `jenga init` to initialize the submodule ('wide-word`). 5 | # Check that the local '.jenga' file is as expected. 6 | # Check that the mafia lock file is as expected. 7 | # Also make sure that cabal files in the 'dist-newstyle' and '.cabal-sandbox' 8 | # are ignored. 9 | 10 | . $(dirname $0)/../core/runner 11 | 12 | testname="init-specific" 13 | 14 | banner "${testname}" 15 | #---------- 16 | 17 | INPUT_DIR=$(dirname $0)/data 18 | OUTPUT_DIR=${TEST} 19 | EXPECTED_DIR=$(dirname $0)/expected 20 | 21 | mkdir -p ${OUTPUT_DIR} 22 | 23 | cp -f ${INPUT_DIR}/* ${OUTPUT_DIR}/ 24 | 25 | # Add some invalid cabal files to make sure they are ignored. 26 | mkdir ${OUTPUT_DIR}/dist-newstyle ${OUTPUT_DIR}/.cabal-sandbox/ 27 | echo "Invalid cabal file" > ${OUTPUT_DIR}/dist-newstyle/invalid.cabal 28 | echo "Invalid cabal file" > ${OUTPUT_DIR}/.cabal-sandbox/invalid.cabal 29 | 30 | (cd ${OUTPUT_DIR} && \ 31 | git init && \ 32 | git add stack-specific.yaml ${testname}.cabal && \ 33 | git commit -m "Initial commit" -- . && \ 34 | ${JENGA} init --stack-file stack-specific.yaml) 35 | 36 | assert_file_exists ${OUTPUT_DIR}/${testname}.lock-8.2.2 37 | assert_file_exists ${OUTPUT_DIR}/.jenga 38 | 39 | error=0 40 | compare_files ${OUTPUT_DIR}/${testname}.lock-8.2.2 ${EXPECTED_DIR}/${testname}.lock-8.2.2 41 | compare_files ${OUTPUT_DIR}/.jenga ${EXPECTED_DIR}/jenga.yaml 42 | 43 | if test "${error}" = "0"; then 44 | pass_test 45 | else 46 | fail_test 47 | fi 48 | -------------------------------------------------------------------------------- /test/cli/init-submodules-dir/data/init-submodules-dir.cabal: -------------------------------------------------------------------------------- 1 | name: init-submodules-dir 2 | version: 0.0.0 3 | synopsis: A test project for jenga 4 | 5 | description: The simple combination of a simple cabal file and a stack.yaml file, 6 | but the the stack file specifies the stack resolver, some extra 7 | dependencies and a git submodule. 8 | 9 | license: MIT 10 | license-file: LICENSE 11 | author: Erik de Castro Lopo 12 | maintainer: erikd@mega-nerd.com 13 | category: Test 14 | build-type: Simple 15 | cabal-version: >= 1.10 16 | 17 | library 18 | ghc-options: -Wall -fwarn-tabs 19 | default-language: Haskell2010 20 | hs-source-dirs: src 21 | 22 | exposed-modules: Test.Jenga.Init.SubModules 23 | 24 | build-depends: base 25 | , binary 26 | , bytestring 27 | , containers 28 | , directory 29 | , exceptions 30 | , extra 31 | , filepath 32 | , time 33 | -------------------------------------------------------------------------------- /test/cli/init-submodules-dir/data/lib/dummy.txt: -------------------------------------------------------------------------------- 1 | Hello 2 | -------------------------------------------------------------------------------- /test/cli/init-submodules-dir/data/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-9.1 2 | 3 | extra-deps: [] 4 | 5 | packages: 6 | - '.' 7 | 8 | - location: 9 | git: https://github.com/erikd/wide-word 10 | commit: 354f9decd7019c026080820d2b120bf1b7c5f296 11 | extra-dep: true 12 | -------------------------------------------------------------------------------- /test/cli/init-submodules-dir/run: -------------------------------------------------------------------------------- 1 | #!/bin/sh -eu 2 | 3 | # This test shows that Jenga fails if the submodules dir contains any regular files. 4 | # It should only contain directories. 5 | 6 | . $(dirname $0)/../core/runner 7 | 8 | testname="init-submodules-dir" 9 | 10 | banner "${testname}" 11 | #---------- 12 | 13 | INPUT_DIR=$(dirname $0)/data 14 | OUTPUT_DIR=${TEST} 15 | EXPECTED_DIR=$(dirname $0)/expected 16 | 17 | mkdir -p ${OUTPUT_DIR} 18 | 19 | cp -rf ${INPUT_DIR}/* ${OUTPUT_DIR} 20 | 21 | (cd ${OUTPUT_DIR} && \ 22 | git init && \ 23 | git add stack.yaml ${testname}.cabal && \ 24 | git commit -m "Initial commit" -- . ) 25 | 26 | error=0 27 | (cd ${OUTPUT_DIR} && \ 28 | (${JENGA} init || error=1) ) 29 | 30 | if test "${error}" = "0"; then 31 | pass_test 32 | else 33 | fail_test 34 | fi 35 | -------------------------------------------------------------------------------- /test/cli/init-submodules/data/init-submodules.cabal: -------------------------------------------------------------------------------- 1 | name: init-submodules 2 | version: 0.0.0 3 | synopsis: A test project for jenga 4 | 5 | description: The simple combination of a simple cabal file and a stack.yaml file, 6 | but the the stack file specifies the stack resolver, some extra 7 | dependencies and a git submodule. 8 | 9 | license: MIT 10 | license-file: LICENSE 11 | author: Erik de Castro Lopo 12 | maintainer: erikd@mega-nerd.com 13 | category: Test 14 | build-type: Simple 15 | cabal-version: >= 1.10 16 | 17 | library 18 | ghc-options: -Wall -fwarn-tabs 19 | default-language: Haskell2010 20 | hs-source-dirs: src 21 | 22 | exposed-modules: Test.Jenga.Init.SubModules 23 | 24 | build-depends: base 25 | , binary 26 | , bytestring 27 | , containers 28 | , directory 29 | , exceptions 30 | , extra 31 | , filepath 32 | , time 33 | -------------------------------------------------------------------------------- /test/cli/init-submodules/data/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-9.1 2 | 3 | extra-deps: [] 4 | 5 | packages: 6 | - '.' 7 | 8 | - location: 9 | git: https://github.com/erikd/wide-word 10 | commit: 354f9decd7019c026080820d2b120bf1b7c5f296 11 | extra-dep: true 12 | -------------------------------------------------------------------------------- /test/cli/init-submodules/expected/init-submodules.lock-8.0.2: -------------------------------------------------------------------------------- 1 | # mafia-lock-file-version: 0 2 | base == 4.9.1.0 3 | binary == 0.8.3.0 4 | bytestring == 0.10.8.1 5 | containers == 0.5.7.1 6 | directory == 1.3.0.0 7 | exceptions == 0.8.3 8 | extra == 1.5.3 9 | filepath == 1.4.1.1 10 | time == 1.6.0.1 11 | wide-word == 0.1.0.4 12 | -------------------------------------------------------------------------------- /test/cli/init-submodules/expected/jenga.yaml: -------------------------------------------------------------------------------- 1 | { 2 | "submodule-dir": "lib", 3 | "mafia-lock": true, 4 | "submodules": [ 5 | { 6 | "hash": "354f9decd7019c026080820d2b120bf1b7c5f296", 7 | "path": "lib/wide-word", 8 | "url": "https://github.com/erikd/wide-word" 9 | } 10 | ], 11 | "drop-deps": [] 12 | } 13 | -------------------------------------------------------------------------------- /test/cli/init-submodules/run: -------------------------------------------------------------------------------- 1 | #!/bin/sh -eu 2 | 3 | # Create a repo using a know stack.yaml file. 4 | # Run `jenga init` to initialize the submodule ('wide-word`). 5 | # Check that the local '.jenga' file is as expected. 6 | # Check that the mafia lock file is as expected. 7 | 8 | . $(dirname $0)/../core/runner 9 | 10 | testname="init-submodules" 11 | 12 | banner "${testname}" 13 | #---------- 14 | 15 | INPUT_DIR=$(dirname $0)/data 16 | OUTPUT_DIR=${TEST} 17 | EXPECTED_DIR=$(dirname $0)/expected 18 | 19 | mkdir -p ${OUTPUT_DIR} 20 | 21 | cp -f ${INPUT_DIR}/* ${OUTPUT_DIR}/ 22 | 23 | (cd ${OUTPUT_DIR} && \ 24 | git init && \ 25 | git add stack.yaml ${testname}.cabal && \ 26 | git commit -m "Initial commit" -- . && \ 27 | ${JENGA} init ) 28 | 29 | (cd ${OUTPUT_DIR} && \ 30 | git commit -m "Add submodules" -- . ) 31 | 32 | assert_file_exists ${OUTPUT_DIR}/lib/wide-word/wide-word.cabal 33 | assert_file_exists ${OUTPUT_DIR}/${testname}.lock-8.0.2 34 | assert_file_exists ${OUTPUT_DIR}/.jenga 35 | 36 | error=0 37 | compare_files ${OUTPUT_DIR}/${testname}.lock-8.0.2 ${EXPECTED_DIR}/${testname}.lock-8.0.2 38 | compare_files ${OUTPUT_DIR}/.jenga ${EXPECTED_DIR}/jenga.yaml 39 | 40 | if test "${error}" = "0"; then 41 | pass_test 42 | else 43 | fail_test 44 | fi 45 | -------------------------------------------------------------------------------- /test/cli/parse-jenga-config/data/jenga-0001.yaml: -------------------------------------------------------------------------------- 1 | submodule-dir: submods 2 | mafia-lock: true 3 | drop-deps: [ directory ] 4 | -------------------------------------------------------------------------------- /test/cli/parse-jenga-config/data/jenga-0002.yaml: -------------------------------------------------------------------------------- 1 | submodule-dir: lib 2 | mafia-lock: false 3 | drop-deps: [ ] 4 | -------------------------------------------------------------------------------- /test/cli/parse-jenga-config/expected/jenga-0001.json: -------------------------------------------------------------------------------- 1 | { 2 | "submodule-dir": "submods", 3 | "mafia-lock": true, 4 | "submodules": [], 5 | "drop-deps": [ 6 | "directory" 7 | ] 8 | } 9 | 10 | -------------------------------------------------------------------------------- /test/cli/parse-jenga-config/expected/jenga-0002.json: -------------------------------------------------------------------------------- 1 | { 2 | "submodule-dir": "lib", 3 | "mafia-lock": false, 4 | "submodules": [], 5 | "drop-deps": [] 6 | } 7 | 8 | -------------------------------------------------------------------------------- /test/cli/parse-jenga-config/expected/stack-0001.json: -------------------------------------------------------------------------------- 1 | { 2 | "packages": [ 3 | "." 4 | ], 5 | "extra-deps": [], 6 | "resolver": "lts-9.0" 7 | } 8 | -------------------------------------------------------------------------------- /test/cli/parse-jenga-config/expected/stack-0002.json: -------------------------------------------------------------------------------- 1 | { 2 | "packages": [ 3 | "first", 4 | "second", 5 | { 6 | "location": { 7 | "git": "https://github.com/well-typed/cborg", 8 | "commit": "c7db82bfd93923f5b08ed51a4cd53e30bd445924" 9 | }, 10 | "subdirs": [ 11 | "cborg" 12 | ], 13 | "extra-dep": true 14 | }, 15 | { 16 | "location": { 17 | "git": "https://github.com/thoughtpolice/hs-ed25519", 18 | "commit": "da4247b5b3420120e20451e6a252e2a2ca15b43c" 19 | }, 20 | "subdirs": [], 21 | "extra-dep": true 22 | } 23 | ], 24 | "extra-deps": [ 25 | "transformers-0.5.5.0", 26 | "concurrent-extra-0.7.0.10" 27 | ], 28 | "resolver": "lts-9.1" 29 | } 30 | -------------------------------------------------------------------------------- /test/cli/parse-jenga-config/expected/stack-0003.json: -------------------------------------------------------------------------------- 1 | { 2 | "packages": [], 3 | "extra-deps": [], 4 | "resolver": "lts-9.0" 5 | } 6 | -------------------------------------------------------------------------------- /test/cli/parse-jenga-config/expected/stack-0004.json: -------------------------------------------------------------------------------- 1 | { 2 | "packages": [], 3 | "extra-deps": [ 4 | "transformers-0.5.5.0", 5 | "concurrent-extra-0.7.0.10", 6 | { 7 | "git": "https://github.com/primetype/inspector", 8 | "commit": "674c5d3a4733088f14164b0924824b7433e06428" 9 | } 10 | ], 11 | "resolver": "lts-9.0" 12 | } 13 | -------------------------------------------------------------------------------- /test/cli/parse-jenga-config/expected/stack-0005.json: -------------------------------------------------------------------------------- 1 | { 2 | "packages": [ 3 | ".", 4 | { 5 | "location": { 6 | "git": "https://github.com/well-typed/cborg", 7 | "commit": "c7db82bfd93923f5b08ed51a4cd53e30bd445924" 8 | }, 9 | "subdirs": [ 10 | "cborg" 11 | ], 12 | "extra-dep": true 13 | }, 14 | { 15 | "location": { 16 | "git": "https://github.com/input-output-hk/engine.io.git", 17 | "commit": "d3c55f51bb81cee7d0d551de930ce65fe7d76756" 18 | }, 19 | "subdirs": [ 20 | "socket-io", 21 | "engine-io", 22 | "engine-io-wai" 23 | ], 24 | "extra-dep": true 25 | } 26 | ], 27 | "extra-deps": [], 28 | "resolver": "lts-11.13" 29 | } 30 | -------------------------------------------------------------------------------- /test/cli/parse-jenga-config/run: -------------------------------------------------------------------------------- 1 | #!/bin/sh -eu 2 | 3 | # Parse a number of variants on jenga config file, render the results as JSON and 4 | # make sure they match the expected outputs. 5 | 6 | . $(dirname $0)/../core/runner 7 | 8 | PARSER="${JENGA} parse-jenga --jenga-file" 9 | 10 | testname="parse-jenga-config" 11 | 12 | banner "${testname}" 13 | #---------- 14 | 15 | INPUT_DIR=$(dirname $0)/data 16 | OUTPUT_DIR=${TEST} 17 | EXPECTED_DIR=$(dirname $0)/expected 18 | 19 | mkdir -p ${OUTPUT_DIR} 20 | 21 | error_count=0 22 | 23 | for input in ${INPUT_DIR}/* ; do 24 | outname=$(basename $input | sed 's/\.yaml$/\.json/') 25 | output=${OUTPUT_DIR}/${outname} 26 | expected=${EXPECTED_DIR}/${outname} 27 | ${PARSER} ${input} > ${output} 28 | if ! test -f ${expected} ; then 29 | cp ${output} ${expected} 30 | fi 31 | error=0 32 | diff -q ${expected} ${output} || error=1 33 | if test "${error}" = "1"; then 34 | echo "Error in file:" ${input} 35 | ${DIFF} ${expected} ${output} 36 | fi 37 | done 38 | 39 | if test "${error_count}" = "0"; then 40 | pass_test 41 | else 42 | fail_test 43 | fi 44 | -------------------------------------------------------------------------------- /test/cli/parse-stack-config/data/stack-0001.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-9.0 2 | flags: {} 3 | extra-deps: [] 4 | extra-package-dbs: [] 5 | 6 | packages: 7 | - '.' 8 | nix: 9 | packages: [gmp,git] 10 | -------------------------------------------------------------------------------- /test/cli/parse-stack-config/data/stack-0002.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-9.1 2 | 3 | flags: 4 | ether: 5 | disable-tup-instances: true 6 | 7 | extra-package-dbs: [] 8 | 9 | # Some comment 10 | packages: 11 | - first 12 | - second 13 | 14 | - location: 15 | git: https://github.com/well-typed/cborg 16 | commit: c7db82bfd93923f5b08ed51a4cd53e30bd445924 17 | subdirs: 18 | - cborg 19 | extra-dep: true 20 | - location: 21 | git: https://github.com/thoughtpolice/hs-ed25519 22 | commit: da4247b5b3420120e20451e6a252e2a2ca15b43c 23 | extra-dep: true 24 | 25 | nix: 26 | shell-file: shell.nix 27 | 28 | extra-deps: 29 | - transformers-0.5.5.0 30 | - concurrent-extra-0.7.0.10 31 | -------------------------------------------------------------------------------- /test/cli/parse-stack-config/data/stack-0003.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | 3 | extra-package-dbs: [] 4 | 5 | packages: 6 | - location: wibble 7 | 8 | resolver: lts-9.0 9 | 10 | nix: 11 | packages: [gmp,git] 12 | -------------------------------------------------------------------------------- /test/cli/parse-stack-config/data/stack-0004.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-9.0 2 | 3 | extra-deps: 4 | - transformers-0.5.5.0 5 | - concurrent-extra-0.7.0.10 6 | - { git: "https://github.com/primetype/inspector" 7 | , commit: "674c5d3a4733088f14164b0924824b7433e06428" 8 | } 9 | -------------------------------------------------------------------------------- /test/cli/parse-stack-config/data/stack-0005.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-11.13 2 | flags: {} 3 | extra-deps: [] 4 | extra-package-dbs: [] 5 | 6 | packages: 7 | - '.' 8 | 9 | - location: 10 | git: https://github.com/well-typed/cborg 11 | commit: c7db82bfd93923f5b08ed51a4cd53e30bd445924 12 | subdirs: 13 | - cborg 14 | extra-dep: true 15 | 16 | - location: 17 | git: https://github.com/input-output-hk/engine.io.git 18 | commit: d3c55f51bb81cee7d0d551de930ce65fe7d76756 19 | extra-dep: true 20 | subdirs: 21 | - socket-io 22 | - engine-io 23 | - engine-io-wai 24 | -------------------------------------------------------------------------------- /test/cli/parse-stack-config/expected/stack-0001.json: -------------------------------------------------------------------------------- 1 | { 2 | "packages": [ 3 | "." 4 | ], 5 | "extra-deps": [], 6 | "resolver": "lts-9.0" 7 | } 8 | -------------------------------------------------------------------------------- /test/cli/parse-stack-config/expected/stack-0002.json: -------------------------------------------------------------------------------- 1 | { 2 | "packages": [ 3 | "first", 4 | "second", 5 | { 6 | "location": { 7 | "git": "https://github.com/well-typed/cborg", 8 | "commit": "c7db82bfd93923f5b08ed51a4cd53e30bd445924" 9 | }, 10 | "subdirs": [ 11 | "cborg" 12 | ], 13 | "extra-dep": true 14 | }, 15 | { 16 | "location": { 17 | "git": "https://github.com/thoughtpolice/hs-ed25519", 18 | "commit": "da4247b5b3420120e20451e6a252e2a2ca15b43c" 19 | }, 20 | "subdirs": [], 21 | "extra-dep": true 22 | } 23 | ], 24 | "extra-deps": [ 25 | "transformers-0.5.5.0", 26 | "concurrent-extra-0.7.0.10" 27 | ], 28 | "resolver": "lts-9.1" 29 | } 30 | -------------------------------------------------------------------------------- /test/cli/parse-stack-config/expected/stack-0003.json: -------------------------------------------------------------------------------- 1 | { 2 | "packages": [], 3 | "extra-deps": [], 4 | "resolver": "lts-9.0" 5 | } 6 | -------------------------------------------------------------------------------- /test/cli/parse-stack-config/expected/stack-0004.json: -------------------------------------------------------------------------------- 1 | { 2 | "packages": [], 3 | "extra-deps": [ 4 | "transformers-0.5.5.0", 5 | "concurrent-extra-0.7.0.10", 6 | { 7 | "git": "https://github.com/primetype/inspector", 8 | "commit": "674c5d3a4733088f14164b0924824b7433e06428" 9 | } 10 | ], 11 | "resolver": "lts-9.0" 12 | } 13 | -------------------------------------------------------------------------------- /test/cli/parse-stack-config/expected/stack-0005.json: -------------------------------------------------------------------------------- 1 | { 2 | "packages": [ 3 | ".", 4 | { 5 | "location": { 6 | "git": "https://github.com/well-typed/cborg", 7 | "commit": "c7db82bfd93923f5b08ed51a4cd53e30bd445924" 8 | }, 9 | "subdirs": [ 10 | "cborg" 11 | ], 12 | "extra-dep": true 13 | }, 14 | { 15 | "location": { 16 | "git": "https://github.com/input-output-hk/engine.io.git", 17 | "commit": "d3c55f51bb81cee7d0d551de930ce65fe7d76756" 18 | }, 19 | "subdirs": [ 20 | "socket-io", 21 | "engine-io", 22 | "engine-io-wai" 23 | ], 24 | "extra-dep": true 25 | } 26 | ], 27 | "extra-deps": [], 28 | "resolver": "lts-11.13" 29 | } 30 | -------------------------------------------------------------------------------- /test/cli/parse-stack-config/run: -------------------------------------------------------------------------------- 1 | #!/bin/sh -eu 2 | 3 | # Parse a number of variants on stack yaml file, render the results as JSON and 4 | # make sure they match the expected outputs. 5 | 6 | . $(dirname $0)/../core/runner 7 | 8 | PARSER="${JENGA} parse-stack --stack-file" 9 | 10 | testname="parse-stack-config" 11 | 12 | banner "${testname}" 13 | #---------- 14 | 15 | INPUT_DIR=$(dirname $0)/data 16 | OUTPUT_DIR=${TEST} 17 | EXPECTED_DIR=$(dirname $0)/expected 18 | 19 | mkdir -p ${OUTPUT_DIR} 20 | 21 | error_count=0 22 | 23 | for input in ${INPUT_DIR}/* ; do 24 | outname=$(basename $input | sed 's/\.yaml$/\.json/') 25 | output=${OUTPUT_DIR}/${outname} 26 | expected=${EXPECTED_DIR}/${outname} 27 | ${PARSER} ${input} > ${output} 28 | if ! test -f ${expected} ; then 29 | cp ${output} ${expected} 30 | fi 31 | error=0 32 | diff -q ${expected} ${output} || error=1 33 | if test "${error}" = "1"; then 34 | echo "Error in file:" ${input} 35 | ${DIFF} ${expected} ${output} 36 | fi 37 | done 38 | 39 | if test "${error_count}" = "0"; then 40 | pass_test 41 | else 42 | fail_test 43 | fi 44 | -------------------------------------------------------------------------------- /test/cli/update/data/stack-7.0.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-7.0 2 | 3 | extra-deps: [] 4 | 5 | packages: 6 | - '.' 7 | 8 | - location: 9 | git: https://github.com/erikd/wide-word 10 | commit: 354f9decd7019c026080820d2b120bf1b7c5f296 11 | extra-dep: true 12 | - location: 13 | git: https://github.com/haskell/stm 14 | commit: 18b5193660318df7617a6a99866b96b706fc2a86 15 | extra-dep: true 16 | -------------------------------------------------------------------------------- /test/cli/update/data/stack-9.1.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-9.1 2 | 3 | extra-deps: 4 | - directory-1.3.1.0 5 | 6 | packages: 7 | - '.' 8 | 9 | - location: 10 | git: https://github.com/erikd/wide-word 11 | commit: 8c3bd977856a0055abba8c78ad702bbe9a124154 12 | extra-dep: true 13 | -------------------------------------------------------------------------------- /test/cli/update/data/update.cabal: -------------------------------------------------------------------------------- 1 | name: update 2 | version: 0.0.0 3 | synopsis: A test project for jenga 4 | 5 | description: The simple combination of a simple cabal file and a stack.yaml file, 6 | but the the stack file specifies the stack resolver, some extra 7 | dependencies and a git submodule. 8 | 9 | license: MIT 10 | license-file: LICENSE 11 | author: Erik de Castro Lopo 12 | maintainer: erikd@mega-nerd.com 13 | category: Test 14 | build-type: Simple 15 | cabal-version: >= 1.10 16 | 17 | library 18 | ghc-options: -Wall -fwarn-tabs 19 | default-language: Haskell2010 20 | hs-source-dirs: src 21 | 22 | exposed-modules: Test.Jenga.Init.SubModules 23 | 24 | build-depends: base 25 | , binary 26 | , bytestring 27 | , containers 28 | , directory 29 | , exceptions 30 | , extra 31 | , filepath 32 | , time 33 | -------------------------------------------------------------------------------- /test/cli/update/expected/jenga-7.0.yaml: -------------------------------------------------------------------------------- 1 | { 2 | "submodule-dir": "lib", 3 | "mafia-lock": true, 4 | "submodules": [ 5 | { 6 | "hash": "354f9decd7019c026080820d2b120bf1b7c5f296", 7 | "path": "lib/wide-word", 8 | "url": "https://github.com/erikd/wide-word" 9 | }, 10 | { 11 | "hash": "18b5193660318df7617a6a99866b96b706fc2a86", 12 | "path": "lib/stm", 13 | "url": "https://github.com/haskell/stm" 14 | } 15 | ], 16 | "drop-deps": [] 17 | } 18 | -------------------------------------------------------------------------------- /test/cli/update/expected/jenga-9.1.yaml: -------------------------------------------------------------------------------- 1 | { 2 | "submodule-dir": "lib", 3 | "mafia-lock": true, 4 | "submodules": [ 5 | { 6 | "hash": "8c3bd977856a0055abba8c78ad702bbe9a124154", 7 | "path": "lib/wide-word", 8 | "url": "https://github.com/erikd/wide-word" 9 | } 10 | ], 11 | "drop-deps": [] 12 | } 13 | -------------------------------------------------------------------------------- /test/cli/update/expected/update.lock-8.0.1: -------------------------------------------------------------------------------- 1 | # mafia-lock-file-version: 0 2 | base == 4.9.0.0 3 | binary == 0.8.3.0 4 | bytestring == 0.10.8.1 5 | containers == 0.5.7.1 6 | directory == 1.2.6.2 7 | exceptions == 0.8.3 8 | extra == 1.4.10 9 | filepath == 1.4.1.0 10 | stm == 2.4.4.1 11 | time == 1.6.0.1 12 | wide-word == 0.1.0.4 13 | -------------------------------------------------------------------------------- /test/cli/update/expected/update.lock-8.0.2: -------------------------------------------------------------------------------- 1 | # mafia-lock-file-version: 0 2 | base == 4.9.1.0 3 | binary == 0.8.3.0 4 | bytestring == 0.10.8.1 5 | containers == 0.5.7.1 6 | directory == 1.3.1.0 7 | exceptions == 0.8.3 8 | extra == 1.5.3 9 | filepath == 1.4.1.1 10 | stm == 2.4.4.1 11 | time == 1.6.0.1 12 | wide-word == 0.1.0.5 13 | -------------------------------------------------------------------------------- /test/cli/update/run: -------------------------------------------------------------------------------- 1 | #!/bin/sh -eu 2 | 3 | # Create a repo using a stack.yaml file for lts-7.0. 4 | # Run `jenga init` to initialize the submodules ('wide-word` and 'stm'). 5 | # Check that the local '.jenga' file is as expected. 6 | # Check that the mafia lock file is as expected. 7 | # Update the 'stack.yaml' file to lts-9.1 (dropping the git version of 'stm'). 8 | # Run 'jenga upgrade' and make sure the 'stm' submodule gets removed. 9 | # Check that the local '.jenga' file has been updated as expected. 10 | # Check that the mafia lock file is as expected. 11 | 12 | . $(dirname $0)/../core/runner 13 | 14 | testname="update" 15 | 16 | banner "${testname}" 17 | #---------- 18 | 19 | INPUT_DIR=$(dirname $0)/data 20 | OUTPUT_DIR=${TEST} 21 | EXPECTED_DIR=$(dirname $0)/expected 22 | 23 | mkdir -p ${OUTPUT_DIR} 24 | 25 | cp -f ${INPUT_DIR}/* ${OUTPUT_DIR}/ 26 | rm -f ${OUTPUT_DIR}/stack*.yaml 27 | cp -f ${INPUT_DIR}/stack-7.0.yaml ${OUTPUT_DIR}/stack.yaml 28 | 29 | (cd ${OUTPUT_DIR} && \ 30 | git init && \ 31 | git add stack.yaml ${testname}.cabal && \ 32 | git commit -m "Initial commit" -- . && \ 33 | ${JENGA} init ) 34 | 35 | error=0 36 | assert_file_exists ${OUTPUT_DIR}/${testname}.lock-8.0.1 37 | assert_file_exists ${OUTPUT_DIR}/lib/stm/stm.cabal 38 | assert_file_exists ${OUTPUT_DIR}/lib/wide-word/wide-word.cabal 39 | assert_file_exists ${OUTPUT_DIR}/.jenga 40 | 41 | compare_files ${OUTPUT_DIR}/${testname}.lock-8.0.1 ${EXPECTED_DIR}/${testname}.lock-8.0.1 42 | compare_files ${OUTPUT_DIR}/.jenga ${EXPECTED_DIR}/jenga-7.0.yaml 43 | 44 | (cd ${OUTPUT_DIR} && \ 45 | git commit -m "Add submodules" -- . && \ 46 | ${JENGA} init ) 47 | 48 | # Update the stack version. 49 | cp -f ${INPUT_DIR}/stack-9.1.yaml ${OUTPUT_DIR}/stack.yaml 50 | 51 | (cd ${OUTPUT_DIR} && \ 52 | ${JENGA} update && \ 53 | git commit -m "Update stack resolver and wide-word, remove stm" -- . ) 54 | 55 | assert_file_exists ${OUTPUT_DIR}/lib/wide-word/wide-word.cabal 56 | assert_file_absent ${OUTPUT_DIR}/lib/stm/stm.cabal 57 | assert_file_exists ${OUTPUT_DIR}/${testname}.lock-8.0.2 58 | assert_file_exists ${OUTPUT_DIR}/.jenga 59 | 60 | compare_files ${OUTPUT_DIR}/${testname}.lock-8.0.2 ${EXPECTED_DIR}/${testname}.lock-8.0.2 61 | compare_files ${OUTPUT_DIR}/.jenga ${EXPECTED_DIR}/jenga-9.1.yaml 62 | 63 | if test "${error}" = "0"; then 64 | pass_test 65 | else 66 | fail_test 67 | fi 68 | -------------------------------------------------------------------------------- /test/test-cli.hs: -------------------------------------------------------------------------------- 1 | 2 | import Control.Monad (forM_) 3 | import System.Directory (listDirectory) 4 | import System.Process (callProcess) 5 | import System.IO (BufferMode (..)) 6 | import qualified System.IO as IO 7 | 8 | main :: IO () 9 | main = do 10 | IO.hSetBuffering IO.stdout LineBuffering 11 | IO.hSetBuffering IO.stderr LineBuffering 12 | testCliMain ["./dist/build/jenga/jenga"] 13 | 14 | testCliMain :: [String] -> IO () 15 | testCliMain args = do 16 | tests <- filter (`notElem` ["core", "data"]) <$> listDirectory "test/cli/" 17 | forM_ tests $ \ t -> callProcess ("test/cli/" ++ t ++ "/run") args 18 | -------------------------------------------------------------------------------- /test/test.hs: -------------------------------------------------------------------------------- 1 | 2 | import Control.Monad (unless) 3 | 4 | import System.IO (BufferMode (..), hSetBuffering, stdout, stderr) 5 | import System.Exit (exitFailure) 6 | 7 | import qualified Test.Jenga.Config 8 | import qualified Test.Jenga.Stack 9 | 10 | main :: IO () 11 | main = runTests 12 | [ Test.Jenga.Config.tests 13 | , Test.Jenga.Stack.tests 14 | ] 15 | 16 | runTests :: [IO Bool] -> IO () 17 | runTests tests = do 18 | hSetBuffering stdout LineBuffering 19 | hSetBuffering stderr LineBuffering 20 | 21 | results <- sequence tests 22 | unless (and results) 23 | exitFailure 24 | --------------------------------------------------------------------------------