Skip to content
This repository has been archived by the owner on Feb 3, 2020. It is now read-only.

Commit

Permalink
Avoid using the cabal-install executable commercialhaskell/stackage#1107
Browse files Browse the repository at this point in the history
  • Loading branch information
@snoyberg
snoyberg committed Jan 20, 2016
1 parent 810c410 commit 016e2da
Show file tree
Hide file tree
Showing 4 changed files with 88 additions and 35 deletions.
1 change: 1 addition & 0 deletions ChangeLog.md
View file
Original file line number Diff line number Diff line change
@@ -1,6 +1,7 @@
## 0.13.0

* build-tool-overrides
* Avoid using the cabal-install executable [stackage#1107](https://github.com/fpco/stackage/issues/1107)

## 0.12.0

Expand Down
7 changes: 1 addition & 6 deletions Stackage/CompleteBuild.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -485,12 +485,7 @@ fetch planFile = do
, version
, ".tar.gz"
]
fp = fromString $ cabalDir </>
"packages" </>
"hackage.haskell.org" </>
unpack name </>
unpack version </>
unpack (concat [name, "-", version, ".tar.gz"])
fp = sdistFilePath cabalDir name version

parMapM_ :: (MonadIO m, MonadBaseUnlift IO m, MonoFoldable mono)
=> Int
Expand Down
28 changes: 18 additions & 10 deletions Stackage/PackageIndex.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -17,6 +17,7 @@ module Stackage.PackageIndex
, SimplifiedPackageDescription (..)
, SimplifiedComponentInfo (..)
, getLatestDescriptions
, gpdFromLBS
) where

import qualified Codec.Archive.Tar as Tar
Expand Down Expand Up @@ -197,17 +198,24 @@ ucfParse root (UnparsedCabalFile name version fp lbs) = liftIO $ do
cache = root </> "cache" </> (unpack $ decodeUtf8 $ B16.encode $ SHA256.hashlazy lbs)

-- Parse the desc from the contents of the .cabal file
parseFromText =
case parsePackageDescription $ unpack $ dropBOM $ decodeUtf8 lbs of
ParseFailed e -> throwM $ CabalParseException fp e
ParseOk _warnings gpd -> do
let pd = packageDescription gpd
PackageIdentifier name' version' = package pd
when (name /= name' || version /= version') $
throwM $ MismatchedNameVersion fp
name name' version version'
return $ gpdToSpd gpd
parseFromText = do
gpd <- gpdFromLBS fp lbs
let pd = packageDescription gpd
PackageIdentifier name' version' = package pd
when (name /= name' || version /= version') $
throwM $ MismatchedNameVersion fp
name name' version version'
return $ gpdToSpd gpd

gpdFromLBS :: MonadThrow m
=> FilePath
-> LByteString
-> m GenericPackageDescription
gpdFromLBS fp lbs =
case parsePackageDescription $ unpack $ dropBOM $ decodeUtf8 lbs of
ParseFailed e -> throwM $ CabalParseException fp e
ParseOk _warnings gpd -> return gpd
where
-- https://github.com/haskell/hackage-server/issues/351
dropBOM t = fromMaybe t $ stripPrefix "\xFEFF" t

Expand Down
87 changes: 68 additions & 19 deletions Stackage/PerformBuild.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -11,13 +11,15 @@ module Stackage.PerformBuild
, PerformBuild (..)
, BuildException (..)
, pbDocDir
, sdistFilePath
) where

import Control.Concurrent.Async (async)
import Control.Concurrent.STM.TSem
import Control.Monad.Writer.Strict (execWriter, tell)
import qualified Data.Map as Map
import Data.NonNull (fromNullable)
import Distribution.PackageDescription (buildType, packageDescription, BuildType (Simple))
import Filesystem (canonicalizePath, createTree,
getWorkingDirectory,
removeTree, rename, removeFile)
Expand All @@ -27,8 +29,10 @@ import Stackage.BuildConstraints
import Stackage.BuildPlan
import Stackage.GhcPkg
import Stackage.PackageDescription
import Stackage.PackageIndex (gpdFromLBS)
import Stackage.Prelude hiding (pi)
import System.Directory (doesDirectoryExist, doesFileExist, findExecutable)
import System.Directory (doesDirectoryExist, doesFileExist, findExecutable,
getAppUserDataDirectory)
import qualified System.FilePath as FP
import System.Environment (getEnvironment)
import System.Exit
Expand Down Expand Up @@ -265,29 +269,31 @@ data SingleBuild = SingleBuild
singleBuild :: PerformBuild
-> Set PackageName -- ^ registered packages
-> SingleBuild -> IO ()
singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} =
withCounter sbActive
$ handle updateErrs
$ (`finally` void (atomically $ tryPutTMVar (piResult sbPackageInfo) False))
$ inner
singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} = do
cabalDir <- getAppUserDataDirectory "cabal"
withCounter sbActive
$ handle updateErrs
$ (`finally` void (atomically $ tryPutTMVar (piResult sbPackageInfo) False))
$ inner cabalDir
where
libComps = setFromList [CompLibrary, CompExecutable]
testComps = insertSet CompTestSuite libComps
inner = do
inner cabalDir = do
let wfd comps =
waitForDeps sbToolMap sbPackageMap comps pbPlan sbPackageInfo
. withTSem sbSem
withUnpacked <- wfd libComps buildLibrary
withUnpacked <- wfd libComps (buildLibrary cabalDir)

wfd testComps (runTests withUnpacked)

pname = piName sbPackageInfo
pident = PackageIdentifier pname (ppVersion $ piPlan sbPackageInfo)
name = display pname
version = display $ ppVersion $ piPlan sbPackageInfo
namever = concat
[ name
, "-"
, display $ ppVersion $ piPlan sbPackageInfo
, version
]

runIn wdir getOutH cmd args = do
Expand Down Expand Up @@ -369,23 +375,29 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} =

hasLib = not $ null $ sdModules $ ppDesc $ piPlan sbPackageInfo

buildLibrary = wf libOut $ \getOutH -> do
buildLibrary cabalDir = wf libOut $ \getOutH -> do
let run a b = do when pbVerbose $ log' (unwords (a : b))
runChild getOutH a b
cabal args = run "runghc" $ "Setup" : args

isUnpacked <- newIORef False
let withUnpacked inner' = do
unlessM (readIORef isUnpacked) $ do
log' $ "Unpacking " ++ namever
runParent getOutH "cabal" ["unpack", namever]
runParent getOutH "tar"
[ "xzf"
, sdistFilePath cabalDir name version
]

createSetupHs childDir name
writeIORef isUnpacked True
inner'

isConfiged <- newIORef False
let withConfiged inner' = withUnpacked $ do
unlessM (readIORef isConfiged) $ do
log' $ "Configuring " ++ namever
run "cabal" $ "configure" : configArgs
cabal $ "configure" : configArgs
writeIORef isConfiged True
inner'

Expand All @@ -406,12 +418,12 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} =
deletePreviousResults pb pident

log' $ "Building " ++ namever
run "cabal" ["build"]
cabal ["build"]

log' $ "Copying/registering " ++ namever
run "cabal" ["copy"]
cabal ["copy"]
withMVar sbRegisterMutex $ const $
run "cabal" ["register"]
cabal ["register"]

savePreviousResult pb Build pident True

Expand Down Expand Up @@ -458,7 +470,7 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} =
when pbBuildHoogle $ tell' "--hoogle"
tell' "--html-location=../$pkg-$version/"

eres <- tryAny $ run "cabal" args
eres <- tryAny $ cabal args

forM_ eres $ \() -> do
renameOrCopy
Expand Down Expand Up @@ -487,21 +499,22 @@ singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} =

runTests withUnpacked = wf testOut $ \getOutH -> do
let run = runChild getOutH
cabal args = run "runghc" $ "Setup" : args

prevTestResult <- getPreviousResult pb Test pident
let needTest = pbEnableTests
&& checkPrevResult prevTestResult pcTests
&& not pcSkipBuild
when needTest $ withUnpacked $ do
log' $ "Test configure " ++ namever
run "cabal" $ "configure" : "--enable-tests" : configArgs
cabal $ "configure" : "--enable-tests" : configArgs

eres <- tryAny $ do
log' $ "Test build " ++ namever
run "cabal" ["build"]
cabal ["build"]

log' $ "Test run " ++ namever
run "cabal" ["test", "--log=" ++ pack testRunOut]
cabal ["test", "--log=" ++ pack testRunOut]

savePreviousResult pb Test pident $ either (const False) (const True) eres
case (eres, pcTests) of
Expand Down Expand Up @@ -646,3 +659,39 @@ getHaddockDeps BuildPlan {..} var =
isLibExe DepInfo {..} =
CompLibrary `member` diComponents ||
CompExecutable `member` diComponents

sdistFilePath :: IsString filepath
=> FilePath -- ^ cabal directory
-> Text -- ^ package name
-> Text -- ^ package name
-> filepath
sdistFilePath cabalDir name version = fromString
$ cabalDir
</> "packages"
</> "hackage.haskell.org"
</> unpack name
</> unpack version
</> unpack (concat [name, "-", version, ".tar.gz"])

-- | Create a default Setup.hs file if the given directory is a simple build plan
--
-- Also deletes any Setup.lhs if necessary
createSetupHs :: FilePath
-> Text -- ^ package name
-> IO ()
createSetupHs dir name = do
simple <- isSimple cabalFP
when simple $ do
_ <- tryIO $ removeFile $ fromString setuplhs
writeFile setuphs $ asByteString "import Distribution.Simple\nmain = defaultMain\n"
where
cabalFP = dir </> unpack name <.> "cabal"
setuphs = dir </> "Setup.hs"
setuplhs = dir </> "Setup.lhs"

-- | Check if the given cabal file has a simple build plan
isSimple :: FilePath -> IO Bool
isSimple fp = do
bs <- readFile fp
gpd <- gpdFromLBS fp (fromStrict bs)
return $ buildType (packageDescription gpd) == Just Simple

0 comments on commit 016e2da

Please sign in to comment.