diff --git a/Control/Concurrent/STM.hs b/Control/Concurrent/STM.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/STM.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE CPP #-} + +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Trustworthy #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Concurrent.STM +-- Copyright : (c) The University of Glasgow 2004 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (requires STM) +-- +-- Software Transactional Memory: a modular composable concurrency +-- abstraction. See +-- +-- * /Composable memory transactions/, by Tim Harris, Simon Marlow, Simon +-- Peyton Jones, and Maurice Herlihy, in /ACM Conference on Principles +-- and Practice of Parallel Programming/ 2005. +-- +-- +----------------------------------------------------------------------------- + +module Control.Concurrent.STM ( + module Control.Monad.STM, + module Control.Concurrent.STM.TVar, +#ifdef __GLASGOW_HASKELL__ + module Control.Concurrent.STM.TMVar, + module Control.Concurrent.STM.TChan, + module Control.Concurrent.STM.TQueue, + module Control.Concurrent.STM.TBQueue, +#endif + module Control.Concurrent.STM.TArray + ) where + +import Control.Monad.STM +import Control.Concurrent.STM.TVar +#ifdef __GLASGOW_HASKELL__ +import Control.Concurrent.STM.TMVar +import Control.Concurrent.STM.TChan +#endif +import Control.Concurrent.STM.TArray +import Control.Concurrent.STM.TQueue +import Control.Concurrent.STM.TBQueue diff --git a/Control/Concurrent/STM/TArray.hs b/Control/Concurrent/STM/TArray.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/STM/TArray.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses #-} + +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Trustworthy #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Concurrent.STM.TArray +-- Copyright : (c) The University of Glasgow 2005 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (requires STM) +-- +-- TArrays: transactional arrays, for use in the STM monad +-- +----------------------------------------------------------------------------- + +module Control.Concurrent.STM.TArray ( + TArray +) where + +import Data.Array (Array, bounds) +import Data.Array.Base (listArray, arrEleBottom, unsafeAt, MArray(..), + IArray(numElements)) +import Data.Ix (rangeSize) +import Data.Typeable (Typeable) +import Control.Concurrent.STM.TVar (TVar, newTVar, readTVar, writeTVar) +#ifdef __GLASGOW_HASKELL__ +import GHC.Conc (STM) +#else +import Control.Sequential.STM (STM) +#endif + +-- |TArray is a transactional array, supporting the usual 'MArray' +-- interface for mutable arrays. +-- +-- It is currently implemented as @Array ix (TVar e)@, +-- but it may be replaced by a more efficient implementation in the future +-- (the interface will remain the same, however). +-- +newtype TArray i e = TArray (Array i (TVar e)) deriving (Eq, Typeable) + +instance MArray TArray e STM where + getBounds (TArray a) = return (bounds a) + newArray b e = do + a <- rep (rangeSize b) (newTVar e) + return $ TArray (listArray b a) + newArray_ b = do + a <- rep (rangeSize b) (newTVar arrEleBottom) + return $ TArray (listArray b a) + unsafeRead (TArray a) i = readTVar $ unsafeAt a i + unsafeWrite (TArray a) i e = writeTVar (unsafeAt a i) e + getNumElements (TArray a) = return (numElements a) + +-- | Like 'replicateM' but uses an accumulator to prevent stack overflows. +-- Unlike 'replicateM' the returned list is in reversed order. +-- This doesn't matter though since this function is only used to create +-- arrays with identical elements. +rep :: Monad m => Int -> m a -> m [a] +rep n m = go n [] + where + go 0 xs = return xs + go i xs = do + x <- m + go (i-1) (x:xs) diff --git a/Control/Concurrent/STM/TBQueue.hs b/Control/Concurrent/STM/TBQueue.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/STM/TBQueue.hs @@ -0,0 +1,179 @@ +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# LANGUAGE CPP, DeriveDataTypeable #-} + +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Trustworthy #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Concurrent.STM.TBQueue +-- Copyright : (c) The University of Glasgow 2012 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (requires STM) +-- +-- 'TBQueue' is a bounded version of 'TQueue'. The queue has a maximum +-- capacity set when it is created. If the queue already contains the +-- maximum number of elements, then 'writeTBQueue' blocks until an +-- element is removed from the queue. +-- +-- The implementation is based on the traditional purely-functional +-- queue representation that uses two lists to obtain amortised /O(1)/ +-- enqueue and dequeue operations. +-- +----------------------------------------------------------------------------- + +module Control.Concurrent.STM.TBQueue ( + -- * TBQueue + TBQueue, + newTBQueue, + newTBQueueIO, + readTBQueue, + tryReadTBQueue, + peekTBQueue, + tryPeekTBQueue, + writeTBQueue, + unGetTBQueue, + isEmptyTBQueue, + ) where + +import Data.Typeable +import GHC.Conc + +#define _UPK_(x) {-# UNPACK #-} !(x) + +-- | 'TBQueue' is an abstract type representing a bounded FIFO channel. +data TBQueue a + = TBQueue _UPK_(TVar Int) -- CR: read capacity + _UPK_(TVar [a]) -- R: elements waiting to be read + _UPK_(TVar Int) -- CW: write capacity + _UPK_(TVar [a]) -- W: elements written (head is most recent) + deriving Typeable + +instance Eq (TBQueue a) where + TBQueue a _ _ _ == TBQueue b _ _ _ = a == b + +-- Total channel capacity remaining is CR + CW. Reads only need to +-- access CR, writes usually need to access only CW but sometimes need +-- CR. So in the common case we avoid contention between CR and CW. +-- +-- - when removing an element from R: +-- CR := CR + 1 +-- +-- - when adding an element to W: +-- if CW is non-zero +-- then CW := CW - 1 +-- then if CR is non-zero +-- then CW := CR - 1; CR := 0 +-- else **FULL** + +-- |Build and returns a new instance of 'TBQueue' +newTBQueue :: Int -- ^ maximum number of elements the queue can hold + -> STM (TBQueue a) +newTBQueue size = do + read <- newTVar [] + write <- newTVar [] + rsize <- newTVar 0 + wsize <- newTVar size + return (TBQueue rsize read wsize write) + +-- |@IO@ version of 'newTBQueue'. This is useful for creating top-level +-- 'TBQueue's using 'System.IO.Unsafe.unsafePerformIO', because using +-- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't +-- possible. +newTBQueueIO :: Int -> IO (TBQueue a) +newTBQueueIO size = do + read <- newTVarIO [] + write <- newTVarIO [] + rsize <- newTVarIO 0 + wsize <- newTVarIO size + return (TBQueue rsize read wsize write) + +-- |Write a value to a 'TBQueue'; blocks if the queue is full. +writeTBQueue :: TBQueue a -> a -> STM () +writeTBQueue (TBQueue rsize _read wsize write) a = do + w <- readTVar wsize + if (w /= 0) + then do writeTVar wsize (w - 1) + else do + r <- readTVar rsize + if (r /= 0) + then do writeTVar rsize 0 + writeTVar wsize (r - 1) + else retry + listend <- readTVar write + writeTVar write (a:listend) + +-- |Read the next value from the 'TBQueue'. +readTBQueue :: TBQueue a -> STM a +readTBQueue (TBQueue rsize read _wsize write) = do + xs <- readTVar read + r <- readTVar rsize + writeTVar rsize (r + 1) + case xs of + (x:xs') -> do + writeTVar read xs' + return x + [] -> do + ys <- readTVar write + case ys of + [] -> retry + _ -> do + let (z:zs) = reverse ys -- NB. lazy: we want the transaction to be + -- short, otherwise it will conflict + writeTVar write [] + writeTVar read zs + return z + +-- | A version of 'readTBQueue' which does not retry. Instead it +-- returns @Nothing@ if no value is available. +tryReadTBQueue :: TBQueue a -> STM (Maybe a) +tryReadTBQueue c = fmap Just (readTBQueue c) `orElse` return Nothing + +-- | Get the next value from the @TBQueue@ without removing it, +-- retrying if the channel is empty. +peekTBQueue :: TBQueue a -> STM a +peekTBQueue c = do + x <- readTBQueue c + unGetTBQueue c x + return x + +-- | A version of 'peekTBQueue' which does not retry. Instead it +-- returns @Nothing@ if no value is available. +tryPeekTBQueue :: TBQueue a -> STM (Maybe a) +tryPeekTBQueue c = do + m <- tryReadTBQueue c + case m of + Nothing -> return Nothing + Just x -> do + unGetTBQueue c x + return m + +-- |Put a data item back onto a channel, where it will be the next item read. +-- Blocks if the queue is full. +unGetTBQueue :: TBQueue a -> a -> STM () +unGetTBQueue (TBQueue rsize read wsize _write) a = do + r <- readTVar rsize + if (r > 0) + then do writeTVar rsize (r - 1) + else do + w <- readTVar wsize + if (w > 0) + then writeTVar wsize (w - 1) + else retry + xs <- readTVar read + writeTVar read (a:xs) + +-- |Returns 'True' if the supplied 'TBQueue' is empty. +isEmptyTBQueue :: TBQueue a -> STM Bool +isEmptyTBQueue (TBQueue _rsize read _wsize write) = do + xs <- readTVar read + case xs of + (_:_) -> return False + [] -> do ys <- readTVar write + case ys of + [] -> return True + _ -> return False diff --git a/Control/Concurrent/STM/TChan.hs b/Control/Concurrent/STM/TChan.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/STM/TChan.hs @@ -0,0 +1,198 @@ +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# LANGUAGE CPP, DeriveDataTypeable #-} + +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Trustworthy #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Concurrent.STM.TChan +-- Copyright : (c) The University of Glasgow 2004 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (requires STM) +-- +-- TChan: Transactional channels +-- (GHC only) +-- +----------------------------------------------------------------------------- + +module Control.Concurrent.STM.TChan ( +#ifdef __GLASGOW_HASKELL__ + -- * TChans + TChan, + + -- ** Construction + newTChan, + newTChanIO, + newBroadcastTChan, + newBroadcastTChanIO, + dupTChan, + + -- ** Reading and writing + readTChan, + tryReadTChan, + peekTChan, + tryPeekTChan, + writeTChan, + unGetTChan, + isEmptyTChan, + cloneTChan +#endif + ) where + +#ifdef __GLASGOW_HASKELL__ +import GHC.Conc + +import Data.Typeable (Typeable) + +#define _UPK_(x) {-# UNPACK #-} !(x) + +-- | 'TChan' is an abstract type representing an unbounded FIFO channel. +data TChan a = TChan _UPK_(TVar (TVarList a)) + _UPK_(TVar (TVarList a)) + deriving (Eq, Typeable) + +type TVarList a = TVar (TList a) +data TList a = TNil | TCons a _UPK_(TVarList a) + +-- |Build and return a new instance of 'TChan' +newTChan :: STM (TChan a) +newTChan = do + hole <- newTVar TNil + read <- newTVar hole + write <- newTVar hole + return (TChan read write) + +-- |@IO@ version of 'newTChan'. This is useful for creating top-level +-- 'TChan's using 'System.IO.Unsafe.unsafePerformIO', because using +-- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't +-- possible. +newTChanIO :: IO (TChan a) +newTChanIO = do + hole <- newTVarIO TNil + read <- newTVarIO hole + write <- newTVarIO hole + return (TChan read write) + +-- | Create a write-only 'TChan'. More precisely, 'readTChan' will 'retry' +-- even after items have been written to the channel. The only way to read +-- a broadcast channel is to duplicate it with 'dupTChan'. +-- +-- Consider a server that broadcasts messages to clients: +-- +-- >serve :: TChan Message -> Client -> IO loop +-- >serve broadcastChan client = do +-- > myChan <- dupTChan broadcastChan +-- > forever $ do +-- > message <- readTChan myChan +-- > send client message +-- +-- The problem with using 'newTChan' to create the broadcast channel is that if +-- it is only written to and never read, items will pile up in memory. By +-- using 'newBroadcastTChan' to create the broadcast channel, items can be +-- garbage collected after clients have seen them. +newBroadcastTChan :: STM (TChan a) +newBroadcastTChan = do + write_hole <- newTVar TNil + read <- newTVar (error "reading from a TChan created by newBroadcastTChan; use dupTChan first") + write <- newTVar write_hole + return (TChan read write) + +-- | @IO@ version of 'newBroadcastTChan'. +newBroadcastTChanIO :: IO (TChan a) +newBroadcastTChanIO = do + dummy_hole <- newTVarIO TNil + write_hole <- newTVarIO TNil + read <- newTVarIO dummy_hole + write <- newTVarIO write_hole + return (TChan read write) + +-- |Write a value to a 'TChan'. +writeTChan :: TChan a -> a -> STM () +writeTChan (TChan _read write) a = do + listend <- readTVar write -- listend == TVar pointing to TNil + new_listend <- newTVar TNil + writeTVar listend (TCons a new_listend) + writeTVar write new_listend + +-- |Read the next value from the 'TChan'. +readTChan :: TChan a -> STM a +readTChan (TChan read _write) = do + listhead <- readTVar read + head <- readTVar listhead + case head of + TNil -> retry + TCons a tail -> do + writeTVar read tail + return a + +-- | A version of 'readTChan' which does not retry. Instead it +-- returns @Nothing@ if no value is available. +tryReadTChan :: TChan a -> STM (Maybe a) +tryReadTChan (TChan read _write) = do + listhead <- readTVar read + head <- readTVar listhead + case head of + TNil -> return Nothing + TCons a tl -> do + writeTVar read tl + return (Just a) + +-- | Get the next value from the @TChan@ without removing it, +-- retrying if the channel is empty. +peekTChan :: TChan a -> STM a +peekTChan (TChan read _write) = do + listhead <- readTVar read + head <- readTVar listhead + case head of + TNil -> retry + TCons a _ -> return a + +-- | A version of 'peekTChan' which does not retry. Instead it +-- returns @Nothing@ if no value is available. +tryPeekTChan :: TChan a -> STM (Maybe a) +tryPeekTChan (TChan read _write) = do + listhead <- readTVar read + head <- readTVar listhead + case head of + TNil -> return Nothing + TCons a _ -> return (Just a) + +-- |Duplicate a 'TChan': the duplicate channel begins empty, but data written to +-- either channel from then on will be available from both. Hence this creates +-- a kind of broadcast channel, where data written by anyone is seen by +-- everyone else. +dupTChan :: TChan a -> STM (TChan a) +dupTChan (TChan _read write) = do + hole <- readTVar write + new_read <- newTVar hole + return (TChan new_read write) + +-- |Put a data item back onto a channel, where it will be the next item read. +unGetTChan :: TChan a -> a -> STM () +unGetTChan (TChan read _write) a = do + listhead <- readTVar read + newhead <- newTVar (TCons a listhead) + writeTVar read newhead + +-- |Returns 'True' if the supplied 'TChan' is empty. +isEmptyTChan :: TChan a -> STM Bool +isEmptyTChan (TChan read _write) = do + listhead <- readTVar read + head <- readTVar listhead + case head of + TNil -> return True + TCons _ _ -> return False + +-- |Clone a 'TChan': similar to dupTChan, but the cloned channel starts with the +-- same content available as the original channel. +cloneTChan :: TChan a -> STM (TChan a) +cloneTChan (TChan read write) = do + readpos <- readTVar read + new_read <- newTVar readpos + return (TChan new_read write) +#endif diff --git a/Control/Concurrent/STM/TMVar.hs b/Control/Concurrent/STM/TMVar.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/STM/TMVar.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE CPP, DeriveDataTypeable #-} + +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Trustworthy #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Concurrent.STM.TMVar +-- Copyright : (c) The University of Glasgow 2004 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (requires STM) +-- +-- TMVar: Transactional MVars, for use in the STM monad +-- (GHC only) +-- +----------------------------------------------------------------------------- + +module Control.Concurrent.STM.TMVar ( +#ifdef __GLASGOW_HASKELL__ + -- * TMVars + TMVar, + newTMVar, + newEmptyTMVar, + newTMVarIO, + newEmptyTMVarIO, + takeTMVar, + putTMVar, + readTMVar, + tryReadTMVar, + swapTMVar, + tryTakeTMVar, + tryPutTMVar, + isEmptyTMVar +#endif + ) where + +#ifdef __GLASGOW_HASKELL__ +import GHC.Conc + +import Data.Typeable (Typeable) + +newtype TMVar a = TMVar (TVar (Maybe a)) deriving (Eq, Typeable) +{- ^ +A 'TMVar' is a synchronising variable, used +for communication between concurrent threads. It can be thought of +as a box, which may be empty or full. +-} + +-- |Create a 'TMVar' which contains the supplied value. +newTMVar :: a -> STM (TMVar a) +newTMVar a = do + t <- newTVar (Just a) + return (TMVar t) + +-- |@IO@ version of 'newTMVar'. This is useful for creating top-level +-- 'TMVar's using 'System.IO.Unsafe.unsafePerformIO', because using +-- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't +-- possible. +newTMVarIO :: a -> IO (TMVar a) +newTMVarIO a = do + t <- newTVarIO (Just a) + return (TMVar t) + +-- |Create a 'TMVar' which is initially empty. +newEmptyTMVar :: STM (TMVar a) +newEmptyTMVar = do + t <- newTVar Nothing + return (TMVar t) + +-- |@IO@ version of 'newEmptyTMVar'. This is useful for creating top-level +-- 'TMVar's using 'System.IO.Unsafe.unsafePerformIO', because using +-- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't +-- possible. +newEmptyTMVarIO :: IO (TMVar a) +newEmptyTMVarIO = do + t <- newTVarIO Nothing + return (TMVar t) + +-- |Return the contents of the 'TMVar'. If the 'TMVar' is currently +-- empty, the transaction will 'retry'. After a 'takeTMVar', +-- the 'TMVar' is left empty. +takeTMVar :: TMVar a -> STM a +takeTMVar (TMVar t) = do + m <- readTVar t + case m of + Nothing -> retry + Just a -> do writeTVar t Nothing; return a + +-- | A version of 'takeTMVar' that does not 'retry'. The 'tryTakeTMVar' +-- function returns 'Nothing' if the 'TMVar' was empty, or @'Just' a@ if +-- the 'TMVar' was full with contents @a@. After 'tryTakeTMVar', the +-- 'TMVar' is left empty. +tryTakeTMVar :: TMVar a -> STM (Maybe a) +tryTakeTMVar (TMVar t) = do + m <- readTVar t + case m of + Nothing -> return Nothing + Just a -> do writeTVar t Nothing; return (Just a) + +-- |Put a value into a 'TMVar'. If the 'TMVar' is currently full, +-- 'putTMVar' will 'retry'. +putTMVar :: TMVar a -> a -> STM () +putTMVar (TMVar t) a = do + m <- readTVar t + case m of + Nothing -> do writeTVar t (Just a); return () + Just _ -> retry + +-- | A version of 'putTMVar' that does not 'retry'. The 'tryPutTMVar' +-- function attempts to put the value @a@ into the 'TMVar', returning +-- 'True' if it was successful, or 'False' otherwise. +tryPutTMVar :: TMVar a -> a -> STM Bool +tryPutTMVar (TMVar t) a = do + m <- readTVar t + case m of + Nothing -> do writeTVar t (Just a); return True + Just _ -> return False + +-- | This is a combination of 'takeTMVar' and 'putTMVar'; ie. it +-- takes the value from the 'TMVar', puts it back, and also returns +-- it. +readTMVar :: TMVar a -> STM a +readTMVar (TMVar t) = do + m <- readTVar t + case m of + Nothing -> retry + Just a -> return a + +-- | A version of 'readTMVar' which does not retry. Instead it +-- returns @Nothing@ if no value is available. +tryReadTMVar :: TMVar a -> STM (Maybe a) +tryReadTMVar (TMVar t) = readTVar t + +-- |Swap the contents of a 'TMVar' for a new value. +swapTMVar :: TMVar a -> a -> STM a +swapTMVar (TMVar t) new = do + m <- readTVar t + case m of + Nothing -> retry + Just old -> do writeTVar t (Just new); return old + +-- |Check whether a given 'TMVar' is empty. +isEmptyTMVar :: TMVar a -> STM Bool +isEmptyTMVar (TMVar t) = do + m <- readTVar t + case m of + Nothing -> return True + Just _ -> return False +#endif diff --git a/Control/Concurrent/STM/TQueue.hs b/Control/Concurrent/STM/TQueue.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/STM/TQueue.hs @@ -0,0 +1,137 @@ +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# LANGUAGE CPP, DeriveDataTypeable #-} + +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Trustworthy #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Concurrent.STM.TQueue +-- Copyright : (c) The University of Glasgow 2012 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (requires STM) +-- +-- A 'TQueue' is like a 'TChan', with two important differences: +-- +-- * it has faster throughput than both 'TChan' and 'Chan' (although +-- the costs are amortised, so the cost of individual operations +-- can vary a lot). +-- +-- * it does /not/ provide equivalents of the 'dupTChan' and +-- 'cloneTChan' operations. +-- +-- The implementation is based on the traditional purely-functional +-- queue representation that uses two lists to obtain amortised /O(1)/ +-- enqueue and dequeue operations. +-- +----------------------------------------------------------------------------- + +module Control.Concurrent.STM.TQueue ( + -- * TQueue + TQueue, + newTQueue, + newTQueueIO, + readTQueue, + tryReadTQueue, + peekTQueue, + tryPeekTQueue, + writeTQueue, + unGetTQueue, + isEmptyTQueue, + ) where + +import GHC.Conc + +import Data.Typeable (Typeable) + +-- | 'TQueue' is an abstract type representing an unbounded FIFO channel. +data TQueue a = TQueue {-# UNPACK #-} !(TVar [a]) + {-# UNPACK #-} !(TVar [a]) + deriving Typeable + +instance Eq (TQueue a) where + TQueue a _ == TQueue b _ = a == b + +-- |Build and returns a new instance of 'TQueue' +newTQueue :: STM (TQueue a) +newTQueue = do + read <- newTVar [] + write <- newTVar [] + return (TQueue read write) + +-- |@IO@ version of 'newTQueue'. This is useful for creating top-level +-- 'TQueue's using 'System.IO.Unsafe.unsafePerformIO', because using +-- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't +-- possible. +newTQueueIO :: IO (TQueue a) +newTQueueIO = do + read <- newTVarIO [] + write <- newTVarIO [] + return (TQueue read write) + +-- |Write a value to a 'TQueue'. +writeTQueue :: TQueue a -> a -> STM () +writeTQueue (TQueue _read write) a = do + listend <- readTVar write + writeTVar write (a:listend) + +-- |Read the next value from the 'TQueue'. +readTQueue :: TQueue a -> STM a +readTQueue (TQueue read write) = do + xs <- readTVar read + case xs of + (x:xs') -> do writeTVar read xs' + return x + [] -> do ys <- readTVar write + case ys of + [] -> retry + _ -> case reverse ys of + [] -> error "readTQueue" + (z:zs) -> do writeTVar write [] + writeTVar read zs + return z + +-- | A version of 'readTQueue' which does not retry. Instead it +-- returns @Nothing@ if no value is available. +tryReadTQueue :: TQueue a -> STM (Maybe a) +tryReadTQueue c = fmap Just (readTQueue c) `orElse` return Nothing + +-- | Get the next value from the @TQueue@ without removing it, +-- retrying if the channel is empty. +peekTQueue :: TQueue a -> STM a +peekTQueue c = do + x <- readTQueue c + unGetTQueue c x + return x + +-- | A version of 'peekTQueue' which does not retry. Instead it +-- returns @Nothing@ if no value is available. +tryPeekTQueue :: TQueue a -> STM (Maybe a) +tryPeekTQueue c = do + m <- tryReadTQueue c + case m of + Nothing -> return Nothing + Just x -> do + unGetTQueue c x + return m + +-- |Put a data item back onto a channel, where it will be the next item read. +unGetTQueue :: TQueue a -> a -> STM () +unGetTQueue (TQueue read _write) a = do + xs <- readTVar read + writeTVar read (a:xs) + +-- |Returns 'True' if the supplied 'TQueue' is empty. +isEmptyTQueue :: TQueue a -> STM Bool +isEmptyTQueue (TQueue read write) = do + xs <- readTVar read + case xs of + (_:_) -> return False + [] -> do ys <- readTVar write + case ys of + [] -> return True + _ -> return False diff --git a/Control/Concurrent/STM/TVar.hs b/Control/Concurrent/STM/TVar.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/STM/TVar.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE CPP #-} + +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Trustworthy #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Concurrent.STM.TVar +-- Copyright : (c) The University of Glasgow 2004 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (requires STM) +-- +-- TVar: Transactional variables +-- +----------------------------------------------------------------------------- + +module Control.Concurrent.STM.TVar ( + -- * TVars + TVar, + newTVar, + newTVarIO, + readTVar, + readTVarIO, + writeTVar, + modifyTVar, + modifyTVar', + swapTVar, +#ifdef __GLASGOW_HASKELL__ + registerDelay +#endif + ) where + +#ifdef __GLASGOW_HASKELL__ +import GHC.Conc +#else +import Control.Sequential.STM +#endif + +#if ! (MIN_VERSION_base(4,2,0)) +readTVarIO = atomically . readTVar +#endif + + +-- Like 'modifyIORef' but for 'TVar'. +-- | Mutate the contents of a 'TVar'. /N.B./, this version is +-- non-strict. +modifyTVar :: TVar a -> (a -> a) -> STM () +modifyTVar var f = do + x <- readTVar var + writeTVar var (f x) +{-# INLINE modifyTVar #-} + + +-- | Strict version of 'modifyTVar'. +modifyTVar' :: TVar a -> (a -> a) -> STM () +modifyTVar' var f = do + x <- readTVar var + writeTVar var $! f x +{-# INLINE modifyTVar' #-} + + +-- Like 'swapTMVar' but for 'TVar'. +-- | Swap the contents of a 'TVar' for a new value. +swapTVar :: TVar a -> a -> STM a +swapTVar var new = do + old <- readTVar var + writeTVar var new + return old +{-# INLINE swapTVar #-} + diff --git a/Control/Monad/STM.hs b/Control/Monad/STM.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/STM.hs @@ -0,0 +1,126 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-} + +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Trustworthy #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.STM +-- Copyright : (c) The University of Glasgow 2004 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (requires STM) +-- +-- Software Transactional Memory: a modular composable concurrency +-- abstraction. See +-- +-- * /Composable memory transactions/, by Tim Harris, Simon Marlow, Simon +-- Peyton Jones, and Maurice Herlihy, in /ACM Conference on Principles +-- and Practice of Parallel Programming/ 2005. +-- +-- +-- This module only defines the 'STM' monad; you probably want to +-- import "Control.Concurrent.STM" (which exports "Control.Monad.STM"). +----------------------------------------------------------------------------- + +module Control.Monad.STM ( + STM, + atomically, +#ifdef __GLASGOW_HASKELL__ + always, + alwaysSucceeds, + retry, + orElse, + check, +#endif + throwSTM, + catchSTM + ) where + +#ifdef __GLASGOW_HASKELL__ +#if ! (MIN_VERSION_base(4,3,0)) +import GHC.Conc hiding (catchSTM) +import Control.Monad ( MonadPlus(..) ) +import Control.Exception +#else +import GHC.Conc +#endif +import GHC.Exts +import Control.Monad.Fix +#else +import Control.Sequential.STM +#endif + +#ifdef __GLASGOW_HASKELL__ +#if ! (MIN_VERSION_base(4,3,0)) +import Control.Applicative +import Control.Monad (ap) +#endif +#endif + + +#ifdef __GLASGOW_HASKELL__ +#if ! (MIN_VERSION_base(4,3,0)) +instance MonadPlus STM where + mzero = retry + mplus = orElse + +instance Applicative STM where + pure = return + (<*>) = ap + +instance Alternative STM where + empty = retry + (<|>) = orElse +#endif + +check :: Bool -> STM () +check b = if b then return () else retry +#endif + +#if ! (MIN_VERSION_base(4,3,0)) +-- |Exception handling within STM actions. +catchSTM :: Exception e => STM a -> (e -> STM a) -> STM a +catchSTM (STM m) handler = STM $ catchSTM# m handler' + where + handler' e = case fromException e of + Just e' -> case handler e' of STM m' -> m' + Nothing -> raiseIO# e + +-- | A variant of 'throw' that can only be used within the 'STM' monad. +-- +-- Throwing an exception in @STM@ aborts the transaction and propagates the +-- exception. +-- +-- Although 'throwSTM' has a type that is an instance of the type of 'throw', the +-- two functions are subtly different: +-- +-- > throw e `seq` x ===> throw e +-- > throwSTM e `seq` x ===> x +-- +-- The first example will cause the exception @e@ to be raised, +-- whereas the second one won\'t. In fact, 'throwSTM' will only cause +-- an exception to be raised when it is used within the 'STM' monad. +-- The 'throwSTM' variant should be used in preference to 'throw' to +-- raise an exception within the 'STM' monad because it guarantees +-- ordering with respect to other 'STM' operations, whereas 'throw' +-- does not. +throwSTM :: Exception e => e -> STM a +throwSTM e = STM $ raiseIO# (toException e) +#endif + + +data STMret a = STMret (State# RealWorld) a + +liftSTM :: STM a -> State# RealWorld -> STMret a +liftSTM (STM m) = \s -> case m s of (# s', r #) -> STMret s' r + +instance MonadFix STM where + mfix k = STM $ \s -> + let ans = liftSTM (k r) s + STMret _ r = ans + in case ans of STMret s' x -> (# s', x #) diff --git a/Distribution/Client/BuildReports/Storage.hs b/Distribution/Client/BuildReports/Storage.hs --- a/Distribution/Client/BuildReports/Storage.hs +++ b/Distribution/Client/BuildReports/Storage.hs @@ -74,8 +74,8 @@ [ (report, repo, remoteRepo) | (report, repo@Repo { repoKind = Left remoteRepo }) <- rs ] -storeLocal :: [PathTemplate] -> [(BuildReport, Repo)] -> IO () -storeLocal templates reports = sequence_ +storeLocal :: [PathTemplate] -> [(BuildReport, Repo)] -> Platform -> IO () +storeLocal templates reports platform = sequence_ [ do createDirectoryIfMissing True (takeDirectory file) appendFile file output --TODO: make this concurrency safe, either lock the report file or make @@ -94,6 +94,7 @@ where env = initialPathTemplateEnv (BuildReport.package report) (BuildReport.compiler report) + platform groupByFileName = map (\grp@((filename,_):_) -> (filename, map snd grp)) . groupBy (equating fst) diff --git a/Distribution/Client/Check.hs b/Distribution/Client/Check.hs --- a/Distribution/Client/Check.hs +++ b/Distribution/Client/Check.hs @@ -72,10 +72,10 @@ isDistError _ = True errors = filter isDistError packageChecks - unless (null errors) $ do + unless (null errors) $ putStrLn "Hackage would reject this package." - when (null packageChecks) $ do + when (null packageChecks) $ putStrLn "No errors or warnings could be found in the package." return (null packageChecks) diff --git a/Distribution/Client/Compat/Environment.hs b/Distribution/Client/Compat/Environment.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Compat/Environment.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Compat.Environment +-- Copyright : (c) Simon Hengel 2012 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- A cross-platform library for setting environment variables. +-- +----------------------------------------------------------------------------- + +module Distribution.Client.Compat.Environment ( + lookupEnv, setEnv +) where + +#ifdef mingw32_HOST_OS +import GHC.Windows +import Foreign.Safe +import Foreign.C +import Control.Monad +#else +import Foreign.C.Types +import Foreign.C.String +import Foreign.C.Error (throwErrnoIfMinus1_) +import System.Posix.Internals ( withFilePath ) +#endif /* mingw32_HOST_OS */ + +#if MIN_VERSION_base(4,6,0) +import System.Environment (lookupEnv) +#else +import System.Environment (getEnv) +import Distribution.Compat.Exception (catchIO) +#endif + +#if !MIN_VERSION_base(4,6,0) +-- | @lookupEnv var@ returns the value of the environment variable @var@, or +-- @Nothing@ if there is no such value. +lookupEnv :: String -> IO (Maybe String) +lookupEnv name = (Just `fmap` getEnv name) `catchIO` const (return Nothing) +#endif /* !MIN_VERSION_base(4,6,0) */ + +-- | @setEnv name value@ sets the specified environment variable to @value@. +-- +-- Throws `Control.Exception.IOException` if either @name@ or @value@ is the +-- empty string or contains an equals sign. +setEnv :: String -> String -> IO () +setEnv key value_ + | null value = error "Distribuiton.Compat.setEnv: empty string" + | otherwise = setEnv_ key value + where + -- NOTE: Anything that follows NUL is ignored on both POSIX and Windows. We + -- still strip it manually so that the null check above succeds if a value + -- starts with NUL. + value = takeWhile (/= '\NUL') value_ + +setEnv_ :: String -> String -> IO () + +#ifdef mingw32_HOST_OS + +setEnv_ key value = withCWString key $ \k -> withCWString value $ \v -> do + success <- c_SetEnvironmentVariable k v + unless success (throwGetLastError "setEnv") + +# if defined(i386_HOST_ARCH) +# define WINDOWS_CCONV stdcall +# elif defined(x86_64_HOST_ARCH) +# define WINDOWS_CCONV ccall +# else +# error Unknown mingw32 arch +# endif /* i386_HOST_ARCH */ + +foreign import WINDOWS_CCONV unsafe "windows.h SetEnvironmentVariableW" + c_SetEnvironmentVariable :: LPTSTR -> LPTSTR -> IO Bool +#else +setEnv_ key value = do + withFilePath key $ \ keyP -> + withFilePath value $ \ valueP -> + throwErrnoIfMinus1_ "setenv" $ + c_setenv keyP valueP (fromIntegral (fromEnum True)) + +foreign import ccall unsafe "setenv" + c_setenv :: CString -> CString -> CInt -> IO CInt +#endif /* mingw32_HOST_OS */ diff --git a/Distribution/Client/Compat/FilePerms.hs b/Distribution/Client/Compat/FilePerms.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Compat/FilePerms.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_HADDOCK hide #-} +module Distribution.Client.Compat.FilePerms ( + setFileOrdinary, + setFileExecutable, + setFileHidden, + ) where + +#ifndef mingw32_HOST_OS +import System.Posix.Types + ( FileMode ) +import System.Posix.Internals + ( c_chmod ) +import Foreign.C + ( withCString ) +import Foreign.C + ( throwErrnoPathIfMinus1_ ) +#else +import System.Win32.File (setFileAttributes, fILE_ATTRIBUTE_HIDDEN) +#endif /* mingw32_HOST_OS */ + +setFileHidden, setFileOrdinary, setFileExecutable :: FilePath -> IO () +#ifndef mingw32_HOST_OS +setFileOrdinary path = setFileMode path 0o644 -- file perms -rw-r--r-- +setFileExecutable path = setFileMode path 0o755 -- file perms -rwxr-xr-x +setFileHidden _ = return () + +setFileMode :: FilePath -> FileMode -> IO () +setFileMode name m = + withCString name $ \s -> + throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m) +#else +setFileOrdinary _ = return () +setFileExecutable _ = return () +setFileHidden path = setFileAttributes path fILE_ATTRIBUTE_HIDDEN +#endif diff --git a/Distribution/Client/Compat/Semaphore.hs b/Distribution/Client/Compat/Semaphore.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Compat/Semaphore.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} +module Distribution.Client.Compat.Semaphore + ( QSem + , newQSem + , waitQSem + , signalQSem + ) where + +import Control.Concurrent.STM (TVar, atomically, newTVar, readTVar, retry, + writeTVar) +import Control.Exception (mask_, onException) +import Control.Monad (join, when) +import Data.Typeable (Typeable) + +-- | 'QSem' is a quantity semaphore in which the resource is aqcuired +-- and released in units of one. It provides guaranteed FIFO ordering +-- for satisfying blocked `waitQSem` calls. +-- +data QSem = QSem !(TVar Int) !(TVar [TVar Bool]) !(TVar [TVar Bool]) + deriving (Eq, Typeable) + +newQSem :: Int -> IO QSem +newQSem i = atomically $ do + q <- newTVar i + b1 <- newTVar [] + b2 <- newTVar [] + return (QSem q b1 b2) + +waitQSem :: QSem -> IO () +waitQSem s@(QSem q _b1 b2) = + mask_ $ join $ atomically $ do + -- join, because if we need to block, we have to add a TVar to + -- the block queue. + -- mask_, because we need a chance to set up an exception handler + -- after the join returns. + v <- readTVar q + if v == 0 + then do b <- newTVar False + ys <- readTVar b2 + writeTVar b2 (b:ys) + return (wait b) + else do writeTVar q $! v - 1 + return (return ()) + where + -- + -- very careful here: if we receive an exception, then we need to + -- (a) write True into the TVar, so that another signalQSem doesn't + -- try to wake up this thread, and + -- (b) if the TVar is *already* True, then we need to do another + -- signalQSem to avoid losing a unit of the resource. + -- + -- The 'wake' function does both (a) and (b), so we can just call + -- it here. + -- + wait t = + flip onException (wake s t) $ + atomically $ do + b <- readTVar t + when (not b) retry + + +wake :: QSem -> TVar Bool -> IO () +wake s x = join $ atomically $ do + b <- readTVar x + if b then return (signalQSem s) + else do writeTVar x True + return (return ()) + +{- + property we want: + + bracket waitQSem (\_ -> signalQSem) (\_ -> ...) + + never loses a unit of the resource. +-} + +signalQSem :: QSem -> IO () +signalQSem s@(QSem q b1 b2) = + mask_ $ join $ atomically $ do + -- join, so we don't force the reverse inside the txn + -- mask_ is needed so we don't lose a wakeup + v <- readTVar q + if v /= 0 + then do writeTVar q $! v + 1 + return (return ()) + else do xs <- readTVar b1 + checkwake1 xs + where + checkwake1 [] = do + ys <- readTVar b2 + checkwake2 ys + checkwake1 (x:xs) = do + writeTVar b1 xs + return (wake s x) + + checkwake2 [] = do + writeTVar q 1 + return (return ()) + checkwake2 ys = do + let (z:zs) = reverse ys + writeTVar b1 zs + writeTVar b2 [] + return (wake s z) diff --git a/Distribution/Client/Compat/Time.hs b/Distribution/Client/Compat/Time.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Compat/Time.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} +module Distribution.Client.Compat.Time + (EpochTime, getModTime, getFileAge, getCurTime) + where + +import Data.Int (Int64) +import System.Directory (getModificationTime) + +#if MIN_VERSION_directory(1,2,0) +import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixDayLength) +import Data.Time (getCurrentTime, diffUTCTime) +#else +import System.Time (ClockTime(..), getClockTime + ,diffClockTimes, normalizeTimeDiff, tdDay) +#endif + +#if defined mingw32_HOST_OS + +import Data.Int (Int32) +import Data.Word (Word32) +import Foreign (Ptr, allocaBytes, peekByteOff) +import Foreign.C.Types (CChar) +import Foreign.C.String (withCString) +import System.IO.Error (mkIOError, doesNotExistErrorType) + +type WIN32_FILE_ATTRIBUTE_DATA = Ptr () +type LPCSTR = Ptr CChar + +foreign import stdcall "Windows.h GetFileAttributesExA" + c_getFileAttributesEx :: LPCSTR -> Int32 + -> WIN32_FILE_ATTRIBUTE_DATA -> IO Bool + +size_WIN32_FILE_ATTRIBUTE_DATA :: Int +size_WIN32_FILE_ATTRIBUTE_DATA = 36 + +index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime :: Int +index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime = 20 + +#else + +#if MIN_VERSION_base(4,5,0) +import Foreign.C.Types (CTime(..)) +#else +import Foreign.C.Types (CTime) +#endif +import System.Posix.Files (getFileStatus, modificationTime) + +#endif + +-- | The number of seconds since the UNIX epoch. +type EpochTime = Int64 + +-- | Return modification time of given file. Works around the low clock +-- resolution problem that 'getModificationTime' has on GHC < 7.8. +-- +-- This is a modified version of the code originally written for OpenShake by +-- Neil Mitchell. See module Development.Shake.FileTime. +getModTime :: FilePath -> IO EpochTime + +#if defined mingw32_HOST_OS + +-- Directly against the Win32 API. +getModTime path = withCString path $ \file -> + allocaBytes size_WIN32_FILE_ATTRIBUTE_DATA $ \info -> do + res <- c_getFileAttributesEx file 0 info + if not res + then do + let err = mkIOError doesNotExistErrorType + "Distribution.Client.Compat.Time.getModTime" + Nothing (Just path) + ioError err + else do + dword <- peekByteOff info + index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime + -- TODO: Convert Windows seconds to POSIX seconds. ATM we don't care + -- since we only use the value for comparisons. + return $! fromIntegral (dword :: Word32) +#else + +-- Directly against the unix library. +getModTime path = do + -- CTime is Int32 in base 4.5, Int64 in base >= 4.6, and an abstract type in + -- base < 4.5. + t <- fmap modificationTime $ getFileStatus path +#if MIN_VERSION_base(4,5,0) + let CTime i = t + return (fromIntegral i) +#else + return (read . show $ t) +#endif +#endif + +-- | Return age of given file in days. +getFileAge :: FilePath -> IO Int +getFileAge file = do + t0 <- getModificationTime file +#if MIN_VERSION_directory(1,2,0) + t1 <- getCurrentTime + let days = truncate $ (t1 `diffUTCTime` t0) / posixDayLength +#else + t1 <- getClockTime + let days = (tdDay . normalizeTimeDiff) (t1 `diffClockTimes` t0) +#endif + return days + +getCurTime :: IO EpochTime +getCurTime = do +#if MIN_VERSION_directory(1,2,0) + (truncate . utcTimeToPOSIXSeconds) `fmap` getCurrentTime +#else + (TOD s _) <- getClockTime + return $! fromIntegral s +#endif diff --git a/Distribution/Client/Config.hs b/Distribution/Client/Config.hs --- a/Distribution/Client/Config.hs +++ b/Distribution/Client/Config.hs @@ -8,7 +8,8 @@ -- Stability : provisional -- Portability : portable -- --- Utilities for handling saved state such as known packages, known servers and downloaded packages. +-- Utilities for handling saved state such as known packages, known servers and +-- downloaded packages. ----------------------------------------------------------------------------- module Distribution.Client.Config ( SavedConfig(..), @@ -21,7 +22,15 @@ defaultCabalDir, defaultConfigFile, defaultCacheDir, + defaultCompiler, defaultLogsDir, + defaultUserInstall, + + baseSavedConfig, + commentSavedConfig, + initialSavedConfig, + configFieldDescriptions, + installDirsFields ) where @@ -42,6 +51,7 @@ import Distribution.Simple.Setup ( ConfigFlags(..), configureOptions, defaultConfigFlags , installDirsOptions + , programConfigurationPaths', programConfigurationOptions , Flag(..), toFlag, flagToMaybe, fromFlagOrDefault ) import Distribution.Simple.InstallDirs ( InstallDirs(..), defaultInstallDirs @@ -52,6 +62,8 @@ , locatedErrorMsg, showPWarning , readFields, warning, lineNo , simpleField, listField, parseFilePathQ, parseTokenQ ) +import Distribution.Client.ParseUtils + ( parseFields, ppFields, ppSection ) import qualified Distribution.ParseUtils as ParseUtils ( Field(..) ) import qualified Distribution.Text as Text @@ -75,24 +87,23 @@ import Data.Monoid ( Monoid(..) ) import Control.Monad - ( when, foldM, liftM ) -import qualified Data.Map as Map + ( unless, foldM, liftM ) import qualified Distribution.Compat.ReadP as Parse ( option ) import qualified Text.PrettyPrint as Disp - ( Doc, render, text, colon, vcat, empty, isEmpty, nest ) + ( render, text, empty ) import Text.PrettyPrint - ( (<>), (<+>), ($$), ($+$) ) + ( ($+$) ) import System.Directory - ( createDirectoryIfMissing, getAppUserDataDirectory ) + ( createDirectoryIfMissing, getAppUserDataDirectory, renameFile ) import Network.URI ( URI(..), URIAuth(..) ) import System.FilePath - ( (), takeDirectory ) -import System.Environment - ( getEnvironment ) + ( (<.>), (), takeDirectory ) import System.IO.Error ( isDoesNotExistError ) +import Distribution.Compat.Environment + ( getEnvironment ) import Distribution.Compat.Exception ( catchIO ) @@ -192,16 +203,20 @@ cacheDir <- defaultCacheDir logsDir <- defaultLogsDir worldFile <- defaultWorldFile + extraPath <- defaultExtraPath return mempty { savedGlobalFlags = mempty { globalCacheDir = toFlag cacheDir, globalRemoteRepos = [defaultRemoteRepo], globalWorldFile = toFlag worldFile }, + savedConfigureFlags = mempty { + configProgramPathExtra = extraPath + }, savedInstallFlags = mempty { installSummaryFile = [toPathTemplate (logsDir "build.log")], - installBuildReports= toFlag AnonymousReports - --installNumJobs = toFlag (Just numberOfProcessors) + installBuildReports= toFlag AnonymousReports, + installNumJobs = toFlag Nothing } } @@ -231,6 +246,11 @@ dir <- defaultCabalDir return $ dir "world" +defaultExtraPath :: IO [FilePath] +defaultExtraPath = do + dir <- defaultCabalDir + return [dir "bin"] + defaultCompiler :: CompilerFlavor defaultCompiler = fromMaybe GHC defaultCompilerFlavor @@ -257,7 +277,7 @@ ("default config file", Just `liftM` defaultConfigFile) ] getSource [] = error "no config file path candidate found." - getSource ((msg,action): xs) = + getSource ((msg,action): xs) = action >>= maybe (getSource xs) (return . (,) msg) (source, configFile) <- getSource sources @@ -272,15 +292,15 @@ writeConfigFile configFile commentConf initialConf return initialConf Just (ParseOk ws conf) -> do - when (not $ null ws) $ warn verbosity $ + unless (null ws) $ warn verbosity $ unlines (map (showPWarning configFile) ws) return conf Just (ParseFailed err) -> do let (line, msg) = locatedErrorMsg err warn verbosity $ "Error parsing config file " ++ configFile - ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg - warn verbosity $ "Using default configuration." + ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg + warn verbosity "Using default configuration." initialSavedConfig where @@ -301,8 +321,10 @@ writeConfigFile :: FilePath -> SavedConfig -> SavedConfig -> IO () writeConfigFile file comments vals = do + let tmpFile = file <.> "tmp" createDirectoryIfMissing True (takeDirectory file) - writeFile file $ explanation ++ showConfigWithComments comments vals ++ "\n" + writeFile tmpFile $ explanation ++ showConfigWithComments comments vals ++ "\n" + renameFile tmpFile file where explanation = unlines ["-- This is the configuration file for the 'cabal' command line tool." @@ -345,7 +367,7 @@ toSavedConfig liftGlobalFlag (commandOptions globalCommand ParseArgs) - ["version", "numeric-version", "config-file"] [] + ["version", "numeric-version", "config-file", "sandbox-config-file"] [] ++ toSavedConfig liftConfigFlag (configureOptions ParseArgs) @@ -390,7 +412,7 @@ ++ toSavedConfig liftInstallFlag (installOptions ParseArgs) - ["dry-run", "only"] [] + ["dry-run", "only", "only-dependencies", "dependencies-only"] [] ++ toSavedConfig liftUploadFlag (commandOptions uploadCommand ParseArgs) @@ -485,28 +507,49 @@ config <- parse others let user0 = savedUserInstallDirs config global0 = savedGlobalInstallDirs config - (user, global) <- foldM parseSections (user0, global0) knownSections + (user, global, paths, args) <- + foldM parseSections (user0, global0, [], []) knownSections return config { + savedConfigureFlags = (savedConfigureFlags config) { + configProgramPaths = paths, + configProgramArgs = args + }, savedUserInstallDirs = user, savedGlobalInstallDirs = global } where - isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True - isKnownSection _ = False + isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True + isKnownSection (ParseUtils.Section _ "program-locations" _ _) = True + isKnownSection (ParseUtils.Section _ "program-default-options" _ _) = True + isKnownSection _ = False parse = parseFields (configFieldDescriptions ++ deprecatedFieldDescriptions) initial - parseSections accum@(u,g) (ParseUtils.Section _ "install-dirs" name fs) + parseSections accum@(u,g,p,a) (ParseUtils.Section _ "install-dirs" name fs) | name' == "user" = do u' <- parseFields installDirsFields u fs - return (u', g) + return (u', g, p, a) | name' == "global" = do g' <- parseFields installDirsFields g fs - return (u, g') + return (u, g', p, a) | otherwise = do warning "The install-paths section should be for 'user' or 'global'" return accum where name' = lowercase name + parseSections accum@(u,g,p,a) + (ParseUtils.Section _ "program-locations" name fs) + | name == "" = do p' <- parseFields withProgramsFields p fs + return (u, g, p', a) + | otherwise = do + warning "The 'program-locations' section should be unnamed" + return accum + parseSections accum@(u, g, p, a) + (ParseUtils.Section _ "program-default-options" name fs) + | name == "" = do a' <- parseFields withProgramOptionsFields a fs + return (u, g, p, a') + | otherwise = do + warning "The 'program-default-options' section should be unnamed" + return accum parseSections accum f = do warning $ "Unrecognized stanza on line " ++ show (lineNo f) return accum @@ -516,52 +559,40 @@ showConfigWithComments :: SavedConfig -> SavedConfig -> String showConfigWithComments comment vals = Disp.render $ - ppFields configFieldDescriptions comment vals + ppFields configFieldDescriptions mcomment vals $+$ Disp.text "" $+$ installDirsSection "user" savedUserInstallDirs $+$ Disp.text "" $+$ installDirsSection "global" savedGlobalInstallDirs + $+$ Disp.text "" + $+$ configFlagsSection "program-locations" withProgramsFields + configProgramPaths + $+$ Disp.text "" + $+$ configFlagsSection "program-default-options" withProgramOptionsFields + configProgramArgs where + mcomment = Just comment installDirsSection name field = ppSection "install-dirs" name installDirsFields - (field comment) (field vals) + (fmap field mcomment) (field vals) + configFlagsSection name fields field = + ppSection name "" fields + (fmap (field . savedConfigureFlags) mcomment) + ((field . savedConfigureFlags) vals) ------------------------- --- * Parsing utils --- ---FIXME: replace this with something better in Cabal-1.5 -parseFields :: [FieldDescr a] -> a -> [ParseUtils.Field] -> ParseResult a -parseFields fields initial = foldM setField initial - where - fieldMap = Map.fromList - [ (name, f) | f@(FieldDescr name _ _) <- fields ] - setField accum (ParseUtils.F line name value) = case Map.lookup name fieldMap of - Just (FieldDescr _ _ set) -> set line value accum - Nothing -> do - warning $ "Unrecognized field " ++ name ++ " on line " ++ show line - return accum - setField accum f = do - warning $ "Unrecognized stanza on line " ++ show (lineNo f) - return accum - --- | This is a customised version of the function from Cabal that also prints --- default values for empty fields as comments. --- -ppFields :: [FieldDescr a] -> a -> a -> Disp.Doc -ppFields fields def cur = Disp.vcat [ ppField name (getter def) (getter cur) - | FieldDescr name getter _ <- fields] - -ppField :: String -> Disp.Doc -> Disp.Doc -> Disp.Doc -ppField name def cur - | Disp.isEmpty cur = Disp.text "--" <+> Disp.text name <> Disp.colon <+> def - | otherwise = Disp.text name <> Disp.colon <+> cur - -ppSection :: String -> String -> [FieldDescr a] -> a -> a -> Disp.Doc -ppSection name arg fields def cur = - Disp.text name <+> Disp.text arg - $$ Disp.nest 2 (ppFields fields def cur) - installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))] installDirsFields = map viewAsFieldDescr installDirsOptions +-- | Fields for the 'program-locations' section. +withProgramsFields :: [FieldDescr [(String, FilePath)]] +withProgramsFields = + map viewAsFieldDescr $ + programConfigurationPaths' (++ "-location") defaultProgramConfiguration + ParseArgs id (++) + +-- | Fields for the 'program-default-options' section. +withProgramOptionsFields :: [FieldDescr [(String, [String])]] +withProgramOptionsFields = + map viewAsFieldDescr $ + programConfigurationOptions defaultProgramConfiguration ParseArgs id (++) diff --git a/Distribution/Client/Configure.hs b/Distribution/Client/Configure.hs --- a/Distribution/Client/Configure.hs +++ b/Distribution/Client/Configure.hs @@ -47,7 +47,7 @@ import Distribution.Simple.Utils as Utils ( notice, info, debug, die ) import Distribution.System - ( Platform, buildPlatform ) + ( Platform ) import Distribution.Verbosity as Verbosity ( Verbosity ) @@ -58,18 +58,19 @@ -> PackageDBStack -> [Repo] -> Compiler + -> Platform -> ProgramConfiguration -> ConfigFlags -> ConfigExFlags -> [String] -> IO () -configure verbosity packageDBs repos comp conf +configure verbosity packageDBs repos comp platform conf configFlags configExFlags extraArgs = do installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf sourcePkgDb <- getSourcePackages verbosity repos - progress <- planLocalPackage verbosity comp configFlags configExFlags + progress <- planLocalPackage verbosity comp platform configFlags configExFlags installedPkgIndex sourcePkgDb notice verbosity "Resolving dependencies..." @@ -97,6 +98,7 @@ useCabalVersion = maybe anyVersion thisVersion (flagToMaybe (configCabalVersion configExFlags)), useCompiler = Just comp, + usePlatform = Just platform, usePackageDB = packageDBs', usePackageIndex = index', useProgramConfig = conf, @@ -125,11 +127,12 @@ -- and all its dependencies. -- planLocalPackage :: Verbosity -> Compiler + -> Platform -> ConfigFlags -> ConfigExFlags -> PackageIndex -> SourcePackageDb -> IO (Progress String String InstallPlan) -planLocalPackage verbosity comp configFlags configExFlags installedPkgIndex +planLocalPackage verbosity comp platform configFlags configExFlags installedPkgIndex (SourcePackageDb _ packagePrefs) = do pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity solver <- chooseSolver verbosity (fromFlag $ configSolver configExFlags) (compilerId comp) @@ -167,10 +170,9 @@ . addConstraints -- '--enable-tests' and '--enable-benchmarks' constraints from -- command line - [ PackageConstraintStanzas (packageName pkg) $ concat - [ if testsEnabled then [TestStanzas] else [] - , if benchmarksEnabled then [BenchStanzas] else [] - ] + [ PackageConstraintStanzas (packageName pkg) $ + [ TestStanzas | testsEnabled ] ++ + [ BenchStanzas | benchmarksEnabled ] ] $ standardInstallPolicy @@ -178,7 +180,7 @@ (SourcePackageDb mempty packagePrefs) [SpecificSourcePackage localPkg] - return (resolveDependencies buildPlatform (compilerId comp) solver resolverParams) + return (resolveDependencies platform (compilerId comp) solver resolverParams) -- | Call an installer for an 'SourcePackage' but override the configure diff --git a/Distribution/Client/Dependency.hs b/Distribution/Client/Dependency.hs --- a/Distribution/Client/Dependency.hs +++ b/Distribution/Client/Dependency.hs @@ -33,6 +33,9 @@ standardInstallPolicy, PackageSpecifier(..), + -- ** Sandbox policy + applySandboxInstallPolicy, + -- ** Extra policy options dontUpgradeBasePackage, hideBrokenInstalledPackages, @@ -70,13 +73,16 @@ , PackagePreferences(..), InstalledPreference(..) , PackagesPreferenceDefault(..) , Progress(..), foldProgress ) +import Distribution.Client.Sandbox.Types + ( SandboxPackageInfo(..) ) import Distribution.Client.Targets import qualified Distribution.InstalledPackageInfo as Installed import Distribution.Package - ( PackageName(..), PackageId, Package(..), packageVersion + ( PackageName(..), PackageId, Package(..), packageName, packageVersion , InstalledPackageId, Dependency(Dependency)) import Distribution.Version - ( Version(..), VersionRange, anyVersion, withinRange, simplifyVersionRange ) + ( Version(..), VersionRange, anyVersion, thisVersion, withinRange + , simplifyVersionRange ) import Distribution.Compiler ( CompilerId(..), CompilerFlavor(..) ) import Distribution.System @@ -235,7 +241,8 @@ } hideInstalledPackagesSpecificByInstalledPackageId :: [InstalledPackageId] - -> DepResolverParams -> DepResolverParams + -> DepResolverParams + -> DepResolverParams hideInstalledPackagesSpecificByInstalledPackageId pkgids params = --TODO: this should work using exclude constraints instead params { @@ -245,7 +252,8 @@ } hideInstalledPackagesSpecificBySourcePackageId :: [PackageId] - -> DepResolverParams -> DepResolverParams + -> DepResolverParams + -> DepResolverParams hideInstalledPackagesSpecificBySourcePackageId pkgids params = --TODO: this should work using exclude constraints instead params { @@ -313,7 +321,44 @@ $ basicDepResolverParams installedPkgIndex sourcePkgIndex +applySandboxInstallPolicy :: SandboxPackageInfo + -> DepResolverParams + -> DepResolverParams +applySandboxInstallPolicy + (SandboxPackageInfo modifiedDeps otherDeps allSandboxPkgs _allDeps) + params + = addPreferences [ PackageInstalledPreference n PreferInstalled + | n <- installedNotModified ] + + . addTargets installedNotModified + + . addPreferences + [ PackageVersionPreference (packageName pkg) + (thisVersion (packageVersion pkg)) | pkg <- otherDeps ] + + . addConstraints + [ PackageConstraintVersion (packageName pkg) + (thisVersion (packageVersion pkg)) | pkg <- modifiedDeps ] + + . addTargets [ packageName pkg | pkg <- modifiedDeps ] + + . hideInstalledPackagesSpecificBySourcePackageId + [ packageId pkg | pkg <- modifiedDeps ] + + -- We don't need to add source packages for add-source deps to the + -- 'installedPkgIndex' since 'getSourcePackages' did that for us. + + $ params + + where + installedPkgIds = + map fst . InstalledPackageIndex.allPackagesBySourcePackageId + $ allSandboxPkgs + modifiedPkgIds = map packageId modifiedDeps + installedNotModified = [ packageName pkg | pkg <- installedPkgIds, + pkg `notElem` modifiedPkgIds ] + -- ------------------------------------------------------------ -- * Interface to the standard resolver -- ------------------------------------------------------------ @@ -353,7 +398,8 @@ resolveDependencies platform comp solver params = fmap (mkInstallPlan platform comp) - $ runSolver solver (SolverConfig reorderGoals indGoals noReinstalls shadowing maxBkjumps) + $ runSolver solver (SolverConfig reorderGoals indGoals noReinstalls + shadowing maxBkjumps) platform comp installedPkgIndex sourcePkgIndex preferences constraints targets where @@ -368,10 +414,10 @@ shadowing maxBkjumps = dontUpgradeBasePackage -- TODO: - -- The modular solver can properly deal with broken packages - -- and won't select them. So the 'hideBrokenInstalledPackages' - -- function should be moved into a module that is specific - -- to the Topdown solver. + -- The modular solver can properly deal with broken + -- packages and won't select them. So the + -- 'hideBrokenInstalledPackages' function should be moved + -- into a module that is specific to the Topdown solver. . (if solver /= Modular then hideBrokenInstalledPackages else id) $ params @@ -448,7 +494,8 @@ -> Either [ResolveNoDepsError] [SourcePackage] resolveWithoutDependencies (DepResolverParams targets constraints prefs defpref installedPkgIndex sourcePkgIndex - _reorderGoals _indGoals _avoidReinstalls _shadowing _maxBjumps) = + _reorderGoals _indGoals _avoidReinstalls + _shadowing _maxBjumps) = collectEithers (map selectPackage targets) where selectPackage :: PackageName -> Either ResolveNoDepsError SourcePackage @@ -471,7 +518,8 @@ (installPref pkg, versionPref pkg, packageVersion pkg) installPref = case preferInstalled of PreferLatest -> const False - PreferInstalled -> not . null . InstalledPackageIndex.lookupSourcePackageId + PreferInstalled -> not . null + . InstalledPackageIndex.lookupSourcePackageId installedPkgIndex . packageId versionPref pkg = packageVersion pkg `withinRange` preferredVersions diff --git a/Distribution/Client/Dependency/Modular/Builder.hs b/Distribution/Client/Dependency/Modular/Builder.hs --- a/Distribution/Client/Dependency/Modular/Builder.hs +++ b/Distribution/Client/Dependency/Modular/Builder.hs @@ -43,6 +43,7 @@ extendOpen :: QPN -> [OpenGoal] -> BuildState -> BuildState extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs where + go :: RevDepMap -> PSQ OpenGoal () -> [OpenGoal] -> BuildState go g o [] = s { rdeps = g, open = o } go g o (ng@(OpenGoal (Flagged _ _ _ _) _gr) : ngs) = go g (cons ng () o) ngs go g o (ng@(OpenGoal (Stanza _ _ ) _gr) : ngs) = go g (cons ng () o) ngs @@ -63,7 +64,7 @@ -- | Given the current scope, qualify all the package names in the given set of -- dependencies and then extend the set of open goals accordingly. -scopedExtendOpen :: QPN -> I -> QGoalReasons -> FlaggedDeps PN -> FlagInfo -> +scopedExtendOpen :: QPN -> I -> QGoalReasonChain -> FlaggedDeps PN -> FlagInfo -> BuildState -> BuildState scopedExtendOpen qpn i gr fdeps fdefs s = extendOpen qpn gs s where @@ -72,12 +73,12 @@ qfdefs = L.map (\ (fn, b) -> Flagged (FN (PI qpn i) fn) b [] []) $ M.toList fdefs gs = L.map (flip OpenGoal gr) (qfdeps ++ qfdefs) -data BuildType = Goals | OneGoal OpenGoal | Instance QPN I PInfo QGoalReasons +data BuildType = Goals | OneGoal OpenGoal | Instance QPN I PInfo QGoalReasonChain -build :: BuildState -> Tree (QGoalReasons, Scope) +build :: BuildState -> Tree (QGoalReasonChain, Scope) build = ana go where - go :: BuildState -> TreeF (QGoalReasons, Scope) BuildState + go :: BuildState -> TreeF (QGoalReasonChain, Scope) BuildState -- If we have a choice between many goals, we just record the choice in -- the tree. We select each open goal in turn, and before we descend, remove @@ -131,7 +132,7 @@ -- | Interface to the tree builder. Just takes an index and a list of package names, -- and computes the initial state and then the tree from there. -buildTree :: Index -> Bool -> [PN] -> Tree (QGoalReasons, Scope) +buildTree :: Index -> Bool -> [PN] -> Tree (QGoalReasonChain, Scope) buildTree idx ind igs = build (BS idx sc (M.fromList (L.map (\ qpn -> (qpn, [])) qpns)) diff --git a/Distribution/Client/Dependency/Modular/Dependency.hs b/Distribution/Client/Dependency/Modular/Dependency.hs --- a/Distribution/Client/Dependency/Modular/Dependency.hs +++ b/Distribution/Client/Dependency/Modular/Dependency.hs @@ -135,11 +135,11 @@ -- | Goals are solver variables paired with information about -- why they have been introduced. -data Goal qpn = Goal (Var qpn) (GoalReasons qpn) +data Goal qpn = Goal (Var qpn) (GoalReasonChain qpn) deriving (Eq, Show) instance Functor Goal where - fmap f (Goal v gr) = Goal (fmap f v) (fmap (fmap f) gr) + fmap f (Goal v grs) = Goal (fmap f v) (fmap (fmap f) grs) class ResetGoal f where resetGoal :: Goal qpn -> f qpn -> f qpn @@ -149,7 +149,7 @@ -- | For open goals as they occur during the build phase, we need to store -- additional information about flags. -data OpenGoal = OpenGoal (FlaggedDep QPN) QGoalReasons +data OpenGoal = OpenGoal (FlaggedDep QPN) QGoalReasonChain deriving (Eq, Show) -- | Reasons why a goal can be added to a goal set. @@ -168,9 +168,9 @@ -- | The first element is the immediate reason. The rest are the reasons -- for the reasons ... -type GoalReasons qpn = [GoalReason qpn] +type GoalReasonChain qpn = [GoalReason qpn] -type QGoalReasons = GoalReasons QPN +type QGoalReasonChain = GoalReasonChain QPN goalReasonToVars :: GoalReason qpn -> ConflictSet qpn goalReasonToVars UserGoal = S.empty @@ -178,9 +178,12 @@ goalReasonToVars (FDependency qfn _) = S.singleton (F qfn) goalReasonToVars (SDependency qsn) = S.singleton (S qsn) -goalReasonsToVars :: Ord qpn => GoalReasons qpn -> ConflictSet qpn -goalReasonsToVars = S.unions . L.map goalReasonToVars +goalReasonChainToVars :: Ord qpn => GoalReasonChain qpn -> ConflictSet qpn +goalReasonChainToVars = S.unions . L.map goalReasonToVars +goalReasonChainsToVars :: Ord qpn => [GoalReasonChain qpn] -> ConflictSet qpn +goalReasonChainsToVars = S.unions . L.map goalReasonChainToVars + -- | Closes a goal, i.e., removes all the extraneous information that we -- need only during the build phase. close :: OpenGoal -> Goal QPN @@ -191,4 +194,4 @@ -- | Compute a conflic set from a goal. The conflict set contains the -- closure of goal reasons as well as the variable of the goal itself. toConflictSet :: Ord qpn => Goal qpn -> ConflictSet qpn -toConflictSet (Goal g gr) = S.insert g (goalReasonsToVars gr) +toConflictSet (Goal g grs) = S.insert g (goalReasonChainToVars grs) diff --git a/Distribution/Client/Dependency/Modular/Explore.hs b/Distribution/Client/Dependency/Modular/Explore.hs --- a/Distribution/Client/Dependency/Modular/Explore.hs +++ b/Distribution/Client/Dependency/Modular/Explore.hs @@ -80,24 +80,25 @@ go (PChoiceF qpn _ ts) (A pa fa sa) = asum $ -- try children in order, P.mapWithKey -- when descending ... - (\ k r -> r (A (M.insert qpn k pa) fa sa)) $ -- record the pkg choice + (\ k r -> r (A (M.insert qpn k pa) fa sa)) -- record the pkg choice ts go (FChoiceF qfn _ _ _ ts) (A pa fa sa) = asum $ -- try children in order, P.mapWithKey -- when descending ... - (\ k r -> r (A pa (M.insert qfn k fa) sa)) $ -- record the flag choice + (\ k r -> r (A pa (M.insert qfn k fa) sa)) -- record the flag choice ts go (SChoiceF qsn _ _ ts) (A pa fa sa) = asum $ -- try children in order, P.mapWithKey -- when descending ... - (\ k r -> r (A pa fa (M.insert qsn k sa))) $ -- record the flag choice + (\ k r -> r (A pa fa (M.insert qsn k sa))) -- record the flag choice ts go (GoalChoiceF ts) a = casePSQ ts A.empty -- empty goal choice is an internal error (\ _k v _xs -> v a) -- commit to the first goal choice -- | Version of 'explore' that returns a 'Log'. -exploreLog :: Tree (Maybe (ConflictSet QPN)) -> (Assignment -> Log Message (Assignment, RevDepMap)) +exploreLog :: Tree (Maybe (ConflictSet QPN)) -> + (Assignment -> Log Message (Assignment, RevDepMap)) exploreLog = cata go where go (FailF c fr) _ = failWith (Failure c fr) diff --git a/Distribution/Client/Dependency/Modular/IndexConversion.hs b/Distribution/Client/Dependency/Modular/IndexConversion.hs --- a/Distribution/Client/Dependency/Modular/IndexConversion.hs +++ b/Distribution/Client/Dependency/Modular/IndexConversion.hs @@ -114,10 +114,10 @@ PInfo (maybe [] (convCondTree os arch cid pi fds (const True) ) libs ++ concatMap (convCondTree os arch cid pi fds (const True) . snd) exes ++ - (prefix (Stanza (SN pi TestStanzas)) - (L.map (convCondTree os arch cid pi fds (const True) . snd) tests)) ++ - (prefix (Stanza (SN pi BenchStanzas)) - (L.map (convCondTree os arch cid pi fds (const True) . snd) benchs))) + prefix (Stanza (SN pi TestStanzas)) + (L.map (convCondTree os arch cid pi fds (const True) . snd) tests) ++ + prefix (Stanza (SN pi BenchStanzas)) + (L.map (convCondTree os arch cid pi fds (const True) . snd) benchs)) fds [] -- TODO: add encaps Nothing diff --git a/Distribution/Client/Dependency/Modular/Log.hs b/Distribution/Client/Dependency/Modular/Log.hs --- a/Distribution/Client/Dependency/Modular/Log.hs +++ b/Distribution/Client/Dependency/Modular/Log.hs @@ -18,6 +18,10 @@ -- Parameterized over the type of actual messages and the final result. type Log m a = Progress m () a +-- | Turns a log into a list of messages paired with a final result. A final result +-- of 'Nothing' indicates failure. A final result of 'Just' indicates success. +-- Keep in mind that forcing the second component of the returned pair will force the +-- entire log. runLog :: Log m a -> ([m], Maybe a) runLog (Done x) = ([], Just x) runLog (Fail _) = ([], Nothing) @@ -32,19 +36,24 @@ logToProgress :: Maybe Int -> Log Message a -> Progress String String a logToProgress mbj l = let (ms, s) = runLog l + -- 'Nothing' for 's' means search tree exhaustively searched and failed (es, e) = proc 0 ms -- catch first error (always) + -- 'Nothing' in 'e' means no backjump found (ns, t) = case mbj of Nothing -> (ms, Nothing) Just n -> proc n ms + -- 'Nothing' in 't' means backjump limit not reached -- prefer first error over later error - r = case t of - Nothing -> case s of - Nothing -> e - Just _ -> Nothing - Just _ -> e + (exh, r) = case t of + -- backjump limit not reached + Nothing -> case s of + Nothing -> (True, e) -- failed after exhaustive search + Just _ -> (True, Nothing) -- success + -- backjump limit reached; prefer first error + Just _ -> (False, e) -- failed after backjump limit was reached in go es es -- trace for first error (showMessages (const True) True ns) -- shortened run - r s + r s exh where -- Proc takes the allowed number of backjumps and a list of messages and explores the -- message list until the maximum number of backjumps has been reached. The log until @@ -63,18 +72,22 @@ -- in parallel with the full log, but we also want to retain the reference to its -- beginning for when we print it. This trick prevents a space leak! -- - -- The thirs argument is the full log, the fifth and six error conditions. + -- The third argument is the full log, the fifth and six error conditions. + -- The seventh argument indicates whether the search was exhaustive. -- -- The order of arguments is important! In particular 's' must not be evaluated -- unless absolutely necessary. It contains the final result, and if we shortcut -- with an error due to backjumping, evaluating 's' would still require traversing -- the entire tree. - go ms (_ : ns) (x : xs) r s = Step x (go ms ns xs r s) - go ms [] (x : xs) r s = Step x (go ms [] xs r s) - go ms _ [] (Just cs) _ = Fail ("Could not resolve dependencies:\n" ++ - unlines (showMessages (L.foldr (\ v _ -> v `S.member` cs) True) False ms)) - go _ _ [] _ (Just s) = Done s - go _ _ [] _ _ = Fail ("Could not resolve dependencies.") -- should not happen + go ms (_ : ns) (x : xs) r s exh = Step x (go ms ns xs r s exh) + go ms [] (x : xs) r s exh = Step x (go ms [] xs r s exh) + go ms _ [] (Just cs) _ exh = Fail $ + "Could not resolve dependencies:\n" ++ + unlines (showMessages (L.foldr (\ v _ -> v `S.member` cs) True) False ms) ++ + (if exh then "Dependency tree exhaustively searched.\n" + else "Backjump limit reached (change with --max-backjumps).\n") + go _ _ [] _ (Just s) _ = Done s + go _ _ [] _ _ _ = Fail ("Could not resolve dependencies; something strange happened.") -- should not happen logToProgress' :: Log Message a -> Progress String String a logToProgress' l = let diff --git a/Distribution/Client/Dependency/Modular/Message.hs b/Distribution/Client/Dependency/Modular/Message.hs --- a/Distribution/Client/Dependency/Modular/Message.hs +++ b/Distribution/Client/Dependency/Modular/Message.hs @@ -66,7 +66,7 @@ | p v = x : xs | otherwise = xs -showGRs :: QGoalReasons -> String +showGRs :: QGoalReasonChain -> String showGRs (gr : _) = showGR gr showGRs [] = "" diff --git a/Distribution/Client/Dependency/Modular/PSQ.hs b/Distribution/Client/Dependency/Modular/PSQ.hs --- a/Distribution/Client/Dependency/Modular/PSQ.hs +++ b/Distribution/Client/Dependency/Modular/PSQ.hs @@ -5,7 +5,7 @@ -- I am not yet sure what exactly is needed. But we need a datastructure with -- key-based lookup that can be sorted. We're using a sequence right now with -- (inefficiently implemented) lookup, because I think that queue-based --- opertions and sorting turn out to be more efficiency-critical in practice. +-- operations and sorting turn out to be more efficiency-critical in practice. import Control.Applicative import Data.Foldable @@ -66,10 +66,11 @@ (k, v) : ys -> c k v (PSQ ys) splits :: PSQ k a -> PSQ k (a, PSQ k a) -splits xs = - casePSQ xs - (PSQ []) - (\ k v ys -> cons k (v, ys) (fmap (\ (w, zs) -> (w, cons k v zs)) (splits ys))) +splits = go id + where + go f xs = casePSQ xs + (PSQ []) + (\ k v ys -> cons k (v, f ys) (go (f . cons k v) ys)) sortBy :: (a -> a -> Ordering) -> PSQ k a -> PSQ k a sortBy cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` snd) xs) diff --git a/Distribution/Client/Dependency/Modular/Preference.hs b/Distribution/Client/Dependency/Modular/Preference.hs --- a/Distribution/Client/Dependency/Modular/Preference.hs +++ b/Distribution/Client/Dependency/Modular/Preference.hs @@ -105,7 +105,7 @@ -- | Traversal that tries to establish various kinds of user constraints. Works -- by selectively disabling choices that have been ruled out by global user -- constraints. -enforcePackageConstraints :: M.Map PN [PackageConstraint] -> Tree QGoalReasons -> Tree QGoalReasons +enforcePackageConstraints :: M.Map PN [PackageConstraint] -> Tree QGoalReasonChain -> Tree QGoalReasonChain enforcePackageConstraints pcs = trav go where go (PChoiceF qpn@(Q _ pn) gr ts) = @@ -132,7 +132,7 @@ -- can only be re-set explicitly by the user. This transformation should -- be run after user preferences have been enforced. For manual flags, -- it disables all but the first non-disabled choice. -enforceManualFlags :: Tree QGoalReasons -> Tree QGoalReasons +enforceManualFlags :: Tree QGoalReasonChain -> Tree QGoalReasonChain enforceManualFlags = trav go where go (FChoiceF qfn gr tr True ts) = FChoiceF qfn gr tr True $ @@ -162,7 +162,7 @@ preferLatest = preferLatestFor (const True) -- | Require installed packages. -requireInstalled :: (PN -> Bool) -> Tree (QGoalReasons, a) -> Tree (QGoalReasons, a) +requireInstalled :: (PN -> Bool) -> Tree (QGoalReasonChain, a) -> Tree (QGoalReasonChain, a) requireInstalled p = trav go where go (PChoiceF v@(Q _ pn) i@(gr, _) cs) @@ -186,7 +186,7 @@ -- they are, perhaps this should just result in trying to reinstall those other -- packages as well. However, doing this all neatly in one pass would require to -- change the builder, or at least to change the goal set after building. -avoidReinstalls :: (PN -> Bool) -> Tree (QGoalReasons, a) -> Tree (QGoalReasons, a) +avoidReinstalls :: (PN -> Bool) -> Tree (QGoalReasonChain, a) -> Tree (QGoalReasonChain, a) avoidReinstalls p = trav go where go (PChoiceF qpn@(Q _ pn) i@(gr, _) cs) @@ -211,7 +211,8 @@ firstGoal :: Tree a -> Tree a firstGoal = trav go where - go (GoalChoiceF xs) = casePSQ xs (GoalChoiceF xs) (\ _ t _ -> out t) + go (GoalChoiceF xs) = -- casePSQ xs (GoalChoiceF xs) (\ _ t _ -> out t) -- more space efficient, but removes valuable debug info + casePSQ xs (GoalChoiceF (fromList [])) (\ g t _ -> GoalChoiceF (fromList [(g, t)])) go x = x -- Note that we keep empty choice nodes, because they mean success. diff --git a/Distribution/Client/Dependency/Modular/Validate.hs b/Distribution/Client/Dependency/Modular/Validate.hs --- a/Distribution/Client/Dependency/Modular/Validate.hs +++ b/Distribution/Client/Dependency/Modular/Validate.hs @@ -80,10 +80,10 @@ type Validate = Reader ValidateState -validate :: Tree (QGoalReasons, Scope) -> Validate (Tree QGoalReasons) +validate :: Tree (QGoalReasonChain, Scope) -> Validate (Tree QGoalReasonChain) validate = cata go where - go :: TreeF (QGoalReasons, Scope) (Validate (Tree QGoalReasons)) -> Validate (Tree QGoalReasons) + go :: TreeF (QGoalReasonChain, Scope) (Validate (Tree QGoalReasonChain)) -> Validate (Tree QGoalReasonChain) go (PChoiceF qpn (gr, sc) ts) = PChoice qpn gr <$> sequence (P.mapWithKey (goP qpn gr sc) ts) go (FChoiceF qfn (gr, _sc) b m ts) = @@ -117,7 +117,7 @@ go (FailF c fr ) = pure (Fail c fr) -- What to do for package nodes ... - goP :: QPN -> QGoalReasons -> Scope -> I -> Validate (Tree QGoalReasons) -> Validate (Tree QGoalReasons) + goP :: QPN -> QGoalReasonChain -> Scope -> I -> Validate (Tree QGoalReasonChain) -> Validate (Tree QGoalReasonChain) goP qpn@(Q _pp pn) gr sc i r = do PA ppa pfa psa <- asks pa -- obtain current preassignment idx <- asks index -- obtain the index @@ -142,7 +142,7 @@ local (\ s -> s { pa = PA nppa pfa psa, saved = nsvd }) r -- What to do for flag nodes ... - goF :: QFN -> QGoalReasons -> Bool -> Validate (Tree QGoalReasons) -> Validate (Tree QGoalReasons) + goF :: QFN -> QGoalReasonChain -> Bool -> Validate (Tree QGoalReasonChain) -> Validate (Tree QGoalReasonChain) goF qfn@(FN (PI qpn _i) _f) gr b r = do PA ppa pfa psa <- asks pa -- obtain current preassignment svd <- asks saved -- obtain saved dependencies @@ -164,7 +164,7 @@ Right nppa -> local (\ s -> s { pa = PA nppa npfa psa }) r -- What to do for stanza nodes (similar to flag nodes) ... - goS :: QSN -> QGoalReasons -> Bool -> Validate (Tree QGoalReasons) -> Validate (Tree QGoalReasons) + goS :: QSN -> QGoalReasonChain -> Bool -> Validate (Tree QGoalReasonChain) -> Validate (Tree QGoalReasonChain) goS qsn@(SN (PI qpn _i) _f) gr b r = do PA ppa pfa psa <- asks pa -- obtain current preassignment svd <- asks saved -- obtain saved dependencies @@ -205,7 +205,7 @@ -- | We try to find new dependencies that become available due to the given -- flag or stanza choice. We therefore look for the choice in question, and then call -- 'extractDeps' for everything underneath. -extractNewDeps :: Var QPN -> QGoalReasons -> Bool -> FAssignment -> SAssignment -> FlaggedDeps QPN -> [Dep QPN] +extractNewDeps :: Var QPN -> QGoalReasonChain -> Bool -> FAssignment -> SAssignment -> FlaggedDeps QPN -> [Dep QPN] extractNewDeps v gr b fa sa = go where go deps = do @@ -228,5 +228,5 @@ Just False -> [] -- | Interface. -validateTree :: Index -> Tree (QGoalReasons, Scope) -> Tree QGoalReasons +validateTree :: Index -> Tree (QGoalReasonChain, Scope) -> Tree QGoalReasonChain validateTree idx t = runReader (validate t) (VS idx M.empty (PA M.empty M.empty M.empty)) diff --git a/Distribution/Client/Dependency/TopDown.hs b/Distribution/Client/Dependency/TopDown.hs --- a/Distribution/Client/Dependency/TopDown.hs +++ b/Distribution/Client/Dependency/TopDown.hs @@ -406,7 +406,7 @@ dependencySatisfiable = not . null . PackageIndex.lookupDependency available --- | Annotate each installed packages with its set of transative dependencies +-- | Annotate each installed packages with its set of transitive dependencies -- and its topological sort number. -- annotateInstalledPackages :: (PackageName -> TopologicalSortNumber) diff --git a/Distribution/Client/Dependency/TopDown/Types.hs b/Distribution/Client/Dependency/TopDown/Types.hs --- a/Distribution/Client/Dependency/TopDown/Types.hs +++ b/Distribution/Client/Dependency/TopDown/Types.hs @@ -43,7 +43,7 @@ = InstalledPackageEx InstalledPackage !TopologicalSortNumber - [PackageIdentifier] -- transative closure of installed deps + [PackageIdentifier] -- transitive closure of installed deps data UnconfiguredPackage = UnconfiguredPackage diff --git a/Distribution/Client/Dependency/Types.hs b/Distribution/Client/Dependency/Types.hs --- a/Distribution/Client/Dependency/Types.hs +++ b/Distribution/Client/Dependency/Types.hs @@ -138,7 +138,7 @@ -- data PackagePreferences = PackagePreferences VersionRange InstalledPreference --- | Wether we prefer an installed version of a package or simply the latest +-- | Whether we prefer an installed version of a package or simply the latest -- version. -- data InstalledPreference = PreferInstalled | PreferLatest @@ -175,8 +175,8 @@ | Fail fail | Done done --- | Consume a 'Progres' calculation. Much like 'foldr' for lists but with --- two base cases, one for a final result and one for failure. +-- | Consume a 'Progress' calculation. Much like 'foldr' for lists but with two +-- base cases, one for a final result and one for failure. -- -- Eg to convert into a simple 'Either' result use: -- diff --git a/Distribution/Client/Fetch.hs b/Distribution/Client/Fetch.hs --- a/Distribution/Client/Fetch.hs +++ b/Distribution/Client/Fetch.hs @@ -37,7 +37,7 @@ import Distribution.Simple.Utils ( die, notice, debug ) import Distribution.System - ( buildPlatform ) + ( Platform ) import Distribution.Text ( display ) import Distribution.Verbosity @@ -66,15 +66,16 @@ -> PackageDBStack -> [Repo] -> Compiler + -> Platform -> ProgramConfiguration -> GlobalFlags -> FetchFlags -> [UserTarget] -> IO () -fetch verbosity _ _ _ _ _ _ [] = +fetch verbosity _ _ _ _ _ _ _ [] = notice verbosity "No packages requested. Nothing to do." -fetch verbosity packageDBs repos comp conf +fetch verbosity packageDBs repos comp platform conf globalFlags fetchFlags userTargets = do mapM_ checkTarget userTargets @@ -88,7 +89,7 @@ userTargets pkgs <- planPackages - verbosity comp fetchFlags + verbosity comp platform fetchFlags installedPkgIndex sourcePkgDb pkgSpecifiers pkgs' <- filterM (fmap not . isFetched . packageSource) pkgs @@ -111,20 +112,22 @@ planPackages :: Verbosity -> Compiler + -> Platform -> FetchFlags -> PackageIndex -> SourcePackageDb -> [PackageSpecifier SourcePackage] -> IO [SourcePackage] -planPackages verbosity comp fetchFlags +planPackages verbosity comp platform fetchFlags installedPkgIndex sourcePkgDb pkgSpecifiers | includeDependencies = do - solver <- chooseSolver verbosity (fromFlag (fetchSolver fetchFlags)) (compilerId comp) + solver <- chooseSolver verbosity + (fromFlag (fetchSolver fetchFlags)) (compilerId comp) notice verbosity "Resolving dependencies..." installPlan <- foldProgress logMsg die return $ resolveDependencies - buildPlatform (compilerId comp) + platform (compilerId comp) solver resolverParams diff --git a/Distribution/Client/FetchUtils.hs b/Distribution/Client/FetchUtils.hs --- a/Distribution/Client/FetchUtils.hs +++ b/Distribution/Client/FetchUtils.hs @@ -27,7 +27,7 @@ import Distribution.Client.Types import Distribution.Client.HttpUtils - ( downloadURI, isOldHackageURI ) + ( downloadURI, isOldHackageURI, DownloadResult(..) ) import Distribution.Package ( PackageId, packageName, packageVersion ) @@ -113,7 +113,7 @@ tmpdir <- getTemporaryDirectory (path, hnd) <- openTempFile tmpdir "cabal-.tar.gz" hClose hnd - downloadURI verbosity uri path + _ <- downloadURI verbosity uri path return path @@ -136,12 +136,12 @@ dir = packageDir repo pkgid path = packageFile repo pkgid createDirectoryIfMissing True dir - downloadURI verbosity uri path + _ <- downloadURI verbosity uri path return path -- | Downloads an index file to [config-dir/packages/serv-id]. -- -downloadIndex :: Verbosity -> RemoteRepo -> FilePath -> IO FilePath +downloadIndex :: Verbosity -> RemoteRepo -> FilePath -> IO DownloadResult downloadIndex verbosity repo cacheDir = do let uri = (remoteRepoURI repo) { uriPath = uriPath (remoteRepoURI repo) @@ -150,7 +150,6 @@ path = cacheDir "00-index" <.> "tar.gz" createDirectoryIfMissing True cacheDir downloadURI verbosity uri path - return path -- ------------------------------------------------------------ diff --git a/Distribution/Client/GZipUtils.hs b/Distribution/Client/GZipUtils.hs --- a/Distribution/Client/GZipUtils.hs +++ b/Distribution/Client/GZipUtils.hs @@ -27,7 +27,7 @@ -- -- This is to deal with http proxies that lie to us and transparently -- decompress without removing the content-encoding header. See: --- +-- -- maybeDecompress :: ByteString -> ByteString maybeDecompress bytes = foldStream $ decompressWithErrors gzipOrZlibFormat defaultDecompressParams bytes diff --git a/Distribution/Client/Get.hs b/Distribution/Client/Get.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Get.hs @@ -0,0 +1,350 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Get +-- Copyright : (c) Andrea Vezzosi 2008 +-- Duncan Coutts 2011 +-- John Millikin 2012 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- The 'cabal get' command. +----------------------------------------------------------------------------- + +module Distribution.Client.Get ( + get + ) where + +import Distribution.Package + ( PackageId, packageId, packageName ) +import Distribution.Simple.Setup + ( Flag(..), fromFlag, fromFlagOrDefault ) +import Distribution.Simple.Utils + ( notice, die, info, writeFileAtomic ) +import Distribution.Verbosity + ( Verbosity ) +import Distribution.Text(display) +import qualified Distribution.PackageDescription as PD + +import Distribution.Client.Setup + ( GlobalFlags(..), GetFlags(..) ) +import Distribution.Client.Types +import Distribution.Client.Targets +import Distribution.Client.Dependency +import Distribution.Client.FetchUtils +import qualified Distribution.Client.Tar as Tar (extractTarGzFile) +import Distribution.Client.IndexUtils as IndexUtils + ( getSourcePackages ) +import Distribution.Compat.Exception + ( catchIO ) + +import Control.Exception + ( finally ) +import Control.Monad + ( filterM, forM_, unless, when ) +import Data.List + ( sortBy ) +import qualified Data.Map +import Data.Maybe + ( listToMaybe, mapMaybe ) +import Data.Monoid + ( mempty ) +import Data.Ord + ( comparing ) +import System.Directory + ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist + , getCurrentDirectory, setCurrentDirectory + ) +import System.Exit + ( ExitCode(..) ) +import System.FilePath + ( (), (<.>), addTrailingPathSeparator ) +import System.Process + ( rawSystem, readProcessWithExitCode ) + + +-- | Entry point for the 'cabal get' command. +get :: Verbosity + -> [Repo] + -> GlobalFlags + -> GetFlags + -> [UserTarget] + -> IO () +get verbosity _ _ _ [] = + notice verbosity "No packages requested. Nothing to do." + +get verbosity repos globalFlags getFlags userTargets = do + let useFork = case (getSourceRepository getFlags) of + NoFlag -> False + _ -> True + + unless useFork $ + mapM_ checkTarget userTargets + + sourcePkgDb <- getSourcePackages verbosity repos + + pkgSpecifiers <- resolveUserTargets verbosity + (fromFlag $ globalWorldFile globalFlags) + (packageIndex sourcePkgDb) + userTargets + + pkgs <- either (die . unlines . map show) return $ + resolveWithoutDependencies + (resolverParams sourcePkgDb pkgSpecifiers) + + unless (null prefix) $ + createDirectoryIfMissing True prefix + + if useFork + then fork pkgs + else unpack pkgs + + where + resolverParams sourcePkgDb pkgSpecifiers = + --TODO: add commandline constraint and preference args for unpack + standardInstallPolicy mempty sourcePkgDb pkgSpecifiers + + prefix = fromFlagOrDefault "" (getDestDir getFlags) + + fork :: [SourcePackage] -> IO () + fork pkgs = do + let kind = fromFlag . getSourceRepository $ getFlags + branchers <- findUsableBranchers + mapM_ (forkPackage verbosity branchers prefix kind) pkgs + + unpack :: [SourcePackage] -> IO () + unpack pkgs = do + forM_ pkgs $ \pkg -> do + location <- fetchPackage verbosity (packageSource pkg) + let pkgid = packageId pkg + descOverride | usePristine = Nothing + | otherwise = packageDescrOverride pkg + case location of + LocalTarballPackage tarballPath -> + unpackPackage verbosity prefix pkgid descOverride tarballPath + + RemoteTarballPackage _tarballURL tarballPath -> + unpackPackage verbosity prefix pkgid descOverride tarballPath + + RepoTarballPackage _repo _pkgid tarballPath -> + unpackPackage verbosity prefix pkgid descOverride tarballPath + + LocalUnpackedPackage _ -> + error "Distribution.Client.Get.unpack: the impossible happened." + where + usePristine = fromFlagOrDefault False (getPristine getFlags) + +checkTarget :: UserTarget -> IO () +checkTarget target = case target of + UserTargetLocalDir dir -> die (notTarball dir) + UserTargetLocalCabalFile file -> die (notTarball file) + _ -> return () + where + notTarball t = + "The 'get' command is for tarball packages. " + ++ "The target '" ++ t ++ "' is not a tarball." + +-- ------------------------------------------------------------ +-- * Unpacking the source tarball +-- ------------------------------------------------------------ + +unpackPackage :: Verbosity -> FilePath -> PackageId + -> PackageDescriptionOverride + -> FilePath -> IO () +unpackPackage verbosity prefix pkgid descOverride pkgPath = do + let pkgdirname = display pkgid + pkgdir = prefix pkgdirname + pkgdir' = addTrailingPathSeparator pkgdir + existsDir <- doesDirectoryExist pkgdir + when existsDir $ die $ + "The directory \"" ++ pkgdir' ++ "\" already exists, not unpacking." + existsFile <- doesFileExist pkgdir + when existsFile $ die $ + "A file \"" ++ pkgdir ++ "\" is in the way, not unpacking." + notice verbosity $ "Unpacking to " ++ pkgdir' + Tar.extractTarGzFile prefix pkgdirname pkgPath + + case descOverride of + Nothing -> return () + Just pkgtxt -> do + let descFilePath = pkgdir display (packageName pkgid) <.> "cabal" + info verbosity $ + "Updating " ++ descFilePath + ++ " with the latest revision from the index." + writeFileAtomic descFilePath pkgtxt + + +-- ------------------------------------------------------------ +-- * Forking the source repository +-- ------------------------------------------------------------ + +data BranchCmd = BranchCmd (Verbosity -> FilePath -> IO ExitCode) + +data Brancher = Brancher + { brancherBinary :: String + , brancherBuildCmd :: PD.SourceRepo -> Maybe BranchCmd + } + +-- | The set of all supported branch drivers. +allBranchers :: [(PD.RepoType, Brancher)] +allBranchers = + [ (PD.Bazaar, branchBzr) + , (PD.Darcs, branchDarcs) + , (PD.Git, branchGit) + , (PD.Mercurial, branchHg) + , (PD.SVN, branchSvn) + ] + +-- | Find which usable branch drivers (selected from 'allBranchers') are +-- available and usable on the local machine. +-- +-- Each driver's main command is run with @--help@, and if the child process +-- exits successfully, that brancher is considered usable. +findUsableBranchers :: IO (Data.Map.Map PD.RepoType Brancher) +findUsableBranchers = do + let usable (_, brancher) = flip catchIO (const (return False)) $ do + let cmd = brancherBinary brancher + (exitCode, _, _) <- readProcessWithExitCode cmd ["--help"] "" + return (exitCode == ExitSuccess) + pairs <- filterM usable allBranchers + return (Data.Map.fromList pairs) + +-- | Fork a single package from a remote source repository to the local +-- filesystem. +forkPackage :: Verbosity + -> Data.Map.Map PD.RepoType Brancher + -- ^ Branchers supported by the local machine. + -> FilePath + -- ^ The directory in which new branches or repositories will + -- be created. + -> (Maybe PD.RepoKind) + -- ^ Which repo to choose. + -> SourcePackage + -- ^ The package to fork. + -> IO () +forkPackage verbosity branchers prefix kind src = do + let desc = PD.packageDescription (packageDescription src) + pkgid = display (packageId src) + pkgname = display (packageName src) + destdir = prefix pkgname + + destDirExists <- doesDirectoryExist destdir + when destDirExists $ do + die ("The directory " ++ show destdir ++ " already exists, not forking.") + + destFileExists <- doesFileExist destdir + when destFileExists $ do + die ("A file " ++ show destdir ++ " is in the way, not forking.") + + let repos = PD.sourceRepos desc + case findBranchCmd branchers repos kind of + Just (BranchCmd io) -> do + exitCode <- io verbosity destdir + case exitCode of + ExitSuccess -> return () + ExitFailure _ -> die ("Couldn't fork package " ++ pkgid) + Nothing -> case repos of + [] -> die ("Package " ++ pkgid + ++ " does not have any source repositories.") + _ -> die ("Package " ++ pkgid + ++ " does not have any usable source repositories.") + +-- | Given a set of possible branchers, and a set of possible source +-- repositories, find a repository that is both 1) likely to be specific to +-- this source version and 2) is supported by the local machine. +findBranchCmd :: Data.Map.Map PD.RepoType Brancher -> [PD.SourceRepo] + -> (Maybe PD.RepoKind) -> Maybe BranchCmd +findBranchCmd branchers allRepos maybeKind = cmd where + -- Sort repositories by kind, from This to Head to Unknown. Repositories + -- with equivalent kinds are selected based on the order they appear in + -- the Cabal description file. + repos' = sortBy (comparing thisFirst) allRepos + thisFirst r = case PD.repoKind r of + PD.RepoThis -> 0 :: Int + PD.RepoHead -> case PD.repoTag r of + -- If the type is 'head' but the author specified a tag, they + -- probably meant to create a 'this' repository but screwed up. + Just _ -> 0 + Nothing -> 1 + PD.RepoKindUnknown _ -> 2 + + -- If the user has specified the repo kind, filter out the repositories + -- she's not interested in. + repos = maybe repos' (\k -> filter ((==) k . PD.repoKind) repos') maybeKind + + repoBranchCmd repo = do + t <- PD.repoType repo + brancher <- Data.Map.lookup t branchers + brancherBuildCmd brancher repo + + cmd = listToMaybe (mapMaybe repoBranchCmd repos) + +-- | Branch driver for Bazaar. +branchBzr :: Brancher +branchBzr = Brancher "bzr" $ \repo -> do + src <- PD.repoLocation repo + let args dst = case PD.repoTag repo of + Just tag -> ["branch", src, dst, "-r", "tag:" ++ tag] + Nothing -> ["branch", src, dst] + return $ BranchCmd $ \verbosity dst -> do + notice verbosity ("bzr: branch " ++ show src) + rawSystem "bzr" (args dst) + +-- | Branch driver for Darcs. +branchDarcs :: Brancher +branchDarcs = Brancher "darcs" $ \repo -> do + src <- PD.repoLocation repo + let args dst = case PD.repoTag repo of + Just tag -> ["get", src, dst, "-t", tag] + Nothing -> ["get", src, dst] + return $ BranchCmd $ \verbosity dst -> do + notice verbosity ("darcs: get " ++ show src) + rawSystem "darcs" (args dst) + +-- | Branch driver for Git. +branchGit :: Brancher +branchGit = Brancher "git" $ \repo -> do + src <- PD.repoLocation repo + let branchArgs = case PD.repoBranch repo of + Just b -> ["--branch", b] + Nothing -> [] + let postClone dst = case PD.repoTag repo of + Just t -> do + cwd <- getCurrentDirectory + setCurrentDirectory dst + finally + (rawSystem "git" (["checkout", t] ++ branchArgs)) + (setCurrentDirectory cwd) + Nothing -> return ExitSuccess + return $ BranchCmd $ \verbosity dst -> do + notice verbosity ("git: clone " ++ show src) + code <- rawSystem "git" (["clone", src, dst] ++ branchArgs) + case code of + ExitFailure _ -> return code + ExitSuccess -> postClone dst + +-- | Branch driver for Mercurial. +branchHg :: Brancher +branchHg = Brancher "hg" $ \repo -> do + src <- PD.repoLocation repo + let branchArgs = case PD.repoBranch repo of + Just b -> ["--branch", b] + Nothing -> [] + let tagArgs = case PD.repoTag repo of + Just t -> ["--rev", t] + Nothing -> [] + let args dst = ["clone", src, dst] ++ branchArgs ++ tagArgs + return $ BranchCmd $ \verbosity dst -> do + notice verbosity ("hg: clone " ++ show src) + rawSystem "hg" (args dst) + +-- | Branch driver for Subversion. +branchSvn :: Brancher +branchSvn = Brancher "svn" $ \repo -> do + src <- PD.repoLocation repo + let args dst = ["checkout", src, dst] + return $ BranchCmd $ \verbosity dst -> do + notice verbosity ("svn: checkout " ++ show src) + rawSystem "svn" (args dst) diff --git a/Distribution/Client/Haddock.hs b/Distribution/Client/Haddock.hs --- a/Distribution/Client/Haddock.hs +++ b/Distribution/Client/Haddock.hs @@ -21,7 +21,7 @@ import Control.Monad (guard) import System.Directory (createDirectoryIfMissing, doesFileExist, renameFile) -import System.FilePath ((), splitFileName) +import System.FilePath ((), splitFileName, isAbsolute) import Distribution.Package ( Package(..), packageVersion ) import Distribution.Simple.Program (haddockProgram, ProgramConfiguration @@ -57,7 +57,7 @@ , "--gen-index" , "--odir=" ++ tempDir , "--title=Haskell modules on this system" ] - ++ [ "--read-interface=" ++ html ++ "," ++ interface + ++ [ "--read-interface=" ++ mkUrl html ++ "," ++ interface | (interface, html) <- paths ] rawSystemProgram verbosity confHaddock flags renameFile (tempDir "index.html") (tempDir destFile) @@ -69,6 +69,11 @@ | (_pname, pkgvers) <- allPackagesByName pkgs , let pkgvers' = filter exposed pkgvers , not (null pkgvers') ] + -- See https://github.com/haskell/cabal/issues/1064 + mkUrl f = + if isAbsolute f + then "file://" ++ f + else f haddockPackagePaths :: [InstalledPackageInfo] -> IO ([(FilePath, FilePath)], Maybe String) diff --git a/Distribution/Client/HttpUtils.hs b/Distribution/Client/HttpUtils.hs --- a/Distribution/Client/HttpUtils.hs +++ b/Distribution/Client/HttpUtils.hs @@ -1,8 +1,8 @@ -{-# OPTIONS -cpp #-} ----------------------------------------------------------------------------- --- | Separate module for HTTP actions, using a proxy server if one exists +-- | Separate module for HTTP actions, using a proxy server if one exists ----------------------------------------------------------------------------- module Distribution.Client.HttpUtils ( + DownloadResult(..), downloadURI, getHTTP, cabalBrowse, @@ -12,148 +12,71 @@ import Network.HTTP ( Request (..), Response (..), RequestMethod (..) - , Header(..), HeaderName(..) ) + , Header(..), HeaderName(..), lookupHeader ) +import Network.HTTP.Proxy ( Proxy(..), fetchProxy) import Network.URI - ( URI (..), URIAuth (..), parseAbsoluteURI ) -import Network.Stream - ( Result, ConnError(..) ) + ( URI (..), URIAuth (..) ) import Network.Browser - ( Proxy (..), Authority (..), BrowserAction, browse + ( BrowserAction, browse , setOutHandler, setErrHandler, setProxy, setAuthorityGen, request) +import Network.Stream + ( Result, ConnError(..) ) import Control.Monad - ( mplus, join, liftM, liftM2 ) + ( liftM ) import qualified Data.ByteString.Lazy.Char8 as ByteString import Data.ByteString.Lazy (ByteString) -#ifdef WIN32 -import System.Win32.Types - ( DWORD, HKEY ) -import System.Win32.Registry - ( hKEY_CURRENT_USER, regOpenKey, regCloseKey - , regQueryValue, regQueryValueEx ) -import Control.Exception - ( bracket ) -import Distribution.Compat.Exception - ( handleIO ) -import Foreign - ( toBool, Storable(peek, sizeOf), castPtr, alloca ) -#endif -import System.Environment (getEnvironment) import qualified Paths_cabal_install_bundle (version) import Distribution.Verbosity (Verbosity) import Distribution.Simple.Utils - ( die, info, warn, debug + ( die, info, warn, debug, notice , copyFileVerbose, writeFileAtomic ) import Distribution.Text ( display ) +import Data.Char ( isSpace ) import qualified System.FilePath.Posix as FilePath.Posix ( splitDirectories ) - --- FIXME: all this proxy stuff is far too complicated, especially parsing --- the proxy strings. Network.Browser should have a way to pick up the --- proxy settings hiding all this system-dependent stuff below. - --- try to read the system proxy settings on windows or unix -proxyString, envProxyString, registryProxyString :: IO (Maybe String) -#ifdef WIN32 --- read proxy settings from the windows registry -registryProxyString = handleIO (\_ -> return Nothing) $ - bracket (regOpenKey hive path) regCloseKey $ \hkey -> do - enable <- fmap toBool $ regQueryValueDWORD hkey "ProxyEnable" - if enable - then fmap Just $ regQueryValue hkey (Just "ProxyServer") - else return Nothing - where - -- some sources say proxy settings should be at - -- HKEY_LOCAL_MACHINE\SOFTWARE\Policies\Microsoft\Windows - -- \CurrentVersion\Internet Settings\ProxyServer - -- but if the user sets them with IE connection panel they seem to - -- end up in the following place: - hive = hKEY_CURRENT_USER - path = "Software\\Microsoft\\Windows\\CurrentVersion\\Internet Settings" - - regQueryValueDWORD :: HKEY -> String -> IO DWORD - regQueryValueDWORD hkey name = alloca $ \ptr -> do - regQueryValueEx hkey name (castPtr ptr) (sizeOf (undefined :: DWORD)) - peek ptr -#else -registryProxyString = return Nothing -#endif - --- read proxy settings by looking for an env var -envProxyString = do - env <- getEnvironment - return (lookup "http_proxy" env `mplus` lookup "HTTP_PROXY" env) +import System.FilePath + ( (<.>) ) +import System.Directory + ( doesFileExist ) -proxyString = liftM2 mplus envProxyString registryProxyString +data DownloadResult = FileAlreadyInCache | FileDownloaded FilePath deriving (Eq) +-- Trime +trim :: String -> String +trim = f . f + where f = reverse . dropWhile isSpace --- |Get the local proxy settings +-- |Get the local proxy settings +--TODO: print info message when we're using a proxy based on verbosity proxy :: Verbosity -> IO Proxy -proxy verbosity = do - mstr <- proxyString - case mstr of - Nothing -> return NoProxy - Just str -> case parseHttpProxy str of - Nothing -> do - warn verbosity $ "invalid http proxy uri: " ++ show str - warn verbosity $ "proxy uri must be http with a hostname" - warn verbosity $ "ignoring http proxy, trying a direct connection" - return NoProxy - Just p -> return p ---TODO: print info message when we're using a proxy - --- | We need to be able to parse non-URIs like @\"wwwcache.example.com:80\"@ --- which lack the @\"http://\"@ URI scheme. The problem is that --- @\"wwwcache.example.com:80\"@ is in fact a valid URI but with scheme --- @\"wwwcache.example.com:\"@, no authority part and a path of @\"80\"@. --- --- So our strategy is to try parsing as normal uri first and if it lacks the --- 'uriAuthority' then we try parsing again with a @\"http://\"@ prefix. --- -parseHttpProxy :: String -> Maybe Proxy -parseHttpProxy str = join - . fmap uri2proxy - $ parseHttpURI str - `mplus` parseHttpURI ("http://" ++ str) - where - parseHttpURI str' = case parseAbsoluteURI str' of - Just uri@URI { uriAuthority = Just _ } - -> Just (fixUserInfo uri) - _ -> Nothing - -fixUserInfo :: URI -> URI -fixUserInfo uri = uri{ uriAuthority = f `fmap` uriAuthority uri } - where - f a@URIAuth{ uriUserInfo = s } = - a{ uriUserInfo = case reverse s of - '@':s' -> reverse s' - _ -> s - } -uri2proxy :: URI -> Maybe Proxy -uri2proxy uri@URI{ uriScheme = "http:" - , uriAuthority = Just (URIAuth auth' host port) - } = Just (Proxy (host ++ port) auth) - where auth = if null auth' - then Nothing - else Just (AuthBasic "" usr pwd uri) - (usr,pwd') = break (==':') auth' - pwd = case pwd' of - ':':cs -> cs - _ -> pwd' -uri2proxy _ = Nothing +proxy _verbosity = do + p <- fetchProxy True + -- Handle empty proxy strings + return $ case p of + Proxy uri auth -> + let uri' = trim uri in + if uri' == "" then NoProxy else Proxy uri' auth + _ -> p -mkRequest :: URI -> Request ByteString -mkRequest uri = Request{ rqURI = uri - , rqMethod = GET - , rqHeaders = [Header HdrUserAgent userAgent] - , rqBody = ByteString.empty } +mkRequest :: URI + -> Maybe String -- ^ Optional etag to be set in the If-None-Match HTTP header. + -> Request ByteString +mkRequest uri etag = Request{ rqURI = uri + , rqMethod = GET + , rqHeaders = Header HdrUserAgent userAgent : ifNoneMatchHdr + , rqBody = ByteString.empty } where userAgent = "cabal-install/" ++ display Paths_cabal_install_bundle.version + ifNoneMatchHdr = maybe [] (\t -> [Header HdrIfNoneMatch t]) etag -- |Carry out a GET request, using the local proxy settings -getHTTP :: Verbosity -> URI -> IO (Result (Response ByteString)) -getHTTP verbosity uri = liftM (\(_, resp) -> Right resp) $ - cabalBrowse verbosity (return ()) (request (mkRequest uri)) +getHTTP :: Verbosity + -> URI + -> Maybe String -- ^ Optional etag to check if we already have the latest file. + -> IO (Result (Response ByteString)) +getHTTP verbosity uri etag = liftM (\(_, resp) -> Right resp) $ + cabalBrowse verbosity (return ()) (request (mkRequest uri etag)) cabalBrowse :: Verbosity -> BrowserAction s () @@ -172,29 +95,56 @@ downloadURI :: Verbosity -> URI -- ^ What to download -> FilePath -- ^ Where to put it - -> IO () -downloadURI verbosity uri path | uriScheme uri == "file:" = + -> IO DownloadResult +downloadURI verbosity uri path | uriScheme uri == "file:" = do copyFileVerbose verbosity (uriPath uri) path + return (FileDownloaded path) + -- Can we store the hash of the file so we can safely return path when the + -- hash matches to avoid unnecessary computation? downloadURI verbosity uri path = do - result <- getHTTP verbosity uri + let etagPath = path <.> "etag" + targetExists <- doesFileExist path + etagPathExists <- doesFileExist etagPath + -- In rare cases the target file doesn't exist, but the etag does. + etag <- if targetExists && etagPathExists + then liftM Just $ readFile etagPath + else return Nothing + + result <- getHTTP verbosity uri etag let result' = case result of Left err -> Left err Right rsp -> case rspCode rsp of - (2,0,0) -> Right (rspBody rsp) + (2,0,0) -> Right rsp + (3,0,4) -> Right rsp (a,b,c) -> Left err where - err = ErrorMisc $ "Unsucessful HTTP code: " - ++ concatMap show [a,b,c] + err = ErrorMisc $ "Error HTTP code: " + ++ concatMap show [a,b,c] + -- Only write the etag if we get a 200 response code. + -- A 304 still sends us an etag header. case result' of + Left _ -> return () + Right rsp -> case rspCode rsp of + (2,0,0) -> case lookupHeader HdrETag (rspHeaders rsp) of + Nothing -> return () + Just newEtag -> writeFile etagPath newEtag + (_,_,_) -> return () + + case result' of Left err -> die $ "Failed to download " ++ show uri ++ " : " ++ show err - Right body -> do - info verbosity ("Downloaded to " ++ path) - writeFileAtomic path (ByteString.unpack body) + Right rsp -> case rspCode rsp of + (2,0,0) -> do + info verbosity ("Downloaded to " ++ path) + writeFileAtomic path $ rspBody rsp + return (FileDownloaded path) + (3,0,4) -> do + notice verbosity "Skipping download: Local and remote files match." + return FileAlreadyInCache + (_,_,_) -> return (FileDownloaded path) --FIXME: check the content-length header matches the body length. --TODO: stream the download into the file rather than buffering the whole -- thing in memory. - -- remember the ETag so we can not re-download if nothing changed. -- Utility function for legacy support. isOldHackageURI :: URI -> Bool diff --git a/Distribution/Client/IndexUtils.hs b/Distribution/Client/IndexUtils.hs --- a/Distribution/Client/IndexUtils.hs +++ b/Distribution/Client/IndexUtils.hs @@ -13,12 +13,15 @@ module Distribution.Client.IndexUtils ( getInstalledPackages, getSourcePackages, + getSourcePackagesStrict, convert, readPackageIndexFile, parsePackageIndex, readRepoIndex, updateRepoIndexCache, + + BuildTreeRefType(..), refTypeFromTypeCode, typeCodeFromRefType ) where import qualified Distribution.Client.Tar as Tar @@ -29,9 +32,10 @@ , Package(..), packageVersion, packageName , Dependency(Dependency), InstalledPackageId(..) ) import Distribution.Client.PackageIndex (PackageIndex) -import qualified Distribution.Client.PackageIndex as PackageIndex -import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex -import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo +import qualified Distribution.Client.PackageIndex as PackageIndex +import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex +import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo +import qualified Distribution.PackageDescription.Parse as PackageDesc.Parse import Distribution.PackageDescription ( GenericPackageDescription ) import Distribution.PackageDescription.Parse @@ -49,32 +53,32 @@ import Distribution.Text ( display, simpleParse ) import Distribution.Verbosity - ( Verbosity, lessVerbose ) + ( Verbosity, normal, lessVerbose ) import Distribution.Simple.Utils - ( die, warn, info, fromUTF8 ) + ( die, warn, info, fromUTF8, findPackageDesc ) import Data.Char (isAlphaNum) -import Data.Maybe (catMaybes, fromMaybe) +import Data.Maybe (mapMaybe, fromMaybe) import Data.List (isPrefixOf) import Data.Monoid (Monoid(..)) import qualified Data.Map as Map -import Control.Monad (MonadPlus(mplus), when, unless, liftM) +import Control.Monad (MonadPlus(mplus), when, liftM) import Control.Exception (evaluate) import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy.Char8 as BS.Char8 import qualified Data.ByteString.Char8 as BSS import Data.ByteString.Lazy (ByteString) import Distribution.Client.GZipUtils (maybeDecompress) +import Distribution.Client.Utils (byteStringToFilePath) +import Distribution.Compat.Exception (catchIO) +import Distribution.Client.Compat.Time +import System.Directory (doesFileExist) import System.FilePath ((), takeExtension, splitDirectories, normalise) import System.FilePath.Posix as FilePath.Posix ( takeFileName ) import System.IO import System.IO.Unsafe (unsafeInterleaveIO) import System.IO.Error (isDoesNotExistError) -import Distribution.Compat.Exception (catchIO) -import System.Directory - ( getModificationTime, doesFileExist ) -import Distribution.Compat.Time getInstalledPackages :: Verbosity -> Compiler @@ -128,16 +132,29 @@ -- This is a higher level wrapper used internally in cabal-install. -- getSourcePackages :: Verbosity -> [Repo] -> IO SourcePackageDb -getSourcePackages verbosity [] = do +getSourcePackages verbosity repos = getSourcePackages' verbosity repos + ReadPackageIndexLazyIO + +-- | Like 'getSourcePackages', but reads the package index strictly. Useful if +-- you want to write to the package index after having read it. +getSourcePackagesStrict :: Verbosity -> [Repo] -> IO SourcePackageDb +getSourcePackagesStrict verbosity repos = getSourcePackages' verbosity repos + ReadPackageIndexStrict + +-- | Common implementation used by getSourcePackages and +-- getSourcePackagesStrict. +getSourcePackages' :: Verbosity -> [Repo] -> ReadPackageIndexMode + -> IO SourcePackageDb +getSourcePackages' verbosity [] _mode = do warn verbosity $ "No remote package servers have been specified. Usually " ++ "you would have one specified in the config file." return SourcePackageDb { packageIndex = mempty, packagePreferences = mempty } -getSourcePackages verbosity repos = do +getSourcePackages' verbosity repos mode = do info verbosity "Reading available packages..." - pkgss <- mapM (readRepoIndex verbosity) repos + pkgss <- mapM (\r -> readRepoIndex verbosity r mode) repos let (pkgs, prefs) = mconcat pkgss prefs' = Map.fromListWith intersectVersionRanges [ (name, range) | Dependency name range <- prefs ] @@ -148,7 +165,6 @@ packagePreferences = prefs' } - -- | Read a repository index from disk, from the local file specified by -- the 'Repo'. -- @@ -156,26 +172,32 @@ -- -- This is a higher level wrapper used internally in cabal-install. -- -readRepoIndex :: Verbosity -> Repo +readRepoIndex :: Verbosity -> Repo -> ReadPackageIndexMode -> IO (PackageIndex SourcePackage, [Dependency]) -readRepoIndex verbosity repo = +readRepoIndex verbosity repo mode = let indexFile = repoLocalDir repo "00-index.tar" cacheFile = repoLocalDir repo "00-index.cache" in handleNotFound $ do warnIfIndexIsOld indexFile whenCacheOutOfDate indexFile cacheFile $ do - info verbosity $ "Updating the index cache file..." + info verbosity "Updating the index cache file..." updatePackageIndexCacheFile indexFile cacheFile - readPackageIndexCacheFile mkAvailablePackage indexFile cacheFile + readPackageIndexCacheFile mkAvailablePackage indexFile cacheFile mode where - mkAvailablePackage pkgid pkgtxt pkg = + mkAvailablePackage pkgEntry = SourcePackage { packageInfoId = pkgid, - packageDescription = pkg, - packageSource = RepoTarballPackage repo pkgid Nothing, - packageDescrOverride = Just pkgtxt + packageDescription = packageDesc pkgEntry, + packageSource = case pkgEntry of + NormalPackage _ _ _ _ -> RepoTarballPackage repo pkgid Nothing + BuildTreeRef _ _ _ path _ -> LocalUnpackedPackage path, + packageDescrOverride = case pkgEntry of + NormalPackage _ _ pkgtxt _ -> Just pkgtxt + _ -> Nothing } + where + pkgid = packageId pkgEntry handleNotFound action = catchIO action $ \e -> if isDoesNotExistError e then do @@ -205,27 +227,57 @@ updateRepoIndexCache :: Verbosity -> Repo -> IO () updateRepoIndexCache verbosity repo = whenCacheOutOfDate indexFile cacheFile $ do - info verbosity $ "Updating the index cache file..." + info verbosity "Updating the index cache file..." updatePackageIndexCacheFile indexFile cacheFile where indexFile = repoLocalDir repo "00-index.tar" cacheFile = repoLocalDir repo "00-index.cache" -whenCacheOutOfDate :: FilePath-> FilePath -> IO () -> IO () +whenCacheOutOfDate :: FilePath -> FilePath -> IO () -> IO () whenCacheOutOfDate origFile cacheFile action = do exists <- doesFileExist cacheFile if not exists then action else do - origTime <- getModificationTime origFile - cacheTime <- getModificationTime cacheFile - unless (cacheTime >= origTime) action - + origTime <- getModTime origFile + cacheTime <- getModTime cacheFile + when (origTime >= cacheTime) action ------------------------------------------------------------------------ -- Reading the index file -- +-- | An index entry is either a normal package, or a local build tree reference. +data PackageEntry = + NormalPackage PackageId GenericPackageDescription ByteString BlockNo + | BuildTreeRef BuildTreeRefType + PackageId GenericPackageDescription FilePath BlockNo + +-- | A build tree reference is either a link or a snapshot. +data BuildTreeRefType = SnapshotRef | LinkRef + deriving Eq + +refTypeFromTypeCode :: Tar.TypeCode -> BuildTreeRefType +refTypeFromTypeCode t + | t == Tar.buildTreeRefTypeCode = LinkRef + | t == Tar.buildTreeSnapshotTypeCode = SnapshotRef + | otherwise = + error "Distribution.Client.IndexUtils.refTypeFromTypeCode: unknown type code" + +typeCodeFromRefType :: BuildTreeRefType -> Tar.TypeCode +typeCodeFromRefType LinkRef = Tar.buildTreeRefTypeCode +typeCodeFromRefType SnapshotRef = Tar.buildTreeSnapshotTypeCode + +type MkPackageEntry = IO PackageEntry + +instance Package PackageEntry where + packageId (NormalPackage pkgid _ _ _) = pkgid + packageId (BuildTreeRef _ pkgid _ _ _) = pkgid + +packageDesc :: PackageEntry -> GenericPackageDescription +packageDesc (NormalPackage _ descr _ _) = descr +packageDesc (BuildTreeRef _ _ descr _ _) = descr + -- | Read a compressed \"00-index.tar.gz\" file into a 'PackageIndex'. -- -- This is supposed to be an \"all in one\" way to easily get at the info in @@ -236,26 +288,24 @@ -- case you can just use @\_ p -> p@ here. -- readPackageIndexFile :: Package pkg - => (PackageId -> GenericPackageDescription -> pkg) + => (PackageEntry -> pkg) -> FilePath -> IO (PackageIndex pkg, [Dependency]) readPackageIndexFile mkPkg indexFile = do - (pkgs, prefs) <- either fail return - . parsePackageIndex - . maybeDecompress - =<< BS.readFile indexFile + (mkPkgs, prefs) <- either fail return + . parsePackageIndex + . maybeDecompress + =<< BS.readFile indexFile - pkgs' <- evaluate $ PackageIndex.fromList - [ mkPkg pkgid pkg | (pkgid, pkg, _) <- pkgs] - return (pkgs', prefs) + pkgEntries <- sequence mkPkgs + pkgs <- evaluate $ PackageIndex.fromList (map mkPkg pkgEntries) + return (pkgs, prefs) -- | Parse an uncompressed \"00-index.tar\" repository index file represented -- as a 'ByteString'. -- parsePackageIndex :: ByteString - -> Either String - ( [(PackageId, GenericPackageDescription, BlockNo)] - , [Dependency] ) + -> Either String ([MkPackageEntry], [Dependency]) parsePackageIndex = accum 0 [] [] . Tar.read where accum blockNo pkgs prefs es = case es of @@ -264,7 +314,7 @@ Tar.Next e es' -> accum blockNo' pkgs' prefs' es' where (pkgs', prefs') = extract blockNo pkgs prefs e - blockNo' = blockNo + sizeInBlocks e + blockNo' = blockNo + Tar.entrySizeInBlocks e extract blockNo pkgs prefs entry = fromMaybe (pkgs, prefs) $ @@ -272,28 +322,20 @@ `mplus` tryExtractPrefs where tryExtractPkg = do - (pkgid, pkg) <- extractPkg entry - return ((pkgid, pkg, blockNo):pkgs, prefs) + mkPkgEntry <- extractPkg entry blockNo + return (mkPkgEntry:pkgs, prefs) tryExtractPrefs = do prefs' <- extractPrefs entry return (pkgs, prefs'++prefs) - sizeInBlocks entry = - 1 + case Tar.entryContent entry of - Tar.NormalFile _ size -> bytesToBlocks size - Tar.OtherEntryType _ _ size -> bytesToBlocks size - _ -> 0 - where - bytesToBlocks s = 1 + ((fromIntegral s - 1) `div` 512) - -extractPkg :: Tar.Entry -> Maybe (PackageId, GenericPackageDescription) -extractPkg entry = case Tar.entryContent entry of +extractPkg :: Tar.Entry -> BlockNo -> Maybe MkPackageEntry +extractPkg entry blockNo = case Tar.entryContent entry of Tar.NormalFile content _ | takeExtension fileName == ".cabal" -> case splitDirectories (normalise fileName) of [pkgname,vers,_] -> case simpleParse vers of - Just ver -> Just (pkgid, descr) + Just ver -> Just $ return (NormalPackage pkgid descr content blockNo) where pkgid = PackageIdentifier (PackageName pkgname) ver parsed = parsePackageDescription . fromUTF8 . BS.Char8.unpack @@ -304,7 +346,18 @@ ++ show fileName _ -> Nothing _ -> Nothing + + Tar.OtherEntryType typeCode content _ + | Tar.isBuildTreeRefTypeCode typeCode -> + Just $ do + let path = byteStringToFilePath content + cabalFile <- findPackageDesc path + descr <- PackageDesc.Parse.readPackageDescription normal cabalFile + return $ BuildTreeRef (refTypeFromTypeCode typeCode) (packageId descr) + descr path blockNo + _ -> Nothing + where fileName = Tar.entryPath entry @@ -317,8 +370,7 @@ _ -> Nothing parsePreferredVersions :: String -> [Dependency] -parsePreferredVersions = catMaybes - . map simpleParse +parsePreferredVersions = mapMaybe simpleParse . filter (not . isPrefixOf "--") . lines @@ -328,36 +380,48 @@ updatePackageIndexCacheFile :: FilePath -> FilePath -> IO () updatePackageIndexCacheFile indexFile cacheFile = do - (pkgs, prefs) <- either fail return - . parsePackageIndex - . maybeDecompress - =<< BS.readFile indexFile - let cache = mkCache pkgs prefs + (mkPkgs, prefs) <- either fail return + . parsePackageIndex + . maybeDecompress + =<< BS.readFile indexFile + pkgEntries <- sequence mkPkgs + let cache = mkCache pkgEntries prefs writeFile cacheFile (showIndexCache cache) where mkCache pkgs prefs = [ CachePreference pref | pref <- prefs ] - ++ [ CachePackageId pkgid blockNo | (pkgid, _, blockNo) <- pkgs ] + ++ [ CachePackageId pkgid blockNo + | (NormalPackage pkgid _ _ blockNo) <- pkgs ] + ++ [ CacheBuildTreeRef refType blockNo + | (BuildTreeRef refType _ _ _ blockNo) <- pkgs] +data ReadPackageIndexMode = ReadPackageIndexStrict + | ReadPackageIndexLazyIO + readPackageIndexCacheFile :: Package pkg - => (PackageId -> ByteString - -> GenericPackageDescription -> pkg) + => (PackageEntry -> pkg) -> FilePath -> FilePath + -> ReadPackageIndexMode -> IO (PackageIndex pkg, [Dependency]) -readPackageIndexCacheFile mkPkg indexFile cacheFile = do - indexHnd <- openFile indexFile ReadMode +readPackageIndexCacheFile mkPkg indexFile cacheFile mode = do cache <- liftM readIndexCache (BSS.readFile cacheFile) - packageIndexFromCache mkPkg indexHnd cache + myWithFile indexFile ReadMode $ \indexHnd -> + packageIndexFromCache mkPkg indexHnd cache mode + where + myWithFile f m act = case mode of + ReadPackageIndexStrict -> withFile f m act + ReadPackageIndexLazyIO -> do indexHnd <- openFile f m + act indexHnd packageIndexFromCache :: Package pkg - => (PackageId -> ByteString - -> GenericPackageDescription -> pkg) + => (PackageEntry -> pkg) -> Handle -> [IndexCacheEntry] + -> ReadPackageIndexMode -> IO (PackageIndex pkg, [Dependency]) -packageIndexFromCache mkPkg hnd = accum mempty [] +packageIndexFromCache mkPkg hnd entrs mode = accum mempty [] entrs where accum srcpkgs prefs [] = do -- Have to reverse entries, since in a tar file, later entries mask @@ -375,27 +439,47 @@ pkgtxt <- getEntryContent blockno pkg <- readPackageDescription pkgtxt return (pkg, pkgtxt) + let srcpkg = case mode of + ReadPackageIndexLazyIO -> + mkPkg (NormalPackage pkgid pkg pkgtxt blockno) + ReadPackageIndexStrict -> + pkg `seq` pkgtxt `seq` mkPkg (NormalPackage pkgid pkg + pkgtxt blockno) + accum (srcpkg:srcpkgs) prefs entries - let srcpkg = mkPkg pkgid pkgtxt pkg + accum srcpkgs prefs (CacheBuildTreeRef refType blockno : entries) = do + -- We have to read the .cabal file eagerly here because we can't cache the + -- package id for build tree references - the user might edit the .cabal + -- file after the reference was added to the index. + path <- liftM byteStringToFilePath . getEntryContent $ blockno + pkg <- do cabalFile <- findPackageDesc path + PackageDesc.Parse.readPackageDescription normal cabalFile + let srcpkg = mkPkg (BuildTreeRef refType (packageId pkg) pkg path blockno) accum (srcpkg:srcpkgs) prefs entries accum srcpkgs prefs (CachePreference pref : entries) = accum srcpkgs (pref:prefs) entries + getEntryContent :: BlockNo -> IO ByteString getEntryContent blockno = do hSeek hnd AbsoluteSeek (fromIntegral (blockno * 512)) header <- BS.hGet hnd 512 size <- getEntrySize header BS.hGet hnd (fromIntegral size) + getEntrySize :: ByteString -> IO Tar.FileSize getEntrySize header = case Tar.read header of Tar.Next e _ -> case Tar.entryContent e of Tar.NormalFile _ size -> return size + Tar.OtherEntryType typecode _ size + | Tar.isBuildTreeRefTypeCode typecode + -> return size _ -> interror "unexpected tar entry type" _ -> interror "could not read tar file entry" + readPackageDescription :: ByteString -> IO GenericPackageDescription readPackageDescription content = case parsePackageDescription . fromUTF8 . BS.Char8.unpack $ content of ParseOk _ d -> return d @@ -415,8 +499,9 @@ type BlockNo = Int data IndexCacheEntry = CachePackageId PackageId BlockNo + | CacheBuildTreeRef BuildTreeRefType BlockNo | CachePreference Dependency - deriving (Eq, Show) + deriving (Eq) readIndexCacheEntry :: BSS.ByteString -> Maybe IndexCacheEntry readIndexCacheEntry = \line -> @@ -428,12 +513,19 @@ (Just pkgname, Just pkgver, Just blockno) -> Just (CachePackageId (PackageIdentifier pkgname pkgver) blockno) _ -> Nothing + [key, typecodestr, blocknostr] | key == buildTreeRefKey -> + case (parseRefType typecodestr, parseBlockNo blocknostr) of + (Just refType, Just blockno) + -> Just (CacheBuildTreeRef refType blockno) + _ -> Nothing + (key: remainder) | key == preferredVersionKey -> fmap CachePreference (simpleParse (BSS.unpack (BSS.unwords remainder))) _ -> Nothing where packageKey = BSS.pack "pkg:" blocknoKey = BSS.pack "b#" + buildTreeRefKey = BSS.pack "build-tree-ref:" preferredVersionKey = BSS.pack "pref-ver:" parseName str @@ -454,15 +546,24 @@ Just (blockno, remainder) | BSS.null remainder -> Just blockno _ -> Nothing + parseRefType str = + case BSS.uncons str of + Just (typeCode, remainder) + | BSS.null remainder && Tar.isBuildTreeRefTypeCode typeCode + -> Just (refTypeFromTypeCode typeCode) + _ -> Nothing + showIndexCacheEntry :: IndexCacheEntry -> String showIndexCacheEntry entry = case entry of CachePackageId pkgid b -> "pkg: " ++ display (packageName pkgid) ++ " " ++ display (packageVersion pkgid) ++ " b# " ++ show b - CachePreference dep -> "pref-ver: " ++ display dep + CacheBuildTreeRef t b -> "build-tree-ref: " ++ (typeCodeFromRefType t:" ") + ++ show b + CachePreference dep -> "pref-ver: " ++ display dep readIndexCache :: BSS.ByteString -> [IndexCacheEntry] -readIndexCache = catMaybes . map readIndexCacheEntry . BSS.lines +readIndexCache = mapMaybe readIndexCacheEntry . BSS.lines showIndexCache :: [IndexCacheEntry] -> String showIndexCache = unlines . map showIndexCacheEntry diff --git a/Distribution/Client/Init.hs b/Distribution/Client/Init.hs --- a/Distribution/Client/Init.hs +++ b/Distribution/Client/Init.hs @@ -24,14 +24,17 @@ import System.IO ( hSetBuffering, stdout, BufferMode(..) ) import System.Directory - ( getCurrentDirectory, doesDirectoryExist ) + ( getCurrentDirectory, doesDirectoryExist, doesFileExist, copyFile + , getDirectoryContents ) import System.FilePath - ( () ) + ( (), (<.>), takeBaseName ) import Data.Time ( getCurrentTime, utcToLocalTime, toGregorian, localDay, getCurrentTimeZone ) +import Data.Char + ( toUpper ) import Data.List - ( intersperse, intercalate, nub, groupBy, (\\) ) + ( intercalate, nub, groupBy, (\\) ) import Data.Maybe ( fromMaybe, isJust, catMaybes ) import Data.Function @@ -42,39 +45,35 @@ import Control.Applicative ( (<$>) ) import Control.Monad - ( when ) -#if MIN_VERSION_base(3,0,0) -import Control.Monad - ( (>=>), join ) -#endif + ( when, unless, (>=>), join ) import Control.Arrow - ( (&&&) ) + ( (&&&), (***) ) import Text.PrettyPrint hiding (mode, cat) import Data.Version ( Version(..) ) import Distribution.Version - ( orLaterVersion, withinVersion, VersionRange ) + ( orLaterVersion, earlierVersion, intersectVersionRanges, VersionRange ) import Distribution.Verbosity ( Verbosity ) import Distribution.ModuleName - ( ModuleName, fromString ) + ( ModuleName, fromString ) -- And for the Text instance import Distribution.InstalledPackageInfo ( InstalledPackageInfo, sourcePackageId, exposed ) import qualified Distribution.Package as P +import Language.Haskell.Extension ( Language(..) ) import Distribution.Client.Init.Types ( InitFlags(..), PackageType(..), Category(..) ) import Distribution.Client.Init.Licenses - ( bsd3, gplv2, gplv3, lgpl2, lgpl3, apache20 ) + ( bsd3, gplv2, gplv3, lgpl2, lgpl3, agplv3, apache20 ) import Distribution.Client.Init.Heuristics - ( guessPackageName, guessAuthorNameMail, SourceFileEntry(..), scanForModules, neededBuildPrograms ) + ( guessPackageName, guessAuthorNameMail, SourceFileEntry(..), + scanForModules, neededBuildPrograms ) import Distribution.License ( License(..), knownLicenses ) -import Distribution.ModuleName - ( ) -- for the Text instance import Distribution.ReadE ( runReadE, readP_to_E ) @@ -126,7 +125,9 @@ >=> getHomepage >=> getSynopsis >=> getCategory + >=> getExtraSourceFiles >=> getLibOrExec + >=> getLanguage >=> getGenComments >=> getSrcDir >=> getModulesBuildToolsAndDeps pkgIx @@ -178,13 +179,15 @@ return $ flags { license = maybeToFlag lic } where listedLicenses = - knownLicenses \\ [GPL Nothing, LGPL Nothing, Apache Nothing, OtherLicense] + knownLicenses \\ [GPL Nothing, LGPL Nothing, AGPL Nothing + , Apache Nothing, OtherLicense] -- | The author's name and email. Prompt, or try to guess from an existing -- darcs repo. getAuthorInfo :: InitFlags -> IO InitFlags getAuthorInfo flags = do - (authorName, authorEmail) <- (\(a,e) -> (flagToMaybe a, flagToMaybe e)) `fmap` guessAuthorNameMail + (authorName, authorEmail) <- + (flagToMaybe *** flagToMaybe) `fmap` guessAuthorNameMail authorName' <- return (flagToMaybe $ author flags) ?>> maybePrompt flags (promptStr "Author name" authorName) ?>> return authorName @@ -230,22 +233,59 @@ (promptListOptional "Project category" [Codec ..])) return $ flags { category = maybeToFlag cat } +-- | Try to guess extra source files (don't prompt the user). +getExtraSourceFiles :: InitFlags -> IO InitFlags +getExtraSourceFiles flags = do + extraSrcFiles <- return (extraSrc flags) + ?>> Just `fmap` guessExtraSourceFiles flags + + return $ flags { extraSrc = extraSrcFiles } + +-- | Try to guess things to include in the extra-source-files field. +-- For now, we just look for things in the root directory named +-- 'readme', 'changes', or 'changelog', with any sort of +-- capitalization and any extension. +guessExtraSourceFiles :: InitFlags -> IO [FilePath] +guessExtraSourceFiles flags = do + dir <- + maybe getCurrentDirectory return . flagToMaybe $ packageDir flags + files <- getDirectoryContents dir + return $ filter isExtra files + + where + isExtra = (`elem` ["README", "CHANGES", "CHANGELOG"]) + . map toUpper + . takeBaseName + -- | Ask whether the project builds a library or executable. getLibOrExec :: InitFlags -> IO InitFlags getLibOrExec flags = do isLib <- return (flagToMaybe $ packageType flags) ?>> maybePrompt flags (either (const Library) id `fmap` - (promptList "What does the package build" - [Library, Executable] - Nothing display False)) + promptList "What does the package build" + [Library, Executable] + Nothing display False) ?>> return (Just Library) return $ flags { packageType = maybeToFlag isLib } --- | Ask whether to generate explanitory comments. +-- | Ask for the base language of the package. +getLanguage :: InitFlags -> IO InitFlags +getLanguage flags = do + lang <- return (flagToMaybe $ language flags) + ?>> maybePrompt flags + (either UnknownLanguage id `fmap` + promptList "What base language is the package written in" + [Haskell2010, Haskell98] + (Just Haskell2010) display True) + ?>> return (Just Haskell2010) + + return $ flags { language = maybeToFlag lang } + +-- | Ask whether to generate explanatory comments. getGenComments :: InitFlags -> IO InitFlags getGenComments flags = do - genComments <- return (flagToMaybe $ noComments flags) + genComments <- return (not <$> flagToMaybe (noComments flags)) ?>> maybePrompt flags (promptYesNo promptMsg (Just False)) ?>> return (Just False) return $ flags { noComments = maybeToFlag (fmap not genComments) } @@ -256,7 +296,7 @@ getSrcDir :: InitFlags -> IO InitFlags getSrcDir flags = do srcDirs <- return (sourceDirs flags) - ?>> Just `fmap` (guessSourceDirs flags) + ?>> Just `fmap` guessSourceDirs flags return $ flags { sourceDirs = srcDirs } @@ -264,8 +304,8 @@ -- moment just looks to see whether there is a directory called 'src'. guessSourceDirs :: InitFlags -> IO [String] guessSourceDirs flags = do - dir <- fromMaybe getCurrentDirectory - (fmap return . flagToMaybe $ packageDir flags) + dir <- + maybe getCurrentDirectory return . flagToMaybe $ packageDir flags srcIsDir <- doesDirectoryExist (dir "src") if srcIsDir then return ["src"] @@ -274,8 +314,7 @@ -- | Get the list of exposed modules and extra tools needed to build them. getModulesBuildToolsAndDeps :: PackageIndex -> InitFlags -> IO InitFlags getModulesBuildToolsAndDeps pkgIx flags = do - dir <- fromMaybe getCurrentDirectory - (fmap return . flagToMaybe $ packageDir flags) + dir <- maybe getCurrentDirectory return . flagToMaybe $ packageDir flags -- XXX really should use guessed source roots. sourceFiles <- scanForModules dir @@ -288,12 +327,23 @@ deps <- return (dependencies flags) ?>> Just <$> importsToDeps flags - (fromString "Prelude" : concatMap imports sourceFiles) + (fromString "Prelude" : -- to ensure we get base as a dep + ( nub -- only need to consider each imported package once + . filter (`notElem` mods) -- don't consider modules from + -- this package itself + . concatMap imports + $ sourceFiles + ) + ) pkgIx + exts <- return (otherExts flags) + ?>> (return . Just . nub . concatMap extensions $ sourceFiles) + return $ flags { exposedModules = Just mods , buildTools = tools , dependencies = deps + , otherExts = exts } importsToDeps :: InitFlags -> [ModuleName] -> PackageIndex -> IO [P.Dependency] @@ -333,7 +383,7 @@ grps -> do message flags ("\nWarning: multiple packages found providing " ++ display m ++ ": " ++ intercalate ", " (map (display . P.pkgName . head) grps)) - message flags ("You will need to pick one and manually add it to the Build-depends: field.") + message flags "You will need to pick one and manually add it to the Build-depends: field." return Nothing where pkgGroups = groupBy ((==) `on` P.pkgName) (map sourcePackageId ps) @@ -351,8 +401,19 @@ (pvpize . maximum . map P.pkgVersion $ pids) pvpize :: Version -> VersionRange - pvpize v = withinVersion $ v { versionBranch = take 2 (versionBranch v) } + pvpize v = orLaterVersion v' + `intersectVersionRanges` + earlierVersion (incVersion 1 v') + where v' = (v { versionBranch = take 2 (versionBranch v) }) +incVersion :: Int -> Version -> Version +incVersion n (Version vlist tags) = Version (incVersion' n vlist) tags + where + incVersion' 0 [] = [1] + incVersion' 0 (v:_) = [v+1] + incVersion' m [] = replicate m 0 ++ [1] + incVersion' m (v:vs) = v : incVersion' (m-1) vs + --------------------------------------------------------------------------- -- Prompting/user interaction ------------------------------------------- --------------------------------------------------------------------------- @@ -421,7 +482,7 @@ $ promptList pr (Nothing : map Just choices) (Just Nothing) (maybe "(none)" display) True where - rearrange = either (Just . Left) (maybe Nothing (Just . Right)) + rearrange = either (Just . Left) (fmap Right) -- | Create a prompt from a list of items. promptList :: Eq t @@ -435,8 +496,7 @@ putStrLn $ pr ++ ":" let options1 = map (\c -> (Just c == def, displayItem c)) choices options2 = zip ([1..]::[Int]) - (options1 ++ if other then [(False, "Other (specify)")] - else []) + (options1 ++ [(False, "Other (specify)") | other]) mapM_ (putStrLn . \(n,(i,s)) -> showOption n i ++ s) options2 promptList' displayItem (length options2) choices def other where showOption n i | n < 10 = " " ++ star i ++ " " ++ rest @@ -495,13 +555,16 @@ Flag (LGPL (Just (Version {versionBranch = [3]}))) -> Just lgpl3 + Flag (AGPL (Just (Version {versionBranch = [3]}))) + -> Just agplv3 + Flag (Apache (Just (Version {versionBranch = [2, 0]}))) -> Just apache20 _ -> Nothing case licenseFile of - Just licenseText -> writeFile "LICENSE" licenseText + Just licenseText -> writeFileSafe flags "LICENSE" licenseText Nothing -> message flags "Warning: unknown license type, you must put a copy in LICENSE yourself." getYear :: IO Integer @@ -515,15 +578,13 @@ writeSetupFile :: InitFlags -> IO () writeSetupFile flags = do message flags "Generating Setup.hs..." - writeFile "Setup.hs" setupFile + writeFileSafe flags "Setup.hs" setupFile where setupFile = unlines [ "import Distribution.Simple" , "main = defaultMain" ] --- XXX ought to do something sensible if a .cabal file already exists, --- instead of overwriting. writeCabalFile :: InitFlags -> IO Bool writeCabalFile flags@(InitFlags{packageName = NoFlag}) = do message flags "Error: no package name provided." @@ -531,9 +592,36 @@ writeCabalFile flags@(InitFlags{packageName = Flag p}) = do let cabalFileName = p ++ ".cabal" message flags $ "Generating " ++ cabalFileName ++ "..." - writeFile cabalFileName (generateCabalFile cabalFileName flags) + writeFileSafe flags cabalFileName (generateCabalFile cabalFileName flags) return True +-- | Write a file \"safely\", backing up any existing version (unless +-- the overwrite flag is set). +writeFileSafe :: InitFlags -> FilePath -> String -> IO () +writeFileSafe flags fileName content = do + moveExistingFile flags fileName + writeFile fileName content + +-- | Move an existing file, if there is one, and the overwrite flag is +-- not set. +moveExistingFile :: InitFlags -> FilePath -> IO () +moveExistingFile flags fileName = + unless (overwrite flags == Flag True) $ do + e <- doesFileExist fileName + when e $ do + newName <- findNewName fileName + message flags $ "Warning: " ++ fileName ++ " already exists, backing up old version in " ++ newName + copyFile fileName newName + +findNewName :: FilePath -> IO FilePath +findNewName oldName = findNewName' 0 + where + findNewName' :: Integer -> IO FilePath + findNewName' n = do + let newName = oldName <.> ("save" ++ show n) + e <- doesFileExist newName + if e then findNewName' (n+1) else return newName + -- | Generate a .cabal file from an InitFlags structure. NOTE: this -- is rather ad-hoc! What we would REALLY like is to have a -- standard low-level AST type representing .cabal files, which @@ -545,7 +633,7 @@ generateCabalFile :: String -> InitFlags -> String generateCabalFile fileName c = renderStyle style { lineLength = 79, ribbonsPerLine = 1.1 } $ - (if (minimal c /= Flag True) + (if minimal c /= Flag True then showComment (Just $ "Initial " ++ fileName ++ " generated by cabal " ++ "init. For further documentation, see " ++ "http://haskell.org/cabal/users-guide/") @@ -607,22 +695,22 @@ Nothing True - , fieldS "extra-source-files" NoFlag + , fieldS "extra-source-files" (listFieldS (extraSrc c)) (Just "Extra files to be distributed with the package, such as examples or a README.") - False + True - , field "cabal-version" (Flag $ orLaterVersion (Version [1,8] [])) + , field "cabal-version" (Flag $ orLaterVersion (Version [1,10] [])) (Just "Constraint on the version of Cabal needed to build this package.") False , case packageType c of Flag Executable -> - text "\nexecutable" <+> text (fromMaybe "" . flagToMaybe $ packageName c) $$ (nest 2 $ vcat + text "\nexecutable" <+> text (fromMaybe "" . flagToMaybe $ packageName c) $$ nest 2 (vcat [ fieldS "main-is" NoFlag (Just ".hs or .lhs file containing the Main module.") True , generateBuildInfo Executable c ]) - Flag Library -> text "\nlibrary" $$ (nest 2 $ vcat + Flag Library -> text "\nlibrary" $$ nest 2 (vcat [ fieldS "exposed-modules" (listField (exposedModules c)) (Just "Modules exported by the library.") True @@ -640,24 +728,32 @@ Executable -> "Modules included in this executable, other than Main.") True + , fieldS "other-extensions" (listField (otherExts c')) + (Just "LANGUAGE extensions used by modules in this package.") + True + , fieldS "build-depends" (listField (dependencies c')) (Just "Other library packages from which modules are imported.") True , fieldS "hs-source-dirs" (listFieldS (sourceDirs c')) (Just "Directories containing source files.") - False + True , fieldS "build-tools" (listFieldS (buildTools c')) (Just "Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.") False + + , field "default-language" (language c') + (Just "Base language which the package is written in.") + True ] listField :: Text s => Maybe [s] -> Flag String listField = listFieldS . fmap (map display) listFieldS :: Maybe [String] -> Flag String - listFieldS = Flag . maybe "" (concat . intersperse ", ") + listFieldS = Flag . maybe "" (intercalate ", ") field :: Text t => String -> Flag t -> Maybe String -> Bool -> Doc field s f = fieldS s (fmap display f) @@ -676,15 +772,15 @@ (False, _, _) -> ($$ text "") $ comment f <> text s <> colon - <> text (take (20 - length s) (repeat ' ')) + <> text (replicate (20 - length s) ' ') <> text (fromMaybe "" . flagToMaybe $ f) comment NoFlag = text "-- " comment (Flag "") = text "-- " comment _ = text "" showComment :: Maybe String -> Doc - showComment (Just t) = vcat . map text - . map ("-- "++) . lines + showComment (Just t) = vcat + . map (text . ("-- "++)) . lines . renderStyle style { lineLength = 76, ribbonsPerLine = 1.05 @@ -714,9 +810,3 @@ message :: InitFlags -> String -> IO () message (InitFlags{quiet = Flag True}) _ = return () message _ s = putStrLn s - -#if MIN_VERSION_base(3,0,0) -#else -(>=>) :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c) -f >=> g = \x -> f x >>= g -#endif diff --git a/Distribution/Client/Init/Heuristics.hs b/Distribution/Client/Init/Heuristics.hs --- a/Distribution/Client/Init/Heuristics.hs +++ b/Distribution/Client/Init/Heuristics.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.Init.Heuristics @@ -22,33 +21,37 @@ import Distribution.Text (simpleParse) import Distribution.Simple.Setup (Flag(..)) import Distribution.ModuleName - ( ModuleName, fromString, toFilePath ) + ( ModuleName, toFilePath ) import Distribution.Client.PackageIndex ( allPackagesByName ) import qualified Distribution.PackageDescription as PD ( category, packageDescription ) import Distribution.Simple.Utils ( intercalate ) +import Distribution.Client.Utils + ( tryCanonicalizePath ) +import Language.Haskell.Extension ( Extension ) import Distribution.Client.Types ( packageDescription, SourcePackageDb(..) ) -import Control.Monad (liftM ) +import Control.Applicative ( pure, (<$>), (<*>) ) +import Control.Monad ( liftM ) import Data.Char ( isUpper, isLower, isSpace ) -#if MIN_VERSION_base(3,0,3) import Data.Either ( partitionEithers ) -#endif import Data.List ( isPrefixOf ) -import Data.Maybe ( catMaybes ) -import Data.Monoid ( mempty, mappend ) +import Data.Maybe ( mapMaybe, catMaybes, maybeToList ) +import Data.Monoid ( mempty, mconcat ) import qualified Data.Set as Set ( fromList, toList ) -import System.Directory ( getDirectoryContents, doesDirectoryExist, doesFileExist, - getHomeDirectory, canonicalizePath ) -import System.Environment ( getEnvironment ) +import System.Directory ( getDirectoryContents, + doesDirectoryExist, doesFileExist, getHomeDirectory, ) +import Distribution.Compat.Environment ( getEnvironment ) import System.FilePath ( takeExtension, takeBaseName, dropExtension, (), (<.>), splitDirectories, makeRelative ) +import System.Process ( readProcessWithExitCode ) +import System.Exit ( ExitCode(..) ) -- |Guess the package name based on the given root directory guessPackageName :: FilePath -> IO String -guessPackageName = liftM (last . splitDirectories) . canonicalizePath +guessPackageName = liftM (last . splitDirectories) . tryCanonicalizePath -- |Data type of source files found in the working directory data SourceFileEntry = SourceFileEntry @@ -56,10 +59,11 @@ , moduleName :: ModuleName , fileExtension :: String , imports :: [ModuleName] + , extensions :: [Extension] } deriving Show sfToFileName :: FilePath -> SourceFileEntry -> FilePath -sfToFileName projectRoot (SourceFileEntry relPath m ext _) +sfToFileName projectRoot (SourceFileEntry relPath m ext _ _) = projectRoot relPath toFilePath m <.> ext -- |Search for source files in the given directory @@ -77,7 +81,7 @@ let modules = catMaybes [ guessModuleName hierarchy file | file <- files , isUpper (head file) ] - modules' <- mapM (findImports projectRoot) modules + modules' <- mapM (findImportsAndExts projectRoot) modules recMods <- mapM (scanRecursive dir hierarchy) dirs return $ concat (modules' : recMods) tagIsDir parent entry = do @@ -85,32 +89,34 @@ return $ (if isDir then Right else Left) entry guessModuleName hierarchy entry | takeBaseName entry == "Setup" = Nothing - | ext `elem` sourceExtensions = Just $ SourceFileEntry relRoot modName ext [] + | ext `elem` sourceExtensions = + SourceFileEntry <$> pure relRoot <*> modName <*> pure ext <*> pure [] <*> pure [] | otherwise = Nothing where - relRoot = makeRelative projectRoot srcRoot + relRoot = makeRelative projectRoot srcRoot unqualModName = dropExtension entry - modName = fromString $ intercalate "." . reverse $ (unqualModName : hierarchy) - ext = case takeExtension entry of '.':e -> e; e -> e + modName = simpleParse + $ intercalate "." . reverse $ (unqualModName : hierarchy) + ext = case takeExtension entry of '.':e -> e; e -> e scanRecursive parent hierarchy entry | isUpper (head entry) = scan (parent entry) (entry : hierarchy) | isLower (head entry) && not (ignoreDir entry) = - scanForModulesIn projectRoot $ foldl () srcRoot (entry : hierarchy) + scanForModulesIn projectRoot $ foldl () srcRoot (reverse (entry : hierarchy)) | otherwise = return [] ignoreDir ('.':_) = True ignoreDir dir = dir `elem` ["dist", "_darcs"] -findImports :: FilePath -> SourceFileEntry -> IO SourceFileEntry -findImports projectRoot sf = do +findImportsAndExts :: FilePath -> SourceFileEntry -> IO SourceFileEntry +findImportsAndExts projectRoot sf = do s <- readFile (sfToFileName projectRoot sf) - let modules = catMaybes - . map ( getModName - . drop 1 - . filter (not . null) - . dropWhile (/= "import") - . words - ) + let modules = mapMaybe + ( getModName + . drop 1 + . filter (not . null) + . dropWhile (/= "import") + . words + ) . filter (not . ("--" `isPrefixOf`)) -- poor man's comment filtering . lines $ s @@ -120,8 +126,30 @@ -- Haskell parser since cabal's dependencies must be kept at a -- minimum. - return sf { imports = modules } + -- A poor man's LANGUAGE pragma parser. + exts = mapMaybe simpleParse + . concatMap getPragmas + . filter isLANGUAGEPragma + . map fst + . drop 1 + . takeWhile (not . null . snd) + . iterate (takeBraces . snd) + $ ("",s) + takeBraces = break (== '}') . dropWhile (/= '{') + + isLANGUAGEPragma = ("{-# LANGUAGE " `isPrefixOf`) + + getPragmas = map trim . splitCommas . takeWhile (/= '#') . drop 13 + + splitCommas "" = [] + splitCommas xs = x : splitCommas (drop 1 y) + where (x,y) = break (==',') xs + + return sf { imports = modules + , extensions = exts + } + where getModName :: [String] -> Maybe ModuleName getModName [] = Nothing getModName ("qualified":ws) = getModName ws @@ -148,32 +176,111 @@ neededBuildPrograms entries = [ handler | ext <- nubSet (map fileExtension entries) - , handler <- maybe [] (:[]) (lookup ext knownSuffixHandlers) + , handler <- maybeToList (lookup ext knownSuffixHandlers) ] --- |Guess author and email +-- | Guess author and email using darcs and git configuration options. Use +-- the following in decreasing order of preference: +-- +-- 1. vcs env vars ($DARCS_EMAIL, $GIT_AUTHOR_*) +-- 2. Local repo configs +-- 3. Global vcs configs +-- 4. The generic $EMAIL +-- +-- Name and email are processed separately, so the guess might end up being +-- a name from DARCS_EMAIL and an email from git config. +-- +-- Darcs has preference, for tradition's sake. guessAuthorNameMail :: IO (Flag String, Flag String) -guessAuthorNameMail = - update (readFromFile authorRepoFile) mempty >>= - update (getAuthorHome >>= readFromFile) >>= - update readFromEnvironment +guessAuthorNameMail = fmap authorGuessPure authorGuessIO + +-- Ordered in increasing preference, since Flag-as-monoid is identical to +-- Last. +authorGuessPure :: AuthorGuessIO -> AuthorGuess +authorGuessPure (AuthorGuessIO env darcsLocalF darcsGlobalF gitLocal gitGlobal) + = mconcat + [ emailEnv env + , gitGlobal + , darcsCfg darcsGlobalF + , gitLocal + , darcsCfg darcsLocalF + , gitEnv env + , darcsEnv env + ] + +authorGuessIO :: IO AuthorGuessIO +authorGuessIO = AuthorGuessIO + <$> getEnvironment + <*> (maybeReadFile $ "_darcs" "prefs" "author") + <*> (maybeReadFile =<< liftM ( (".darcs" "author")) getHomeDirectory) + <*> gitCfg Local + <*> gitCfg Global + +-- Types and functions used for guessing the author are now defined: + +type AuthorGuess = (Flag String, Flag String) +type Enviro = [(String, String)] +data GitLoc = Local | Global +data AuthorGuessIO = AuthorGuessIO + Enviro -- ^ Environment lookup table + (Maybe String) -- ^ Contents of local darcs author info + (Maybe String) -- ^ Contents of global darcs author info + AuthorGuess -- ^ Git config --local + AuthorGuess -- ^ Git config --global + +darcsEnv :: Enviro -> AuthorGuess +darcsEnv = maybe mempty nameAndMail . lookup "DARCS_EMAIL" + +gitEnv :: Enviro -> AuthorGuess +gitEnv env = (name, email) where - update _ info@(Flag _, Flag _) = return info - update extract info = liftM (`mappend` info) extract -- prefer info - readFromFile file = do - exists <- doesFileExist file - if exists then liftM nameAndMail (readFile file) else return mempty - readFromEnvironment = fmap extractFromEnvironment getEnvironment - extractFromEnvironment env = - let darcsEmailEnv = maybe mempty nameAndMail (lookup "DARCS_EMAIL" env) - emailEnv = maybe mempty (\e -> (mempty, Flag e)) (lookup "EMAIL" env) - in darcsEmailEnv `mappend` emailEnv - getAuthorHome = liftM ( (".darcs" "author")) getHomeDirectory - authorRepoFile = "_darcs" "prefs" "author" + name = maybeFlag "GIT_AUTHOR_NAME" env + email = maybeFlag "GIT_AUTHOR_EMAIL" env +darcsCfg :: Maybe String -> AuthorGuess +darcsCfg = maybe mempty nameAndMail + +emailEnv :: Enviro -> AuthorGuess +emailEnv env = (mempty, email) + where + email = maybeFlag "EMAIL" env + +gitCfg :: GitLoc -> IO AuthorGuess +gitCfg which = do + name <- gitVar which "user.name" + mail <- gitVar which "user.email" + return (name, mail) + +gitVar :: GitLoc -> String -> IO (Flag String) +gitVar which = fmap happyOutput . gitConfigQuery which + +happyOutput :: (ExitCode, a, t) -> Flag a +happyOutput v = case v of + (ExitSuccess, s, _) -> Flag s + _ -> mempty + +gitConfigQuery :: GitLoc -> String -> IO (ExitCode, String, String) +gitConfigQuery which key = + fmap trim' $ readProcessWithExitCode "git" ["config", w, key] "" + where + w = case which of + Local -> "--local" + Global -> "--global" + trim' (a, b, c) = (a, trim b, c) + +maybeFlag :: String -> Enviro -> Flag String +maybeFlag k = maybe mempty Flag . lookup k + +maybeReadFile :: String -> IO (Maybe String) +maybeReadFile f = do + exists <- doesFileExist f + if exists + then fmap Just $ readFile f + else return Nothing + -- |Get list of categories used in hackage. NOTE: Very slow, needs to be cached knownCategories :: SourcePackageDb -> [String] -knownCategories (SourcePackageDb sourcePkgIndex _) = nubSet $ +knownCategories (SourcePackageDb sourcePkgIndex _) = nubSet [ cat | pkg <- map head (allPackagesByName sourcePkgIndex) , let catList = (PD.category . PD.packageDescription . packageDescription) pkg , cat <- splitString ',' catList @@ -188,7 +295,10 @@ where (nameOrEmail,erest) = break (== '<') str (email,_) = break (== '>') (tail erest) - trim = removeLeadingSpace . reverse . removeLeadingSpace . reverse + +trim :: String -> String +trim = removeLeadingSpace . reverse . removeLeadingSpace . reverse + where removeLeadingSpace = dropWhile isSpace -- split string at given character, and remove whitespaces @@ -218,12 +328,3 @@ putStrLn "List of known categories" print $ knownCategories db -} - -#if MIN_VERSION_base(3,0,3) -#else -partitionEithers :: [Either a b] -> ([a],[b]) -partitionEithers = foldr (either left right) ([],[]) - where - left a (l, r) = (a:l, r) - right a (l, r) = (l, a:r) -#endif diff --git a/Distribution/Client/Init/Licenses.hs b/Distribution/Client/Init/Licenses.hs --- a/Distribution/Client/Init/Licenses.hs +++ b/Distribution/Client/Init/Licenses.hs @@ -5,6 +5,7 @@ , gplv3 , lgpl2 , lgpl3 + , agplv3 , apache20 ) where @@ -1065,6 +1066,671 @@ , "Public License instead of this License. But first, please read" , "." , "" + ] + +agplv3 :: License +agplv3 = unlines + [ " GNU AFFERO GENERAL PUBLIC LICENSE" + , " Version 3, 19 November 2007" + , "" + , " Copyright (C) 2007 Free Software Foundation, Inc. " + , " Everyone is permitted to copy and distribute verbatim copies" + , " of this license document, but changing it is not allowed." + , "" + , " Preamble" + , "" + , " The GNU Affero General Public License is a free, copyleft license for" + , "software and other kinds of works, specifically designed to ensure" + , "cooperation with the community in the case of network server software." + , "" + , " The licenses for most software and other practical works are designed" + , "to take away your freedom to share and change the works. By contrast," + , "our General Public Licenses are intended to guarantee your freedom to" + , "share and change all versions of a program--to make sure it remains free" + , "software for all its users." + , "" + , " When we speak of free software, we are referring to freedom, not" + , "price. Our General Public Licenses are designed to make sure that you" + , "have the freedom to distribute copies of free software (and charge for" + , "them if you wish), that you receive source code or can get it if you" + , "want it, that you can change the software or use pieces of it in new" + , "free programs, and that you know you can do these things." + , "" + , " Developers that use our General Public Licenses protect your rights" + , "with two steps: (1) assert copyright on the software, and (2) offer" + , "you this License which gives you legal permission to copy, distribute" + , "and/or modify the software." + , "" + , " A secondary benefit of defending all users' freedom is that" + , "improvements made in alternate versions of the program, if they" + , "receive widespread use, become available for other developers to" + , "incorporate. Many developers of free software are heartened and" + , "encouraged by the resulting cooperation. However, in the case of" + , "software used on network servers, this result may fail to come about." + , "The GNU General Public License permits making a modified version and" + , "letting the public access it on a server without ever releasing its" + , "source code to the public." + , "" + , " The GNU Affero General Public License is designed specifically to" + , "ensure that, in such cases, the modified source code becomes available" + , "to the community. It requires the operator of a network server to" + , "provide the source code of the modified version running there to the" + , "users of that server. Therefore, public use of a modified version, on" + , "a publicly accessible server, gives the public access to the source" + , "code of the modified version." + , "" + , " An older license, called the Affero General Public License and" + , "published by Affero, was designed to accomplish similar goals. This is" + , "a different license, not a version of the Affero GPL, but Affero has" + , "released a new version of the Affero GPL which permits relicensing under" + , "this license." + , "" + , " The precise terms and conditions for copying, distribution and" + , "modification follow." + , "" + , " TERMS AND CONDITIONS" + , "" + , " 0. Definitions." + , "" + , " \"This License\" refers to version 3 of the GNU Affero General Public License." + , "" + , " \"Copyright\" also means copyright-like laws that apply to other kinds of" + , "works, such as semiconductor masks." + , "" + , " \"The Program\" refers to any copyrightable work licensed under this" + , "License. Each licensee is addressed as \"you\". \"Licensees\" and" + , "\"recipients\" may be individuals or organizations." + , "" + , " To \"modify\" a work means to copy from or adapt all or part of the work" + , "in a fashion requiring copyright permission, other than the making of an" + , "exact copy. The resulting work is called a \"modified version\" of the" + , "earlier work or a work \"based on\" the earlier work." + , "" + , " A \"covered work\" means either the unmodified Program or a work based" + , "on the Program." + , "" + , " To \"propagate\" a work means to do anything with it that, without" + , "permission, would make you directly or secondarily liable for" + , "infringement under applicable copyright law, except executing it on a" + , "computer or modifying a private copy. Propagation includes copying," + , "distribution (with or without modification), making available to the" + , "public, and in some countries other activities as well." + , "" + , " To \"convey\" a work means any kind of propagation that enables other" + , "parties to make or receive copies. Mere interaction with a user through" + , "a computer network, with no transfer of a copy, is not conveying." + , "" + , " An interactive user interface displays \"Appropriate Legal Notices\"" + , "to the extent that it includes a convenient and prominently visible" + , "feature that (1) displays an appropriate copyright notice, and (2)" + , "tells the user that there is no warranty for the work (except to the" + , "extent that warranties are provided), that licensees may convey the" + , "work under this License, and how to view a copy of this License. If" + , "the interface presents a list of user commands or options, such as a" + , "menu, a prominent item in the list meets this criterion." + , "" + , " 1. Source Code." + , "" + , " The \"source code\" for a work means the preferred form of the work" + , "for making modifications to it. \"Object code\" means any non-source" + , "form of a work." + , "" + , " A \"Standard Interface\" means an interface that either is an official" + , "standard defined by a recognized standards body, or, in the case of" + , "interfaces specified for a particular programming language, one that" + , "is widely used among developers working in that language." + , "" + , " The \"System Libraries\" of an executable work include anything, other" + , "than the work as a whole, that (a) is included in the normal form of" + , "packaging a Major Component, but which is not part of that Major" + , "Component, and (b) serves only to enable use of the work with that" + , "Major Component, or to implement a Standard Interface for which an" + , "implementation is available to the public in source code form. A" + , "\"Major Component\", in this context, means a major essential component" + , "(kernel, window system, and so on) of the specific operating system" + , "(if any) on which the executable work runs, or a compiler used to" + , "produce the work, or an object code interpreter used to run it." + , "" + , " The \"Corresponding Source\" for a work in object code form means all" + , "the source code needed to generate, install, and (for an executable" + , "work) run the object code and to modify the work, including scripts to" + , "control those activities. However, it does not include the work's" + , "System Libraries, or general-purpose tools or generally available free" + , "programs which are used unmodified in performing those activities but" + , "which are not part of the work. For example, Corresponding Source" + , "includes interface definition files associated with source files for" + , "the work, and the source code for shared libraries and dynamically" + , "linked subprograms that the work is specifically designed to require," + , "such as by intimate data communication or control flow between those" + , "subprograms and other parts of the work." + , "" + , " The Corresponding Source need not include anything that users" + , "can regenerate automatically from other parts of the Corresponding" + , "Source." + , "" + , " The Corresponding Source for a work in source code form is that" + , "same work." + , "" + , " 2. Basic Permissions." + , "" + , " All rights granted under this License are granted for the term of" + , "copyright on the Program, and are irrevocable provided the stated" + , "conditions are met. This License explicitly affirms your unlimited" + , "permission to run the unmodified Program. The output from running a" + , "covered work is covered by this License only if the output, given its" + , "content, constitutes a covered work. This License acknowledges your" + , "rights of fair use or other equivalent, as provided by copyright law." + , "" + , " You may make, run and propagate covered works that you do not" + , "convey, without conditions so long as your license otherwise remains" + , "in force. You may convey covered works to others for the sole purpose" + , "of having them make modifications exclusively for you, or provide you" + , "with facilities for running those works, provided that you comply with" + , "the terms of this License in conveying all material for which you do" + , "not control copyright. Those thus making or running the covered works" + , "for you must do so exclusively on your behalf, under your direction" + , "and control, on terms that prohibit them from making any copies of" + , "your copyrighted material outside their relationship with you." + , "" + , " Conveying under any other circumstances is permitted solely under" + , "the conditions stated below. Sublicensing is not allowed; section 10" + , "makes it unnecessary." + , "" + , " 3. Protecting Users' Legal Rights From Anti-Circumvention Law." + , "" + , " No covered work shall be deemed part of an effective technological" + , "measure under any applicable law fulfilling obligations under article" + , "11 of the WIPO copyright treaty adopted on 20 December 1996, or" + , "similar laws prohibiting or restricting circumvention of such" + , "measures." + , "" + , " When you convey a covered work, you waive any legal power to forbid" + , "circumvention of technological measures to the extent such circumvention" + , "is effected by exercising rights under this License with respect to" + , "the covered work, and you disclaim any intention to limit operation or" + , "modification of the work as a means of enforcing, against the work's" + , "users, your or third parties' legal rights to forbid circumvention of" + , "technological measures." + , "" + , " 4. Conveying Verbatim Copies." + , "" + , " You may convey verbatim copies of the Program's source code as you" + , "receive it, in any medium, provided that you conspicuously and" + , "appropriately publish on each copy an appropriate copyright notice;" + , "keep intact all notices stating that this License and any" + , "non-permissive terms added in accord with section 7 apply to the code;" + , "keep intact all notices of the absence of any warranty; and give all" + , "recipients a copy of this License along with the Program." + , "" + , " You may charge any price or no price for each copy that you convey," + , "and you may offer support or warranty protection for a fee." + , "" + , " 5. Conveying Modified Source Versions." + , "" + , " You may convey a work based on the Program, or the modifications to" + , "produce it from the Program, in the form of source code under the" + , "terms of section 4, provided that you also meet all of these conditions:" + , "" + , " a) The work must carry prominent notices stating that you modified" + , " it, and giving a relevant date." + , "" + , " b) The work must carry prominent notices stating that it is" + , " released under this License and any conditions added under section" + , " 7. This requirement modifies the requirement in section 4 to" + , " \"keep intact all notices\"." + , "" + , " c) You must license the entire work, as a whole, under this" + , " License to anyone who comes into possession of a copy. This" + , " License will therefore apply, along with any applicable section 7" + , " additional terms, to the whole of the work, and all its parts," + , " regardless of how they are packaged. This License gives no" + , " permission to license the work in any other way, but it does not" + , " invalidate such permission if you have separately received it." + , "" + , " d) If the work has interactive user interfaces, each must display" + , " Appropriate Legal Notices; however, if the Program has interactive" + , " interfaces that do not display Appropriate Legal Notices, your" + , " work need not make them do so." + , "" + , " A compilation of a covered work with other separate and independent" + , "works, which are not by their nature extensions of the covered work," + , "and which are not combined with it such as to form a larger program," + , "in or on a volume of a storage or distribution medium, is called an" + , "\"aggregate\" if the compilation and its resulting copyright are not" + , "used to limit the access or legal rights of the compilation's users" + , "beyond what the individual works permit. Inclusion of a covered work" + , "in an aggregate does not cause this License to apply to the other" + , "parts of the aggregate." + , "" + , " 6. Conveying Non-Source Forms." + , "" + , " You may convey a covered work in object code form under the terms" + , "of sections 4 and 5, provided that you also convey the" + , "machine-readable Corresponding Source under the terms of this License," + , "in one of these ways:" + , "" + , " a) Convey the object code in, or embodied in, a physical product" + , " (including a physical distribution medium), accompanied by the" + , " Corresponding Source fixed on a durable physical medium" + , " customarily used for software interchange." + , "" + , " b) Convey the object code in, or embodied in, a physical product" + , " (including a physical distribution medium), accompanied by a" + , " written offer, valid for at least three years and valid for as" + , " long as you offer spare parts or customer support for that product" + , " model, to give anyone who possesses the object code either (1) a" + , " copy of the Corresponding Source for all the software in the" + , " product that is covered by this License, on a durable physical" + , " medium customarily used for software interchange, for a price no" + , " more than your reasonable cost of physically performing this" + , " conveying of source, or (2) access to copy the" + , " Corresponding Source from a network server at no charge." + , "" + , " c) Convey individual copies of the object code with a copy of the" + , " written offer to provide the Corresponding Source. This" + , " alternative is allowed only occasionally and noncommercially, and" + , " only if you received the object code with such an offer, in accord" + , " with subsection 6b." + , "" + , " d) Convey the object code by offering access from a designated" + , " place (gratis or for a charge), and offer equivalent access to the" + , " Corresponding Source in the same way through the same place at no" + , " further charge. You need not require recipients to copy the" + , " Corresponding Source along with the object code. If the place to" + , " copy the object code is a network server, the Corresponding Source" + , " may be on a different server (operated by you or a third party)" + , " that supports equivalent copying facilities, provided you maintain" + , " clear directions next to the object code saying where to find the" + , " Corresponding Source. Regardless of what server hosts the" + , " Corresponding Source, you remain obligated to ensure that it is" + , " available for as long as needed to satisfy these requirements." + , "" + , " e) Convey the object code using peer-to-peer transmission, provided" + , " you inform other peers where the object code and Corresponding" + , " Source of the work are being offered to the general public at no" + , " charge under subsection 6d." + , "" + , " A separable portion of the object code, whose source code is excluded" + , "from the Corresponding Source as a System Library, need not be" + , "included in conveying the object code work." + , "" + , " A \"User Product\" is either (1) a \"consumer product\", which means any" + , "tangible personal property which is normally used for personal, family," + , "or household purposes, or (2) anything designed or sold for incorporation" + , "into a dwelling. In determining whether a product is a consumer product," + , "doubtful cases shall be resolved in favor of coverage. For a particular" + , "product received by a particular user, \"normally used\" refers to a" + , "typical or common use of that class of product, regardless of the status" + , "of the particular user or of the way in which the particular user" + , "actually uses, or expects or is expected to use, the product. A product" + , "is a consumer product regardless of whether the product has substantial" + , "commercial, industrial or non-consumer uses, unless such uses represent" + , "the only significant mode of use of the product." + , "" + , " \"Installation Information\" for a User Product means any methods," + , "procedures, authorization keys, or other information required to install" + , "and execute modified versions of a covered work in that User Product from" + , "a modified version of its Corresponding Source. The information must" + , "suffice to ensure that the continued functioning of the modified object" + , "code is in no case prevented or interfered with solely because" + , "modification has been made." + , "" + , " If you convey an object code work under this section in, or with, or" + , "specifically for use in, a User Product, and the conveying occurs as" + , "part of a transaction in which the right of possession and use of the" + , "User Product is transferred to the recipient in perpetuity or for a" + , "fixed term (regardless of how the transaction is characterized), the" + , "Corresponding Source conveyed under this section must be accompanied" + , "by the Installation Information. But this requirement does not apply" + , "if neither you nor any third party retains the ability to install" + , "modified object code on the User Product (for example, the work has" + , "been installed in ROM)." + , "" + , " The requirement to provide Installation Information does not include a" + , "requirement to continue to provide support service, warranty, or updates" + , "for a work that has been modified or installed by the recipient, or for" + , "the User Product in which it has been modified or installed. Access to a" + , "network may be denied when the modification itself materially and" + , "adversely affects the operation of the network or violates the rules and" + , "protocols for communication across the network." + , "" + , " Corresponding Source conveyed, and Installation Information provided," + , "in accord with this section must be in a format that is publicly" + , "documented (and with an implementation available to the public in" + , "source code form), and must require no special password or key for" + , "unpacking, reading or copying." + , "" + , " 7. Additional Terms." + , "" + , " \"Additional permissions\" are terms that supplement the terms of this" + , "License by making exceptions from one or more of its conditions." + , "Additional permissions that are applicable to the entire Program shall" + , "be treated as though they were included in this License, to the extent" + , "that they are valid under applicable law. If additional permissions" + , "apply only to part of the Program, that part may be used separately" + , "under those permissions, but the entire Program remains governed by" + , "this License without regard to the additional permissions." + , "" + , " When you convey a copy of a covered work, you may at your option" + , "remove any additional permissions from that copy, or from any part of" + , "it. (Additional permissions may be written to require their own" + , "removal in certain cases when you modify the work.) You may place" + , "additional permissions on material, added by you to a covered work," + , "for which you have or can give appropriate copyright permission." + , "" + , " Notwithstanding any other provision of this License, for material you" + , "add to a covered work, you may (if authorized by the copyright holders of" + , "that material) supplement the terms of this License with terms:" + , "" + , " a) Disclaiming warranty or limiting liability differently from the" + , " terms of sections 15 and 16 of this License; or" + , "" + , " b) Requiring preservation of specified reasonable legal notices or" + , " author attributions in that material or in the Appropriate Legal" + , " Notices displayed by works containing it; or" + , "" + , " c) Prohibiting misrepresentation of the origin of that material, or" + , " requiring that modified versions of such material be marked in" + , " reasonable ways as different from the original version; or" + , "" + , " d) Limiting the use for publicity purposes of names of licensors or" + , " authors of the material; or" + , "" + , " e) Declining to grant rights under trademark law for use of some" + , " trade names, trademarks, or service marks; or" + , "" + , " f) Requiring indemnification of licensors and authors of that" + , " material by anyone who conveys the material (or modified versions of" + , " it) with contractual assumptions of liability to the recipient, for" + , " any liability that these contractual assumptions directly impose on" + , " those licensors and authors." + , "" + , " All other non-permissive additional terms are considered \"further" + , "restrictions\" within the meaning of section 10. If the Program as you" + , "received it, or any part of it, contains a notice stating that it is" + , "governed by this License along with a term that is a further" + , "restriction, you may remove that term. If a license document contains" + , "a further restriction but permits relicensing or conveying under this" + , "License, you may add to a covered work material governed by the terms" + , "of that license document, provided that the further restriction does" + , "not survive such relicensing or conveying." + , "" + , " If you add terms to a covered work in accord with this section, you" + , "must place, in the relevant source files, a statement of the" + , "additional terms that apply to those files, or a notice indicating" + , "where to find the applicable terms." + , "" + , " Additional terms, permissive or non-permissive, may be stated in the" + , "form of a separately written license, or stated as exceptions;" + , "the above requirements apply either way." + , "" + , " 8. Termination." + , "" + , " You may not propagate or modify a covered work except as expressly" + , "provided under this License. Any attempt otherwise to propagate or" + , "modify it is void, and will automatically terminate your rights under" + , "this License (including any patent licenses granted under the third" + , "paragraph of section 11)." + , "" + , " However, if you cease all violation of this License, then your" + , "license from a particular copyright holder is reinstated (a)" + , "provisionally, unless and until the copyright holder explicitly and" + , "finally terminates your license, and (b) permanently, if the copyright" + , "holder fails to notify you of the violation by some reasonable means" + , "prior to 60 days after the cessation." + , "" + , " Moreover, your license from a particular copyright holder is" + , "reinstated permanently if the copyright holder notifies you of the" + , "violation by some reasonable means, this is the first time you have" + , "received notice of violation of this License (for any work) from that" + , "copyright holder, and you cure the violation prior to 30 days after" + , "your receipt of the notice." + , "" + , " Termination of your rights under this section does not terminate the" + , "licenses of parties who have received copies or rights from you under" + , "this License. If your rights have been terminated and not permanently" + , "reinstated, you do not qualify to receive new licenses for the same" + , "material under section 10." + , "" + , " 9. Acceptance Not Required for Having Copies." + , "" + , " You are not required to accept this License in order to receive or" + , "run a copy of the Program. Ancillary propagation of a covered work" + , "occurring solely as a consequence of using peer-to-peer transmission" + , "to receive a copy likewise does not require acceptance. However," + , "nothing other than this License grants you permission to propagate or" + , "modify any covered work. These actions infringe copyright if you do" + , "not accept this License. Therefore, by modifying or propagating a" + , "covered work, you indicate your acceptance of this License to do so." + , "" + , " 10. Automatic Licensing of Downstream Recipients." + , "" + , " Each time you convey a covered work, the recipient automatically" + , "receives a license from the original licensors, to run, modify and" + , "propagate that work, subject to this License. You are not responsible" + , "for enforcing compliance by third parties with this License." + , "" + , " An \"entity transaction\" is a transaction transferring control of an" + , "organization, or substantially all assets of one, or subdividing an" + , "organization, or merging organizations. If propagation of a covered" + , "work results from an entity transaction, each party to that" + , "transaction who receives a copy of the work also receives whatever" + , "licenses to the work the party's predecessor in interest had or could" + , "give under the previous paragraph, plus a right to possession of the" + , "Corresponding Source of the work from the predecessor in interest, if" + , "the predecessor has it or can get it with reasonable efforts." + , "" + , " You may not impose any further restrictions on the exercise of the" + , "rights granted or affirmed under this License. For example, you may" + , "not impose a license fee, royalty, or other charge for exercise of" + , "rights granted under this License, and you may not initiate litigation" + , "(including a cross-claim or counterclaim in a lawsuit) alleging that" + , "any patent claim is infringed by making, using, selling, offering for" + , "sale, or importing the Program or any portion of it." + , "" + , " 11. Patents." + , "" + , " A \"contributor\" is a copyright holder who authorizes use under this" + , "License of the Program or a work on which the Program is based. The" + , "work thus licensed is called the contributor's \"contributor version\"." + , "" + , " A contributor's \"essential patent claims\" are all patent claims" + , "owned or controlled by the contributor, whether already acquired or" + , "hereafter acquired, that would be infringed by some manner, permitted" + , "by this License, of making, using, or selling its contributor version," + , "but do not include claims that would be infringed only as a" + , "consequence of further modification of the contributor version. For" + , "purposes of this definition, \"control\" includes the right to grant" + , "patent sublicenses in a manner consistent with the requirements of" + , "this License." + , "" + , " Each contributor grants you a non-exclusive, worldwide, royalty-free" + , "patent license under the contributor's essential patent claims, to" + , "make, use, sell, offer for sale, import and otherwise run, modify and" + , "propagate the contents of its contributor version." + , "" + , " In the following three paragraphs, a \"patent license\" is any express" + , "agreement or commitment, however denominated, not to enforce a patent" + , "(such as an express permission to practice a patent or covenant not to" + , "sue for patent infringement). To \"grant\" such a patent license to a" + , "party means to make such an agreement or commitment not to enforce a" + , "patent against the party." + , "" + , " If you convey a covered work, knowingly relying on a patent license," + , "and the Corresponding Source of the work is not available for anyone" + , "to copy, free of charge and under the terms of this License, through a" + , "publicly available network server or other readily accessible means," + , "then you must either (1) cause the Corresponding Source to be so" + , "available, or (2) arrange to deprive yourself of the benefit of the" + , "patent license for this particular work, or (3) arrange, in a manner" + , "consistent with the requirements of this License, to extend the patent" + , "license to downstream recipients. \"Knowingly relying\" means you have" + , "actual knowledge that, but for the patent license, your conveying the" + , "covered work in a country, or your recipient's use of the covered work" + , "in a country, would infringe one or more identifiable patents in that" + , "country that you have reason to believe are valid." + , "" + , " If, pursuant to or in connection with a single transaction or" + , "arrangement, you convey, or propagate by procuring conveyance of, a" + , "covered work, and grant a patent license to some of the parties" + , "receiving the covered work authorizing them to use, propagate, modify" + , "or convey a specific copy of the covered work, then the patent license" + , "you grant is automatically extended to all recipients of the covered" + , "work and works based on it." + , "" + , " A patent license is \"discriminatory\" if it does not include within" + , "the scope of its coverage, prohibits the exercise of, or is" + , "conditioned on the non-exercise of one or more of the rights that are" + , "specifically granted under this License. You may not convey a covered" + , "work if you are a party to an arrangement with a third party that is" + , "in the business of distributing software, under which you make payment" + , "to the third party based on the extent of your activity of conveying" + , "the work, and under which the third party grants, to any of the" + , "parties who would receive the covered work from you, a discriminatory" + , "patent license (a) in connection with copies of the covered work" + , "conveyed by you (or copies made from those copies), or (b) primarily" + , "for and in connection with specific products or compilations that" + , "contain the covered work, unless you entered into that arrangement," + , "or that patent license was granted, prior to 28 March 2007." + , "" + , " Nothing in this License shall be construed as excluding or limiting" + , "any implied license or other defenses to infringement that may" + , "otherwise be available to you under applicable patent law." + , "" + , " 12. No Surrender of Others' Freedom." + , "" + , " If conditions are imposed on you (whether by court order, agreement or" + , "otherwise) that contradict the conditions of this License, they do not" + , "excuse you from the conditions of this License. If you cannot convey a" + , "covered work so as to satisfy simultaneously your obligations under this" + , "License and any other pertinent obligations, then as a consequence you may" + , "not convey it at all. For example, if you agree to terms that obligate you" + , "to collect a royalty for further conveying from those to whom you convey" + , "the Program, the only way you could satisfy both those terms and this" + , "License would be to refrain entirely from conveying the Program." + , "" + , " 13. Remote Network Interaction; Use with the GNU General Public License." + , "" + , " Notwithstanding any other provision of this License, if you modify the" + , "Program, your modified version must prominently offer all users" + , "interacting with it remotely through a computer network (if your version" + , "supports such interaction) an opportunity to receive the Corresponding" + , "Source of your version by providing access to the Corresponding Source" + , "from a network server at no charge, through some standard or customary" + , "means of facilitating copying of software. This Corresponding Source" + , "shall include the Corresponding Source for any work covered by version 3" + , "of the GNU General Public License that is incorporated pursuant to the" + , "following paragraph." + , "" + , " Notwithstanding any other provision of this License, you have" + , "permission to link or combine any covered work with a work licensed" + , "under version 3 of the GNU General Public License into a single" + , "combined work, and to convey the resulting work. The terms of this" + , "License will continue to apply to the part which is the covered work," + , "but the work with which it is combined will remain governed by version" + , "3 of the GNU General Public License." + , "" + , " 14. Revised Versions of this License." + , "" + , " The Free Software Foundation may publish revised and/or new versions of" + , "the GNU Affero General Public License from time to time. Such new versions" + , "will be similar in spirit to the present version, but may differ in detail to" + , "address new problems or concerns." + , "" + , " Each version is given a distinguishing version number. If the" + , "Program specifies that a certain numbered version of the GNU Affero General" + , "Public License \"or any later version\" applies to it, you have the" + , "option of following the terms and conditions either of that numbered" + , "version or of any later version published by the Free Software" + , "Foundation. If the Program does not specify a version number of the" + , "GNU Affero General Public License, you may choose any version ever published" + , "by the Free Software Foundation." + , "" + , " If the Program specifies that a proxy can decide which future" + , "versions of the GNU Affero General Public License can be used, that proxy's" + , "public statement of acceptance of a version permanently authorizes you" + , "to choose that version for the Program." + , "" + , " Later license versions may give you additional or different" + , "permissions. However, no additional obligations are imposed on any" + , "author or copyright holder as a result of your choosing to follow a" + , "later version." + , "" + , " 15. Disclaimer of Warranty." + , "" + , " THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY" + , "APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT" + , "HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY" + , "OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO," + , "THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR" + , "PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM" + , "IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF" + , "ALL NECESSARY SERVICING, REPAIR OR CORRECTION." + , "" + , " 16. Limitation of Liability." + , "" + , " IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING" + , "WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS" + , "THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY" + , "GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE" + , "USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF" + , "DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD" + , "PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS)," + , "EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF" + , "SUCH DAMAGES." + , "" + , " 17. Interpretation of Sections 15 and 16." + , "" + , " If the disclaimer of warranty and limitation of liability provided" + , "above cannot be given local legal effect according to their terms," + , "reviewing courts shall apply local law that most closely approximates" + , "an absolute waiver of all civil liability in connection with the" + , "Program, unless a warranty or assumption of liability accompanies a" + , "copy of the Program in return for a fee." + , "" + , " END OF TERMS AND CONDITIONS" + , "" + , " How to Apply These Terms to Your New Programs" + , "" + , " If you develop a new program, and you want it to be of the greatest" + , "possible use to the public, the best way to achieve this is to make it" + , "free software which everyone can redistribute and change under these terms." + , "" + , " To do so, attach the following notices to the program. It is safest" + , "to attach them to the start of each source file to most effectively" + , "state the exclusion of warranty; and each file should have at least" + , "the \"copyright\" line and a pointer to where the full notice is found." + , "" + , " " + , " Copyright (C) " + , "" + , " This program is free software: you can redistribute it and/or modify" + , " it under the terms of the GNU Affero General Public License as published by" + , " the Free Software Foundation, either version 3 of the License, or" + , " (at your option) any later version." + , "" + , " This program is distributed in the hope that it will be useful," + , " but WITHOUT ANY WARRANTY; without even the implied warranty of" + , " MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" + , " GNU Affero General Public License for more details." + , "" + , " You should have received a copy of the GNU Affero General Public License" + , " along with this program. If not, see ." + , "" + , "Also add information on how to contact you by electronic and paper mail." + , "" + , " If your software can interact with users remotely through a computer" + , "network, you should also make sure that it provides a way for users to" + , "get its source. For example, if your program is a web application, its" + , "interface could display a \"Source\" link that leads users to an archive" + , "of the code. There are many ways you could offer source, and different" + , "solutions will be better for different programs; see section 13 for the" + , "specific requirements." + , "" + , " You should also get your employer (if you work as a programmer) or school," + , "if any, to sign a \"copyright disclaimer\" for the program, if necessary." + , "For more information on this, and how to apply and follow the GNU AGPL, see" + , "." ] lgpl2 :: License diff --git a/Distribution/Client/Init/Types.hs b/Distribution/Client/Init/Types.hs --- a/Distribution/Client/Init/Types.hs +++ b/Distribution/Client/Init/Types.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.Init.Types @@ -22,6 +21,7 @@ import qualified Distribution.Package as P import Distribution.License import Distribution.ModuleName +import Language.Haskell.Extension ( Language(..), Extension ) import qualified Text.PrettyPrint as Disp import qualified Distribution.Compat.ReadP as Parse @@ -51,20 +51,28 @@ , synopsis :: Flag String , category :: Flag (Either String Category) + , extraSrc :: Maybe [String] , packageType :: Flag PackageType + , language :: Flag Language , exposedModules :: Maybe [ModuleName] , otherModules :: Maybe [ModuleName] + , otherExts :: Maybe [Extension] , dependencies :: Maybe [P.Dependency] , sourceDirs :: Maybe [String] , buildTools :: Maybe [String] , initVerbosity :: Flag Verbosity + , overwrite :: Flag Bool } deriving (Show) + -- the Monoid instance for Flag has later values override earlier + -- ones, which is why we want Maybe [foo] for collecting foo values, + -- not Flag [foo]. + data PackageType = Library | Executable deriving (Show, Read, Eq) @@ -88,13 +96,17 @@ , homepage = mempty , synopsis = mempty , category = mempty + , extraSrc = mempty , packageType = mempty + , language = mempty , exposedModules = mempty , otherModules = mempty + , otherExts = mempty , dependencies = mempty , sourceDirs = mempty , buildTools = mempty , initVerbosity = mempty + , overwrite = mempty } mappend a b = InitFlags { nonInteractive = combine nonInteractive @@ -111,13 +123,17 @@ , homepage = combine homepage , synopsis = combine synopsis , category = combine category + , extraSrc = combine extraSrc , packageType = combine packageType + , language = combine language , exposedModules = combine exposedModules , otherModules = combine otherModules + , otherExts = combine otherExts , dependencies = combine dependencies , sourceDirs = combine sourceDirs , buildTools = combine buildTools , initVerbosity = combine initVerbosity + , overwrite = combine overwrite } where combine field = field a `mappend` field b @@ -146,12 +162,3 @@ disp = Disp.text . show parse = Parse.choice $ map (fmap read . Parse.string . show) [Codec .. ] -#if MIN_VERSION_base(3,0,0) -#else --- Compat instance for ghc-6.6 era -instance Monoid a => Monoid (Maybe a) where - mempty = Nothing - Nothing `mappend` m = m - m `mappend` Nothing = m - Just m1 `mappend` Just m2 = Just (m1 `mappend` m2) -#endif diff --git a/Distribution/Client/Install.hs b/Distribution/Client/Install.hs --- a/Distribution/Client/Install.hs +++ b/Distribution/Client/Install.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.Install @@ -14,29 +13,32 @@ -- High level interface to package installation. ----------------------------------------------------------------------------- module Distribution.Client.Install ( + -- * High-level interface install, - upgrade, + + -- * Lower-level interface that allows to manipulate the install plan + makeInstallContext, + makeInstallPlan, + processInstallPlan, + InstallArgs, + InstallContext, + + -- * Prune certain packages from the install plan + pruneInstallPlan ) where import Data.List ( unfoldr, nub, sort, (\\) ) +import qualified Data.Set as S import Data.Maybe ( isJust, fromMaybe, maybeToList ) -import qualified Data.ByteString.Lazy.Char8 as BS - ( unpack ) import Control.Exception as Exception - ( bracket, handleJust ) -#if MIN_VERSION_base(4,0,0) -import Control.Exception as Exception - ( Exception(toException), catches, Handler(Handler), IOException ) + ( Exception(toException), bracket, catches, Handler(Handler), handleJust + , IOException, SomeException ) import System.Exit ( ExitCode ) -#else -import Control.Exception as Exception - ( Exception(IOException, ExitException) ) -#endif import Distribution.Compat.Exception - ( SomeException, catchIO, catchExit ) + ( catchIO, catchExit ) import Control.Monad ( when, unless ) import System.Directory @@ -44,7 +46,7 @@ import System.FilePath ( (), (<.>), takeDirectory ) import System.IO - ( openFile, IOMode(AppendMode), stdout, hFlush, hClose ) + ( openFile, IOMode(WriteMode), hClose ) import System.IO.Error ( isDoesNotExistError, ioeGetFileName ) @@ -54,7 +56,6 @@ ( Solver(..) ) import Distribution.Client.FetchUtils import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex) --- import qualified Distribution.Client.Info as Info import Distribution.Client.IndexUtils as IndexUtils ( getSourcePackages, getInstalledPackages ) import qualified Distribution.Client.InstallPlan as InstallPlan @@ -64,7 +65,12 @@ , ConfigFlags(..), configureCommand, filterConfigureFlags , ConfigExFlags(..), InstallFlags(..) ) import Distribution.Client.Config - ( defaultCabalDir ) + ( defaultCabalDir, defaultUserInstall ) +import Distribution.Client.Sandbox.Timestamp + ( withUpdateTimestamps ) +import Distribution.Client.Sandbox.Types + ( SandboxPackageInfo(..), UseSandbox(..), isUseSandbox + , whenUsingSandbox ) import Distribution.Client.Tar (extractTarGzFile) import Distribution.Client.Types as Source import Distribution.Client.BuildReports.Types @@ -76,6 +82,7 @@ ( storeAnonymous, storeLocal, fromInstallPlan ) import qualified Distribution.Client.InstallSymlink as InstallSymlink ( symlinkBinaries ) +import qualified Distribution.Client.PackageIndex as SourcePackageIndex import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade import qualified Distribution.Client.World as World import qualified Distribution.InstalledPackageInfo as Installed @@ -85,7 +92,8 @@ import Distribution.Simple.Compiler ( CompilerId(..), Compiler(compilerId), compilerFlavor , PackageDB(..), PackageDBStack ) -import Distribution.Simple.Program (ProgramConfiguration, defaultProgramConfiguration) +import Distribution.Simple.Program (ProgramConfiguration, + defaultProgramConfiguration) import qualified Distribution.Simple.InstallDirs as InstallDirs import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.PackageIndex (PackageIndex) @@ -94,7 +102,7 @@ , buildCommand, BuildFlags(..), emptyBuildFlags , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe ) import qualified Distribution.Simple.Setup as Cabal - ( installCommand, InstallFlags(..), emptyInstallFlags + ( installCommand, InstallFlags(..), TestFlags(..), emptyInstallFlags , emptyTestFlags, testCommand, Flag(..) ) import Distribution.Simple.Utils ( rawSystemExit, comparing, writeFileAtomic ) @@ -114,15 +122,16 @@ import Distribution.Version ( Version, anyVersion, thisVersion ) import Distribution.Simple.Utils as Utils - ( notice, info, warn, die, intercalate, withTempDirectory ) + ( notice, info, warn, debugNoWrap, die, intercalate, withTempDirectory ) import Distribution.Client.Utils - ( numberOfProcessors, inDir, mergeBy, MergeResult(..) ) + ( numberOfProcessors, inDir, mergeBy, MergeResult(..) + , tryCanonicalizePath ) import Distribution.System - ( Platform, buildPlatform, OS(Windows), buildOS ) + ( Platform, OS(Windows), buildOS ) import Distribution.Text ( display ) import Distribution.Verbosity as Verbosity - ( Verbosity, showForCabal, verbose, deafening ) + ( Verbosity, showForCabal, normal, verbose ) import Distribution.Simple.BuildPaths ( exeExtension ) --TODO: @@ -143,12 +152,15 @@ -- | Installs the packages needed to satisfy a list of dependencies. -- -install, upgrade +install :: Verbosity -> PackageDBStack -> [Repo] -> Compiler + -> Platform -> ProgramConfiguration + -> UseSandbox + -> Maybe SandboxPackageInfo -> GlobalFlags -> ConfigFlags -> ConfigExFlags @@ -156,77 +168,124 @@ -> HaddockFlags -> [UserTarget] -> IO () -install verbosity packageDBs repos comp conf - globalFlags configFlags configExFlags installFlags haddockFlags userTargets0 = do +install verbosity packageDBs repos comp platform conf useSandbox mSandboxPkgInfo + globalFlags configFlags configExFlags installFlags haddockFlags + userTargets0 = do + installContext <- makeInstallContext verbosity args (Just userTargets0) + installPlan <- foldProgress logMsg die' return =<< + makeInstallPlan verbosity args installContext + + processInstallPlan verbosity args installContext installPlan + where + args :: InstallArgs + args = (packageDBs, repos, comp, platform, conf, useSandbox, mSandboxPkgInfo, + globalFlags, configFlags, configExFlags, installFlags, + haddockFlags) + + die' message = die (message ++ if isUseSandbox useSandbox + then installFailedInSandbox else []) + -- TODO: use a better error message, remove duplication. + installFailedInSandbox = + "\nNote: when using a sandbox, all packages are required to have \ + consistent dependencies. \ + Try reinstalling/unregistering the offending packages or \ + recreating the sandbox." + logMsg message rest = debugNoWrap verbosity message >> rest + +-- TODO: Make InstallContext a proper datatype with documented fields. +-- | Common context for makeInstallPlan and processInstallPlan. +type InstallContext = ( PackageIndex, SourcePackageDb + , [UserTarget], [PackageSpecifier SourcePackage] ) + +-- TODO: Make InstallArgs a proper datatype with documented fields or just get +-- rid of it completely. +-- | Initial arguments given to 'install' or 'makeInstallContext'. +type InstallArgs = ( PackageDBStack + , [Repo] + , Compiler + , Platform + , ProgramConfiguration + , UseSandbox + , Maybe SandboxPackageInfo + , GlobalFlags + , ConfigFlags + , ConfigExFlags + , InstallFlags + , HaddockFlags ) + +-- | Make an install context given install arguments. +makeInstallContext :: Verbosity -> InstallArgs -> Maybe [UserTarget] + -> IO InstallContext +makeInstallContext verbosity + (packageDBs, repos, comp, _, conf,_,_, + globalFlags, _, _, _, _) mUserTargets = do + installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf sourcePkgDb <- getSourcePackages verbosity repos - solver <- chooseSolver verbosity (fromFlag (configSolver configExFlags)) (compilerId comp) + (userTargets, pkgSpecifiers) <- case mUserTargets of + Nothing -> + -- We want to distinguish between the case where the user has given an + -- empty list of targets on the command-line and the case where we + -- specifically want to have an empty list of targets. + return ([], []) + Just userTargets0 -> do + -- For install, if no target is given it means we use the current + -- directory as the single target. + let userTargets | null userTargets0 = [UserTargetLocalDir "."] + | otherwise = userTargets0 - let -- For install, if no target is given it means we use the - -- current directory as the single target - userTargets | null userTargets0 = [UserTargetLocalDir "."] - | otherwise = userTargets0 + pkgSpecifiers <- resolveUserTargets verbosity + (fromFlag $ globalWorldFile globalFlags) + (packageIndex sourcePkgDb) + userTargets + return (userTargets, pkgSpecifiers) - pkgSpecifiers <- resolveUserTargets verbosity - (fromFlag $ globalWorldFile globalFlags) - (packageIndex sourcePkgDb) - userTargets + return (installedPkgIndex, sourcePkgDb, userTargets, pkgSpecifiers) +-- | Make an install plan given install context and install arguments. +makeInstallPlan :: Verbosity -> InstallArgs -> InstallContext + -> IO (Progress String String InstallPlan) +makeInstallPlan verbosity + (_, _, comp, platform, _, _, mSandboxPkgInfo, + _, configFlags, configExFlags, installFlags, + _) + (installedPkgIndex, sourcePkgDb, + _, pkgSpecifiers) = do + + solver <- chooseSolver verbosity (fromFlag (configSolver configExFlags)) + (compilerId comp) notice verbosity "Resolving dependencies..." - installPlan <- foldProgress logMsg die return $ - planPackages - comp solver configFlags configExFlags installFlags - installedPkgIndex sourcePkgDb pkgSpecifiers + return $ planPackages comp platform mSandboxPkgInfo solver + configFlags configExFlags installFlags + installedPkgIndex sourcePkgDb pkgSpecifiers - checkPrintPlan verbosity installedPkgIndex installPlan installFlags pkgSpecifiers +-- | Given an install plan, perform the actual installations. +processInstallPlan :: Verbosity -> InstallArgs -> InstallContext + -> InstallPlan + -> IO () +processInstallPlan verbosity + args@(_,_, _, _, _, _, _, _, _, _, installFlags, _) + (installedPkgIndex, sourcePkgDb, + userTargets, pkgSpecifiers) installPlan = do + checkPrintPlan verbosity installedPkgIndex installPlan sourcePkgDb + installFlags pkgSpecifiers unless dryRun $ do installPlan' <- performInstallations verbosity - context installedPkgIndex installPlan - postInstallActions verbosity context userTargets installPlan' - + args installedPkgIndex installPlan + postInstallActions verbosity args userTargets installPlan' where - context :: InstallContext - context = (packageDBs, repos, comp, conf, - globalFlags, configFlags, configExFlags, installFlags, haddockFlags) - - dryRun = fromFlag (installDryRun installFlags) - logMsg message rest = debugNoWrap message >> rest - -- Solver debug output really looks better without automatic - -- line wrapping. TODO: This should probably be moved into - -- the utilities module. - debugNoWrap xs = when (verbosity >= deafening) (putStrLn xs >> hFlush stdout) - -upgrade _ _ _ _ _ _ _ _ _ _ _ = die $ - "Use the 'cabal install' command instead of 'cabal upgrade'.\n" - ++ "You can install the latest version of a package using 'cabal install'. " - ++ "The 'cabal upgrade' command has been removed because people found it " - ++ "confusing and it often led to broken packages.\n" - ++ "If you want the old upgrade behaviour then use the install command " - ++ "with the --upgrade-dependencies flag (but check first with --dry-run " - ++ "to see what would happen). This will try to pick the latest versions " - ++ "of all dependencies, rather than the usual behaviour of trying to pick " - ++ "installed versions of all dependencies. If you do use " - ++ "--upgrade-dependencies, it is recommended that you do not upgrade core " - ++ "packages (e.g. by using appropriate --constraint= flags)." - -type InstallContext = ( PackageDBStack - , [Repo] - , Compiler - , ProgramConfiguration - , GlobalFlags - , ConfigFlags - , ConfigExFlags - , InstallFlags - , HaddockFlags ) + dryRun = fromFlag (installDryRun installFlags) -- ------------------------------------------------------------ -- * Installation planning -- ------------------------------------------------------------ planPackages :: Compiler + -> Platform + -> Maybe SandboxPackageInfo -> Solver -> ConfigFlags -> ConfigExFlags @@ -235,15 +294,16 @@ -> SourcePackageDb -> [PackageSpecifier SourcePackage] -> Progress String String InstallPlan -planPackages comp solver configFlags configExFlags installFlags +planPackages comp platform mSandboxPkgInfo solver + configFlags configExFlags installFlags installedPkgIndex sourcePkgDb pkgSpecifiers = resolveDependencies - buildPlatform (compilerId comp) + platform (compilerId comp) solver resolverParams - >>= if onlyDeps then adjustPlanOnlyDeps else return + >>= if onlyDeps then pruneInstallPlan pkgSpecifiers else return where resolverParams = @@ -283,9 +343,12 @@ [ PackageConstraintStanzas (pkgSpecifierTarget pkgSpecifier) stanzas | pkgSpecifier <- pkgSpecifiers ] + . maybe id applySandboxInstallPolicy mSandboxPkgInfo + . (if reinstall then reinstallTargets else id) - $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers + $ standardInstallPolicy + installedPkgIndex sourcePkgDb pkgSpecifiers stanzas = concat [ if testsEnabled then [TestStanzas] else [] @@ -294,33 +357,6 @@ testsEnabled = fromFlagOrDefault False $ configTests configFlags benchmarksEnabled = fromFlagOrDefault False $ configBenchmarks configFlags - --TODO: this is a general feature and should be moved to D.C.Dependency - -- Also, the InstallPlan.remove should return info more precise to the - -- problem, rather than the very general PlanProblem type. - adjustPlanOnlyDeps :: InstallPlan -> Progress String String InstallPlan - adjustPlanOnlyDeps = - either (Fail . explain) Done - . InstallPlan.remove (isTarget pkgSpecifiers) - where - explain :: [InstallPlan.PlanProblem] -> String - explain problems = - "Cannot select only the dependencies (as requested by the " - ++ "'--only-dependencies' flag), " - ++ (case pkgids of - [pkgid] -> "the package " ++ display pkgid ++ " is " - _ -> "the packages " - ++ intercalate ", " (map display pkgids) ++ " are ") - ++ "required by a dependency of one of the other targets." - where - pkgids = - nub [ depid - | InstallPlan.PackageMissingDeps _ depids <- problems - , depid <- depids - , packageName depid `elem` targetnames ] - - targetnames = map pkgSpecifierTarget pkgSpecifiers - - reinstall = fromFlag (installReinstall installFlags) reorderGoals = fromFlag (installReorderGoals installFlags) independentGoals = fromFlag (installIndependentGoals installFlags) @@ -330,6 +366,34 @@ upgradeDeps = fromFlag (installUpgradeDeps installFlags) onlyDeps = fromFlag (installOnlyDeps installFlags) +-- | Remove the provided targets from the install plan. +pruneInstallPlan :: Package pkg => [PackageSpecifier pkg] -> InstallPlan + -> Progress String String InstallPlan +pruneInstallPlan pkgSpecifiers = + -- TODO: this is a general feature and should be moved to D.C.Dependency + -- Also, the InstallPlan.remove should return info more precise to the + -- problem, rather than the very general PlanProblem type. + either (Fail . explain) Done + . InstallPlan.remove (\pkg -> packageName pkg `elem` targetnames) + where + explain :: [InstallPlan.PlanProblem] -> String + explain problems = + "Cannot select only the dependencies (as requested by the " + ++ "'--only-dependencies' flag), " + ++ (case pkgids of + [pkgid] -> "the package " ++ display pkgid ++ " is " + _ -> "the packages " + ++ intercalate ", " (map display pkgids) ++ " are ") + ++ "required by a dependency of one of the other targets." + where + pkgids = + nub [ depid + | InstallPlan.PackageMissingDeps _ depids <- problems + , depid <- depids + , packageName depid `elem` targetnames ] + + targetnames = map pkgSpecifierTarget pkgSpecifiers + -- ------------------------------------------------------------ -- * Informational messages -- ------------------------------------------------------------ @@ -339,10 +403,12 @@ checkPrintPlan :: Verbosity -> PackageIndex -> InstallPlan + -> SourcePackageDb -> InstallFlags -> [PackageSpecifier SourcePackage] -> IO () -checkPrintPlan verbosity installed installPlan installFlags pkgSpecifiers = do +checkPrintPlan verbosity installed installPlan sourcePkgDb + installFlags pkgSpecifiers = do -- User targets that are already installed. let preExistingTargets = @@ -384,7 +450,8 @@ -- We print the install plan if we are in a dry-run or if we are confronted -- with a dangerous install plan. when (dryRun || containsReinstalls && not overrideReinstall) $ - printPlan (dryRun || breaksPkgs && not overrideReinstall) adaptedVerbosity lPlan + printPlan (dryRun || breaksPkgs && not overrideReinstall) + adaptedVerbosity lPlan sourcePkgDb -- If the install plan is dangerous, we print various warning messages. In -- particular, if we can see that packages are likely to be broken, we even @@ -433,11 +500,6 @@ type PackageChange = MergeResult PackageIdentifier PackageIdentifier -isTarget :: Package pkg => [PackageSpecifier SourcePackage] -> pkg -> Bool -isTarget pkgSpecifiers pkg = packageName pkg `elem` targetnames - where - targetnames = map pkgSpecifierTarget pkgSpecifiers - extractReinstalls :: PackageStatus -> [InstalledPackageId] extractReinstalls (Reinstall ipids _) = ipids extractReinstalls _ = [] @@ -447,7 +509,8 @@ case PackageIndex.lookupPackageName installedPkgIndex (packageName cpkg) of [] -> NewPackage - ps -> case filter ((==packageId cpkg) . Installed.sourcePackageId) (concatMap snd ps) of + ps -> case filter ((==packageId cpkg) + . Installed.sourcePackageId) (concatMap snd ps) of [] -> NewVersion (map fst ps) pkgs@(pkg:_) -> Reinstall (map Installed.installedPackageId pkgs) (changes pkg cpkg) @@ -457,15 +520,17 @@ changes :: Installed.InstalledPackageInfo -> ConfiguredPackage -> [MergeResult PackageIdentifier PackageIdentifier] - changes pkg pkg' = filter changed - $ mergeBy (comparing packageName) - -- get dependencies of installed package (convert to source pkg ids via index) - (nub . sort . concatMap (maybeToList . - fmap Installed.sourcePackageId . - PackageIndex.lookupInstalledPackageId installedPkgIndex) . - Installed.depends $ pkg) - -- get dependencies of configured package - (nub . sort . depends $ pkg') + changes pkg pkg' = + filter changed + $ mergeBy (comparing packageName) + -- get dependencies of installed package (convert to source pkg ids via + -- index) + (nub . sort . concatMap + (maybeToList . fmap Installed.sourcePackageId . + PackageIndex.lookupInstalledPackageId installedPkgIndex) . + Installed.depends $ pkg) + -- get dependencies of configured package + (nub . sort . depends $ pkg') changed (InBoth pkgid pkgid') = pkgid /= pkgid' changed _ = True @@ -473,21 +538,27 @@ printPlan :: Bool -- is dry run -> Verbosity -> [(ConfiguredPackage, PackageStatus)] + -> SourcePackageDb -> IO () -printPlan dryRun verbosity plan = case plan of +printPlan dryRun verbosity plan sourcePkgDb = case plan of [] -> return () pkgs | verbosity >= Verbosity.verbose -> notice verbosity $ unlines $ ("In order, the following " ++ wouldWill ++ " be installed:") : map showPkgAndReason pkgs | otherwise -> notice verbosity $ unlines $ - ("In order, the following " ++ wouldWill ++ " be installed (use -v for more details):") - : map (display . packageId) (map fst pkgs) + ("In order, the following " ++ wouldWill + ++ " be installed (use -v for more details):") + : map showPkg pkgs where wouldWill | dryRun = "would" | otherwise = "will" + showPkg (pkg, _) = display (packageId pkg) ++ + showLatest (pkg) + showPkgAndReason (pkg', pr) = display (packageId pkg') ++ + showLatest pkg' ++ showFlagAssignment (nonDefaultFlags pkg') ++ showStanzas (stanzas pkg') ++ " " ++ case pr of @@ -497,6 +568,22 @@ [] -> "" diff -> " changes: " ++ intercalate ", " (map change diff) + showLatest :: ConfiguredPackage -> String + showLatest pkg = case mLatestVersion of + Just latestVersion -> + if pkgVersion /= latestVersion + then (" (latest: " ++ display latestVersion ++ ")") + else "" + Nothing -> "" + where + pkgVersion = packageVersion pkg + mLatestVersion :: Maybe Version + mLatestVersion = case SourcePackageIndex.lookupPackageName + (packageIndex sourcePkgDb) + (packageName pkg) of + [] -> Nothing + x -> Just $ packageVersion $ last x + toFlagAssignment :: [Flag] -> FlagAssignment toFlagAssignment = map (\ f -> (flagName f, flagDefault f)) @@ -541,12 +628,13 @@ -- * error reporting -- postInstallActions :: Verbosity - -> InstallContext + -> InstallArgs -> [UserTarget] -> InstallPlan -> IO () postInstallActions verbosity - (packageDBs, _, comp, conf, globalFlags, configFlags, _, installFlags, _) + (packageDBs, _, comp, platform, conf, useSandbox, mSandboxPkgInfo + ,globalFlags, configFlags, _, installFlags, _) targets installPlan = do unless oneShot $ @@ -557,18 +645,22 @@ let buildReports = BuildReports.fromInstallPlan installPlan BuildReports.storeLocal (installSummaryFile installFlags) buildReports + (InstallPlan.planPlatform installPlan) when (reportingLevel >= AnonymousReports) $ BuildReports.storeAnonymous buildReports when (reportingLevel == DetailedReports) $ storeDetailedBuildReports verbosity logsDir buildReports - regenerateHaddockIndex verbosity packageDBs comp conf + regenerateHaddockIndex verbosity packageDBs comp platform conf configFlags installFlags installPlan symlinkBinaries verbosity configFlags installFlags installPlan printBuildFailures installPlan + updateSandboxTimestampsFile useSandbox mSandboxPkgInfo + comp platform installPlan + where reportingLevel = fromFlag (installBuildReports installFlags) logsDir = fromFlag (globalLogsDir globalFlags) @@ -603,11 +695,7 @@ warn verbosity $ "Missing log file for build report: " ++ fromMaybe "" (ioeGetFileName ioe) -#if MIN_VERSION_base(4,0,0) missingFile ioe -#else - missingFile (IOException ioe) -#endif | isDoesNotExistError ioe = Just ioe missingFile _ = Nothing @@ -615,12 +703,13 @@ regenerateHaddockIndex :: Verbosity -> [PackageDB] -> Compiler + -> Platform -> ProgramConfiguration -> ConfigFlags -> InstallFlags -> InstallPlan -> IO () -regenerateHaddockIndex verbosity packageDBs comp conf +regenerateHaddockIndex verbosity packageDBs comp platform conf configFlags installFlags installPlan | haddockIndexFileIsRequested && shouldRegenerateHaddockIndex = do @@ -664,7 +753,7 @@ where env = env0 ++ installDirsTemplateEnv absoluteDirs env0 = InstallDirs.compilerTemplateEnv (compilerId comp) - ++ InstallDirs.platformTemplateEnv (buildPlatform) + ++ InstallDirs.platformTemplateEnv platform absoluteDirs = InstallDirs.substituteInstallDirTemplates env0 templateDirs templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault @@ -724,7 +813,25 @@ InstallFailed e -> " failed during the final install step." ++ " The exception was:\n " ++ show e +-- | If we're working inside a sandbox and some add-source deps were installed, +-- update the timestamps of those deps. +updateSandboxTimestampsFile :: UseSandbox -> Maybe SandboxPackageInfo + -> Compiler -> Platform -> InstallPlan + -> IO () +updateSandboxTimestampsFile (UseSandbox sandboxDir) + (Just (SandboxPackageInfo _ _ _ allAddSourceDeps)) + comp platform installPlan = + withUpdateTimestamps sandboxDir (compilerId comp) platform $ \_ -> do + let allInstalled = [ pkg | InstallPlan.Installed pkg _ + <- InstallPlan.toList installPlan ] + allSrcPkgs = [ pkg | ConfiguredPackage pkg _ _ _ <- allInstalled ] + allPaths = [ pth | LocalUnpackedPackage pth + <- map packageSource allSrcPkgs] + allPathsCanonical <- mapM tryCanonicalizePath allPaths + return $! filter (`S.member` allAddSourceDeps) allPathsCanonical +updateSandboxTimestampsFile _ _ _ _ _ = return () + -- ------------------------------------------------------------ -- * Actually do the installations -- ------------------------------------------------------------ @@ -739,15 +846,21 @@ type UseLogFile = Maybe (PackageIdentifier -> FilePath, Verbosity) performInstallations :: Verbosity - -> InstallContext + -> InstallArgs -> PackageIndex -> InstallPlan -> IO InstallPlan performInstallations verbosity - (packageDBs, _, comp, conf, + (packageDBs, _, comp, _, conf, useSandbox, _, globalFlags, configFlags, configExFlags, installFlags, haddockFlags) installedPkgIndex installPlan = do + -- With 'install -j' it can be a bit hard to tell whether a sandbox is used. + whenUsingSandbox useSandbox $ \sandboxDir -> + when parallelBuild $ + notice verbosity $ "Notice: installing into a sandbox located at " + ++ sandboxDir + jobControl <- if parallelBuild then newParallelJobControl else newSerialJobControl buildLimit <- newJobLimit numJobs @@ -763,7 +876,7 @@ installUnpackedPackage verbosity buildLimit installLock numJobs (setupScriptOptions installedPkgIndex cacheLock) miscOptions configFlags' installFlags haddockFlags - compid pkg pkgoverride mpath useLogFile + compid platform pkg pkgoverride mpath useLogFile where platform = InstallPlan.planPlatform installPlan @@ -773,12 +886,13 @@ Cabal.NoFlag -> 1 Cabal.Flag Nothing -> numberOfProcessors Cabal.Flag (Just n) -> n - numFetchJobs = 2 + numFetchJobs = 2 parallelBuild = numJobs >= 2 setupScriptOptions index lock = SetupScriptOptions { useCabalVersion = maybe anyVersion thisVersion (libVersion miscOptions), useCompiler = Just comp, + usePlatform = Just platform, -- Hack: we typically want to allow the UserPackageDB for finding the -- Cabal lib when compiling any Setup.hs even if we're doing a global -- install. However we also allow looking in a specific package db. @@ -844,11 +958,14 @@ substLogFileName template pkg = fromPathTemplate . substPathTemplate env $ template - where env = initialPathTemplateEnv (packageId pkg) (compilerId comp) + where env = initialPathTemplateEnv (packageId pkg) + (compilerId comp) platform miscOptions = InstallMisc { rootCmd = if fromFlag (configUserInstall configFlags) - then Nothing -- ignore --root-cmd if --user. + || (isUseSandbox useSandbox) + then Nothing -- ignore --root-cmd if --user + -- or working inside a sandbox. else flagToMaybe (installRootCmd installFlags), libVersion = flagToMaybe (configCabalVersion configExFlags) } @@ -908,20 +1025,22 @@ (Right _) -> notice verbosity $ "Installed " ++ display pkgid (Left _) -> do notice verbosity $ "Failed to install " ++ display pkgid - case useLogFile of - Nothing -> return () - Just (mkLogFileName, _) -> do - let (logName, n) = (mkLogFileName pkgid, 10) - notice verbosity $ "Last " ++ (show n) - ++ " lines of the build log ( " ++ logName ++ " ):" - printLastNLines logName n + when (verbosity >= normal) $ + case useLogFile of + Nothing -> return () + Just (mkLogFileName, _) -> do + let logName = mkLogFileName pkgid + n = 10 + putStr $ "Last " ++ (show n) + ++ " lines of the build log ( " ++ logName ++ " ):\n" + printLastNLines logName n printLastNLines :: FilePath -> Int -> IO () printLastNLines path n = do lns <- fmap lines $ readFile path let len = length lns - let toDrop = if len > n && n > 0 then (len - n) else 0 - mapM_ (notice verbosity) (drop toDrop lns) + let toDrop = if (len > n && n > 0) then (len - n) else 0 + mapM_ putStrLn (drop toDrop lns) -- | Call an installer for an 'SourcePackage' but override the configure -- flags with the ones given by the 'ConfiguredPackage'. In particular the @@ -936,7 +1055,8 @@ -> PackageDescriptionOverride -> a) -> a installConfiguredPackage platform comp configFlags - (ConfiguredPackage (SourcePackage _ gpkg source pkgoverride) flags stanzas deps) + (ConfiguredPackage (SourcePackage _ gpkg source pkgoverride) + flags stanzas deps) installPkg = installPkg configFlags { configConfigurationsFlags = flags, configConstraints = map thisPackageVersion deps, @@ -1027,6 +1147,7 @@ -> InstallFlags -> HaddockFlags -> CompilerId + -> Platform -> PackageDescription -> PackageDescriptionOverride -> Maybe FilePath -- ^ Directory to change to before starting the installation. @@ -1035,7 +1156,7 @@ installUnpackedPackage verbosity buildLimit installLock numJobs scriptOptions miscOptions configFlags installConfigFlags haddockFlags - compid pkg pkgoverride workingDir useLogFile = do + compid platform pkg pkgoverride workingDir useLogFile = do -- Override the .cabal file if necessary case pkgoverride of @@ -1046,8 +1167,17 @@ info verbosity $ "Updating " ++ display (packageName pkgid) <.> "cabal" ++ " with the latest revision from the index." - writeFileAtomic descFilePath (BS.unpack pkgtxt) + writeFileAtomic descFilePath pkgtxt + -- Make sure that we pass --libsubdir etc to 'setup configure' (necessary if + -- the setup script was compiled against an old version of the Cabal lib). + configFlags' <- addDefaultInstallDirs configFlags + -- Filter out flags not supported by the old versions of the Cabal lib. + let configureFlags :: Version -> ConfigFlags + configureFlags = filterConfigureFlags configFlags' { + configVerbosity = toFlag verbosity' + } + -- Configure phase onFailure ConfigureFailed $ withJobLimit buildLimit $ do when (numJobs > 1) $ notice verbosity $ @@ -1078,7 +1208,7 @@ -- Install phase onFailure InstallFailed $ criticalSection installLock $ - withWin32SelfUpgrade verbosity configFlags compid pkg $ do + withWin32SelfUpgrade verbosity configFlags compid platform pkg $ do case rootCmd miscOptions of (Just cmd) -> reexec cmd Nothing -> setup Cabal.installCommand installFlags @@ -1086,9 +1216,6 @@ where pkgid = packageId pkg - configureFlags = filterConfigureFlags configFlags { - configVerbosity = toFlag verbosity' - } buildCommand' = buildCommand defaultProgramConfiguration buildFlags _ = emptyBuildFlags { buildDistPref = configDistPref configFlags, @@ -1096,16 +1223,34 @@ } shouldHaddock = fromFlag (installDocumentation installConfigFlags) haddockFlags' _ = haddockFlags { - haddockVerbosity = toFlag verbosity' + haddockVerbosity = toFlag verbosity', + haddockDistPref = configDistPref configFlags } testsEnabled = fromFlag (configTests configFlags) - testFlags _ = Cabal.emptyTestFlags + testFlags _ = Cabal.emptyTestFlags { + Cabal.testDistPref = configDistPref configFlags + } installFlags _ = Cabal.emptyInstallFlags { Cabal.installDistPref = configDistPref configFlags, Cabal.installVerbosity = toFlag verbosity' } verbosity' = maybe verbosity snd useLogFile + addDefaultInstallDirs :: ConfigFlags -> IO ConfigFlags + addDefaultInstallDirs configFlags' = do + defInstallDirs <- InstallDirs.defaultInstallDirs flavor userInstall False + return $ configFlags' { + configInstallDirs = fmap Cabal.Flag . + InstallDirs.substituteInstallDirTemplates env $ + InstallDirs.combineInstallDirs fromFlagOrDefault + defInstallDirs (configInstallDirs configFlags) + } + where + CompilerId flavor _ = compid + env = initialPathTemplateEnv pkgid compid platform + userInstall = fromFlagOrDefault defaultUserInstall + (configUserInstall configFlags') + setup cmd flags = do Exception.bracket (case useLogFile of @@ -1114,7 +1259,7 @@ let logFileName = mkLogFileName (packageId pkg) logDir = takeDirectory logFileName unless (null logDir) $ createDirectoryIfMissing True logDir - logFile <- openFile logFileName AppendMode + logFile <- openFile logFileName WriteMode return (Just logFile)) (\mHandle -> case mHandle of Just handle -> hClose handle @@ -1142,7 +1287,6 @@ -- helper onFailure :: (SomeException -> BuildFailure) -> IO BuildResult -> IO BuildResult onFailure result action = -#if MIN_VERSION_base(4,0,0) action `catches` [ Handler $ \ioe -> handler (ioe :: IOException) , Handler $ \exit -> handler (exit :: ExitCode) @@ -1150,11 +1294,6 @@ where handler :: Exception e => e -> IO BuildResult handler = return . Left . result . toException -#else - action - `catchIO` (return . Left . result . IOException) - `catchExit` (return . Left . result . ExitException) -#endif -- ------------------------------------------------------------ @@ -1164,10 +1303,11 @@ withWin32SelfUpgrade :: Verbosity -> ConfigFlags -> CompilerId + -> Platform -> PackageDescription -> IO a -> IO a -withWin32SelfUpgrade _ _ _ _ action | buildOS /= Windows = action -withWin32SelfUpgrade verbosity configFlags compid pkg action = do +withWin32SelfUpgrade _ _ _ _ _ action | buildOS /= Windows = action +withWin32SelfUpgrade verbosity configFlags compid platform pkg action = do defaultDirs <- InstallDirs.defaultInstallDirs compFlavor @@ -1195,7 +1335,8 @@ templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault defaultDirs (configInstallDirs configFlags) absoluteDirs = InstallDirs.absoluteInstallDirs - pkgid compid InstallDirs.NoCopyDest templateDirs + pkgid compid InstallDirs.NoCopyDest + platform templateDirs substTemplate = InstallDirs.fromPathTemplate . InstallDirs.substPathTemplate env - where env = InstallDirs.initialPathTemplateEnv pkgid compid + where env = InstallDirs.initialPathTemplateEnv pkgid compid platform diff --git a/Distribution/Client/InstallPlan.hs b/Distribution/Client/InstallPlan.hs --- a/Distribution/Client/InstallPlan.hs +++ b/Distribution/Client/InstallPlan.hs @@ -409,7 +409,7 @@ -- most one version of any package in the set. It only requires that of -- packages which have more than one other package depending on them. We could -- actually make the condition even more precise and say that different --- versions are ok so long as they are not both in the transative closure of +-- versions are ok so long as they are not both in the transitive closure of -- any other package (or equivalently that their inverse closures do not -- intersect). The point is we do not want to have any packages depending -- directly or indirectly on two different versions of the same package. The diff --git a/Distribution/Client/InstallSymlink.hs b/Distribution/Client/InstallSymlink.hs --- a/Distribution/Client/InstallSymlink.hs +++ b/Distribution/Client/InstallSymlink.hs @@ -1,9 +1,4 @@ -{-# OPTIONS -cpp #-} --- OPTIONS required for ghc-6.4.x compat, and must appear first {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -cpp #-} -{-# OPTIONS_NHC98 -cpp #-} -{-# OPTIONS_JHC -fcpp #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.InstallSymlink @@ -152,12 +147,12 @@ defaultDirs (configInstallDirs configFlags) absoluteDirs = InstallDirs.absoluteInstallDirs (packageId pkg) compilerId InstallDirs.NoCopyDest - templateDirs + platform templateDirs canonicalizePath (InstallDirs.bindir absoluteDirs) substTemplate pkgid = InstallDirs.fromPathTemplate . InstallDirs.substPathTemplate env - where env = InstallDirs.initialPathTemplateEnv pkgid compilerId + where env = InstallDirs.initialPathTemplateEnv pkgid compilerId platform fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "") prefixTemplate = fromFlagTemplate (configProgPrefix configFlags) @@ -234,6 +229,6 @@ bs = splitPath b commonLen = length $ takeWhile id $ zipWith (==) as bs in joinPath $ [ ".." | _ <- drop commonLen as ] - ++ [ b' | b' <- drop commonLen bs ] + ++ drop commonLen bs #endif diff --git a/Distribution/Client/JobControl.hs b/Distribution/Client/JobControl.hs --- a/Distribution/Client/JobControl.hs +++ b/Distribution/Client/JobControl.hs @@ -27,8 +27,9 @@ ) where import Control.Monad -import Control.Concurrent -import Control.Exception +import Control.Concurrent hiding (QSem, newQSem, waitQSem, signalQSem) +import Control.Exception (SomeException, bracket_, mask, throw, try) +import Distribution.Client.Compat.Semaphore data JobControl m a = JobControl { spawnJob :: m a -> m (), @@ -51,7 +52,6 @@ collect = join . readChan newParallelJobControl :: IO (JobControl IO a) -#if MIN_VERSION_base(4,3,0) newParallelJobControl = do resultVar <- newEmptyMVar return JobControl { @@ -69,9 +69,6 @@ collect :: MVar (Either SomeException a) -> IO a collect resultVar = takeMVar resultVar >>= either throw return -#else -newParallelJobControl = newSerialJobControl -#endif data JobLimit = JobLimit QSem diff --git a/Distribution/Client/List.hs b/Distribution/Client/List.hs --- a/Distribution/Client/List.hs +++ b/Distribution/Client/List.hs @@ -138,6 +138,9 @@ -> InfoFlags -> [UserTarget] -> IO () +info verbosity _ _ _ _ _ _ [] = + notice verbosity "No packages requested. Nothing to do." + info verbosity packageDBs repos comp conf globalFlags _listFlags userTargets = do @@ -184,9 +187,8 @@ sourcePkgs selectedSourcePkg' showPkgVersion where - pref = prefs name - installedPkgs = concatMap snd (InstalledPackageIndex.lookupPackageName installedPkgIndex name) - sourcePkgs = PackageIndex.lookupPackageName sourcePkgIndex name + (pref, installedPkgs, sourcePkgs) = + sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex selectedInstalledPkgs = InstalledPackageIndex.lookupDependency installedPkgIndex (Dependency name verConstraint) @@ -205,10 +207,22 @@ selectedPkg True where name = packageName pkg - pref = prefs name - installedPkgs = concatMap snd (InstalledPackageIndex.lookupPackageName installedPkgIndex name) - sourcePkgs = PackageIndex.lookupPackageName sourcePkgIndex name selectedPkg = Just pkg + (pref, installedPkgs, sourcePkgs) = + sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex + +sourcePkgsInfo :: + (PackageName -> VersionRange) + -> PackageName + -> InstalledPackageIndex.PackageIndex + -> PackageIndex.PackageIndex SourcePackage + -> (VersionRange, [Installed.InstalledPackageInfo], [SourcePackage]) +sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex = + (pref, installedPkgs, sourcePkgs) + where + pref = prefs name + installedPkgs = concatMap snd (InstalledPackageIndex.lookupPackageName installedPkgIndex name) + sourcePkgs = PackageIndex.lookupPackageName sourcePkgIndex name -- | The info that we can display for each package. It is information per diff --git a/Distribution/Client/PackageIndex.hs b/Distribution/Client/PackageIndex.hs --- a/Distribution/Client/PackageIndex.hs +++ b/Distribution/Client/PackageIndex.hs @@ -63,7 +63,7 @@ import Data.Array ((!)) import Data.List (groupBy, sortBy, nub, isInfixOf) import Data.Monoid (Monoid(..)) -import Data.Maybe (isJust, isNothing, fromMaybe) +import Data.Maybe (isJust, isNothing, fromMaybe, catMaybes) import Distribution.Package ( PackageName(..), PackageIdentifier(..) @@ -90,7 +90,7 @@ deriving (Show, Read) instance Package pkg => Monoid (PackageIndex pkg) where - mempty = PackageIndex (Map.empty) + mempty = PackageIndex Map.empty mappend = merge --save one mappend with empty in the common case: mconcat [] = mempty @@ -334,9 +334,9 @@ , isNothing (lookupPackageId index pkg') ] , not (null missing) ] --- | Tries to take the transative closure of the package dependencies. +-- | Tries to take the transitive closure of the package dependencies. -- --- If the transative closure is complete then it returns that subset of the +-- If the transitive closure is complete then it returns that subset of the -- index. Otherwise it returns the broken packages as in 'brokenPackages'. -- -- * Note that if the result is @Right []@ it is because at least one of @@ -360,7 +360,7 @@ where completed' = insert pkg completed pkgids' = depends pkg ++ pkgids --- | Takes the transative closure of the packages reverse dependencies. +-- | Takes the transitive closure of the packages reverse dependencies. -- -- * The given 'PackageIdentifier's must be in the index. -- @@ -466,9 +466,8 @@ PackageIdentifier -> Maybe Graph.Vertex) dependencyGraph index = (graph, vertexToPkg, pkgIdToVertex) where - graph = Array.listArray bounds - [ [ v | Just v <- map pkgIdToVertex (depends pkg) ] - | pkg <- pkgs ] + graph = Array.listArray bounds $ + map (catMaybes . map pkgIdToVertex . depends) pkgs vertexToPkg vertex = pkgTable ! vertex pkgIdToVertex = binarySearch 0 topBound diff --git a/Distribution/Client/ParseUtils.hs b/Distribution/Client/ParseUtils.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/ParseUtils.hs @@ -0,0 +1,57 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.ParseUtils +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Parsing utilities. +----------------------------------------------------------------------------- + +module Distribution.Client.ParseUtils ( parseFields, ppFields, ppSection ) + where + +import Distribution.ParseUtils + ( FieldDescr(..), ParseResult(..), warning, lineNo ) +import qualified Distribution.ParseUtils as ParseUtils + ( Field(..) ) + +import Control.Monad ( foldM ) +import Text.PrettyPrint ( (<>), (<+>), ($$) ) +import qualified Data.Map as Map +import qualified Text.PrettyPrint as Disp + ( Doc, text, colon, vcat, empty, isEmpty, nest ) + +--FIXME: replace this with something better +parseFields :: [FieldDescr a] -> a -> [ParseUtils.Field] -> ParseResult a +parseFields fields = foldM setField + where + fieldMap = Map.fromList + [ (name, f) | f@(FieldDescr name _ _) <- fields ] + setField accum (ParseUtils.F line name value) = + case Map.lookup name fieldMap of + Just (FieldDescr _ _ set) -> set line value accum + Nothing -> do + warning $ "Unrecognized field " ++ name ++ " on line " ++ show line + return accum + setField accum f = do + warning $ "Unrecognized stanza on line " ++ show (lineNo f) + return accum + +-- | This is a customised version of the functions from Distribution.ParseUtils +-- that also optionally print default values for empty fields as comments. +-- +ppFields :: [FieldDescr a] -> (Maybe a) -> a -> Disp.Doc +ppFields fields def cur = Disp.vcat [ ppField name (fmap getter def) (getter cur) + | FieldDescr name getter _ <- fields] + +ppField :: String -> (Maybe Disp.Doc) -> Disp.Doc -> Disp.Doc +ppField name mdef cur + | Disp.isEmpty cur = maybe Disp.empty + (\def -> Disp.text "--" <+> Disp.text name + <> Disp.colon <+> def) mdef + | otherwise = Disp.text name <> Disp.colon <+> cur + +ppSection :: String -> String -> [FieldDescr a] -> (Maybe a) -> a -> Disp.Doc +ppSection name arg fields def cur = + Disp.text name <+> Disp.text arg + $$ Disp.nest 2 (ppFields fields def cur) diff --git a/Distribution/Client/Run.hs b/Distribution/Client/Run.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Run.hs @@ -0,0 +1,64 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Run +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Implementation of the 'run' command. +----------------------------------------------------------------------------- + +module Distribution.Client.Run ( run, splitRunArgs ) + where + +import Distribution.Client.Utils (tryCanonicalizePath) + +import Distribution.PackageDescription (Executable (..), + PackageDescription (..)) +import Distribution.Simple.Build.PathsModule (pkgPathEnvVar) +import Distribution.Simple.BuildPaths (exeExtension) +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo (..)) +import Distribution.Simple.Utils (die, rawSystemExitWithEnv) +import Distribution.Verbosity (Verbosity) + +import Data.Functor ((<$>)) +import Data.List (find) +import System.Directory (getCurrentDirectory) +import Distribution.Compat.Environment (getEnvironment) +import System.FilePath ((<.>), ()) + + +-- | Return the executable to run and any extra arguments that should be +-- forwarded to it. +splitRunArgs :: LocalBuildInfo -> [String] -> IO (Executable, [String]) +splitRunArgs lbi args = + case exes of + [] -> die "Couldn't find any executables." + [exe] -> case args of + [] -> return (exe, []) + (x:xs) | x == exeName exe -> return (exe, xs) + | otherwise -> return (exe, args) + _ -> case args of + [] -> die $ "This package contains multiple executables. " + ++ "You must pass the executable name as the first argument " + ++ "to 'cabal run'." + (x:xs) -> case find (\exe -> exeName exe == x) exes of + Nothing -> die $ "No executable named '" ++ x ++ "'." + Just exe -> return (exe, xs) + where + pkg_descr = localPkgDescr lbi + exes = executables pkg_descr + + +-- | Run a given executable. +run :: Verbosity -> LocalBuildInfo -> Executable -> [String] -> IO () +run verbosity lbi exe exeArgs = do + curDir <- getCurrentDirectory + let buildPref = buildDir lbi + pkg_descr = localPkgDescr lbi + dataDirEnvVar = (pkgPathEnvVar pkg_descr "datadir", + curDir dataDir pkg_descr) + + path <- tryCanonicalizePath $ + buildPref exeName exe (exeName exe <.> exeExtension) + env <- (dataDirEnvVar:) <$> getEnvironment + rawSystemExitWithEnv verbosity path exeArgs env diff --git a/Distribution/Client/Sandbox.hs b/Distribution/Client/Sandbox.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Sandbox.hs @@ -0,0 +1,730 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Sandbox +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- UI for the sandboxing functionality. +----------------------------------------------------------------------------- + +module Distribution.Client.Sandbox ( + sandboxInit, + sandboxDelete, + sandboxAddSource, + sandboxAddSourceSnapshot, + sandboxDeleteSource, + sandboxListSources, + sandboxHcPkg, + dumpPackageEnvironment, + withSandboxBinDirOnSearchPath, + + getSandboxConfigFilePath, + loadConfigOrSandboxConfig, + initPackageDBIfNeeded, + maybeWithSandboxDirOnSearchPath, + + WereDepsReinstalled(..), + reinstallAddSourceDeps, + maybeReinstallAddSourceDeps, + + SandboxPackageInfo(..), + maybeWithSandboxPackageInfo, + + tryGetIndexFilePath, + sandboxBuildDir, + getInstalledPackagesInSandbox, + + -- FIXME: move somewhere else + configPackageDB', configCompilerAux' + ) where + +import Distribution.Client.Setup + ( SandboxFlags(..), ConfigFlags(..), ConfigExFlags(..), InstallFlags(..) + , GlobalFlags(..), defaultConfigExFlags, defaultInstallFlags + , defaultSandboxLocation, globalRepos ) +import Distribution.Client.Sandbox.Timestamp ( listModifiedDeps + , maybeAddCompilerTimestampRecord + , withAddTimestamps + , withRemoveTimestamps ) +import Distribution.Client.Config ( SavedConfig(..), loadConfig ) +import Distribution.Client.Dependency ( foldProgress ) +import Distribution.Client.IndexUtils ( BuildTreeRefType(..) ) +import Distribution.Client.Install ( InstallArgs, + makeInstallContext, + makeInstallPlan, + processInstallPlan ) +import Distribution.Client.Sandbox.PackageEnvironment + ( PackageEnvironment(..), IncludeComments(..), PackageEnvironmentType(..) + , createPackageEnvironmentFile, classifyPackageEnvironment + , tryLoadSandboxPackageEnvironmentFile, loadUserConfig + , commentPackageEnvironment, showPackageEnvironmentWithComments + , sandboxPackageEnvironmentFile, userPackageEnvironmentFile ) +import Distribution.Client.Sandbox.Types ( SandboxPackageInfo(..) + , UseSandbox(..) ) +import Distribution.Client.Types ( PackageLocation(..) + , SourcePackage(..) ) +import Distribution.Client.Utils ( inDir, tryCanonicalizePath ) +import Distribution.PackageDescription.Configuration + ( flattenPackageDescription ) +import Distribution.PackageDescription.Parse ( readPackageDescription ) +import Distribution.Simple.Compiler ( Compiler(..), PackageDB(..) + , PackageDBStack ) +import Distribution.Simple.Configure ( configCompilerAuxEx + , interpretPackageDbFlags + , getPackageDBContents ) +import Distribution.Simple.PreProcess ( knownSuffixHandlers ) +import Distribution.Simple.Program ( ProgramConfiguration ) +import Distribution.Simple.Setup ( Flag(..), HaddockFlags(..) + , fromFlagOrDefault ) +import Distribution.Simple.SrcDist ( prepareTree ) +import Distribution.Simple.Utils ( die, debug, notice, warn + , debugNoWrap, defaultPackageDesc + , findPackageDesc + , intercalate, topHandlerWith + , createDirectoryIfMissingVerbose ) +import Distribution.Package ( Package(..) ) +import Distribution.System ( Platform ) +import Distribution.Text ( display ) +import Distribution.Verbosity ( Verbosity, lessVerbose ) +import Distribution.Client.Compat.Environment ( lookupEnv, setEnv ) +import Distribution.Client.Compat.FilePerms ( setFileHidden ) +import qualified Distribution.Client.Sandbox.Index as Index +import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex +import qualified Distribution.Simple.Register as Register +import qualified Data.Map as M +import qualified Data.Set as S +import Control.Exception ( assert, bracket_ ) +import Control.Monad ( forM, liftM2, unless, when ) +import Data.Bits ( shiftL, shiftR, xor ) +import Data.Char ( ord ) +import Data.IORef ( newIORef, writeIORef, readIORef ) +import Data.List ( delete, foldl' ) +import Data.Maybe ( fromJust ) +import Data.Monoid ( mempty, mappend ) +import Data.Word ( Word32 ) +import Numeric ( showHex ) +import System.Directory ( createDirectory + , doesDirectoryExist + , doesFileExist + , getCurrentDirectory + , removeDirectoryRecursive + , removeFile + , renameDirectory ) +import System.FilePath ( (), getSearchPath + , searchPathSeparator + , takeDirectory ) + + +-- +-- * Constants +-- + +-- | The name of the sandbox subdirectory where we keep snapshots of add-source +-- dependencies. +snapshotDirectoryName :: FilePath +snapshotDirectoryName = "snapshots" + +-- | Non-standard build dir that is used for building add-source deps instead of +-- "dist". Fixes surprising behaviour in some cases (see issue #1281). +sandboxBuildDir :: FilePath -> FilePath +sandboxBuildDir sandboxDir = "dist/dist-sandbox-" ++ showHex sandboxDirHash "" + where + sandboxDirHash = jenkins sandboxDir + + -- See http://en.wikipedia.org/wiki/Jenkins_hash_function + jenkins :: String -> Word32 + jenkins str = loop_finish $ foldl' loop 0 str + where + loop :: Word32 -> Char -> Word32 + loop hash key_i' = hash''' + where + key_i = toEnum . ord $ key_i' + hash' = hash + key_i + hash'' = hash' + (shiftL hash' 10) + hash''' = hash'' `xor` (shiftR hash'' 6) + + loop_finish :: Word32 -> Word32 + loop_finish hash = hash''' + where + hash' = hash + (shiftL hash 3) + hash'' = hash' `xor` (shiftR hash' 11) + hash''' = hash'' + (shiftL hash'' 15) + +-- +-- * Basic sandbox functions. +-- + +-- | Return the path to the package environment directory - either the current +-- directory or the one that @--sandbox-config-file@ resides in. +getPkgEnvDir :: GlobalFlags -> IO FilePath +getPkgEnvDir globalFlags = do + let sandboxConfigFileFlag = globalSandboxConfigFile globalFlags + case sandboxConfigFileFlag of + NoFlag -> getCurrentDirectory + Flag path -> tryCanonicalizePath . takeDirectory $ path + +-- | Return the path to the sandbox config file - either the default or the one +-- specified with @--sandbox-config-file@. +getSandboxConfigFilePath :: GlobalFlags -> IO FilePath +getSandboxConfigFilePath globalFlags = do + let sandboxConfigFileFlag = globalSandboxConfigFile globalFlags + case sandboxConfigFileFlag of + NoFlag -> do pkgEnvDir <- getCurrentDirectory + return (pkgEnvDir sandboxPackageEnvironmentFile) + Flag path -> return path + +-- | Load the @cabal.sandbox.config@ file (and possibly the optional +-- @cabal.config@). In addition to a @PackageEnvironment@, also return a +-- canonical path to the sandbox. Exit with error if the sandbox directory or +-- the package environment file do not exist. +tryLoadSandboxConfig :: Verbosity -> GlobalFlags + -> IO (FilePath, PackageEnvironment) +tryLoadSandboxConfig verbosity globalFlags = do + path <- getSandboxConfigFilePath globalFlags + tryLoadSandboxPackageEnvironmentFile verbosity path + (globalConfigFile globalFlags) + +-- | Return the name of the package index file for this package environment. +tryGetIndexFilePath :: SavedConfig -> IO FilePath +tryGetIndexFilePath config = tryGetIndexFilePath' (savedGlobalFlags config) + +-- | The same as 'tryGetIndexFilePath', but takes 'GlobalFlags' instead of +-- 'SavedConfig'. +tryGetIndexFilePath' :: GlobalFlags -> IO FilePath +tryGetIndexFilePath' globalFlags = do + let paths = globalLocalRepos globalFlags + case paths of + [] -> die $ "Distribution.Client.Sandbox.tryGetIndexFilePath: " ++ + "no local repos found. " ++ checkConfiguration + _ -> return $ (last paths) Index.defaultIndexFileName + where + checkConfiguration = "Please check your configuration ('" + ++ userPackageEnvironmentFile ++ "')." + +-- | Try to extract a 'PackageDB' from 'ConfigFlags'. Gives a better error +-- message than just pattern-matching. +getSandboxPackageDB :: ConfigFlags -> IO PackageDB +getSandboxPackageDB configFlags = do + case configPackageDBs configFlags of + [Just sandboxDB@(SpecificPackageDB _)] -> return sandboxDB + -- TODO: should we allow multiple package DBs (e.g. with 'inherit')? + + [] -> + die $ "Sandbox package DB is not specified. " ++ sandboxConfigCorrupt + [_] -> + die $ "Unexpected contents of the 'package-db' field. " + ++ sandboxConfigCorrupt + _ -> + die $ "Too many package DBs provided. " ++ sandboxConfigCorrupt + + where + sandboxConfigCorrupt = "Your 'cabal.sandbox.config' is probably corrupt." + + +-- | Which packages are installed in the sandbox package DB? +getInstalledPackagesInSandbox :: Verbosity -> ConfigFlags + -> Compiler -> ProgramConfiguration + -> IO InstalledPackageIndex.PackageIndex +getInstalledPackagesInSandbox verbosity configFlags comp conf = do + sandboxDB <- getSandboxPackageDB configFlags + getPackageDBContents verbosity comp sandboxDB conf + +-- | Temporarily add $SANDBOX_DIR/bin to $PATH. +withSandboxBinDirOnSearchPath :: FilePath -> IO a -> IO a +withSandboxBinDirOnSearchPath sandboxDir = bracket_ addBinDir rmBinDir + where + -- TODO: Instead of modifying the global process state, it'd be better to + -- set the environment individually for each subprocess invocation. This + -- will have to wait until the Shell monad is implemented; without it the + -- required changes are too intrusive. + addBinDir :: IO () + addBinDir = do + mbOldPath <- lookupEnv "PATH" + let newPath = maybe sandboxBin ((++) sandboxBin . (:) searchPathSeparator) + mbOldPath + setEnv "PATH" newPath + + rmBinDir :: IO () + rmBinDir = do + oldPath <- getSearchPath + let newPath = intercalate [searchPathSeparator] + (delete sandboxBin oldPath) + setEnv "PATH" newPath + + sandboxBin = sandboxDir "bin" + +-- | Initialise a package DB for this compiler if it doesn't exist. +initPackageDBIfNeeded :: Verbosity -> ConfigFlags + -> Compiler -> ProgramConfiguration + -> IO () +initPackageDBIfNeeded verbosity configFlags comp conf = do + SpecificPackageDB dbPath <- getSandboxPackageDB configFlags + packageDBExists <- doesDirectoryExist dbPath + unless packageDBExists $ + Register.initPackageDB verbosity comp conf dbPath + when packageDBExists $ + debug verbosity $ "The package database already exists: " ++ dbPath + +-- | Entry point for the 'cabal dump-pkgenv' command. +dumpPackageEnvironment :: Verbosity -> SandboxFlags -> GlobalFlags -> IO () +dumpPackageEnvironment verbosity _sandboxFlags globalFlags = do + (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags + commentPkgEnv <- commentPackageEnvironment sandboxDir + putStrLn . showPackageEnvironmentWithComments (Just commentPkgEnv) $ pkgEnv + +-- | Entry point for the 'cabal sandbox-init' command. +sandboxInit :: Verbosity -> SandboxFlags -> GlobalFlags -> IO () +sandboxInit verbosity sandboxFlags globalFlags = do + -- Warn if there's a 'cabal-dev' sandbox. + isCabalDevSandbox <- liftM2 (&&) (doesDirectoryExist "cabal-dev") + (doesFileExist $ "cabal-dev" "cabal.config") + when isCabalDevSandbox $ + warn verbosity $ + "You are apparently using a legacy (cabal-dev) sandbox. " + ++ "Legacy sandboxes may interact badly with native Cabal sandboxes. " + ++ "You may want to delete the 'cabal-dev' directory to prevent issues." + + -- Create the sandbox directory. + let sandboxDir' = fromFlagOrDefault defaultSandboxLocation + (sandboxLocation sandboxFlags) + createDirectoryIfMissingVerbose verbosity True sandboxDir' + sandboxDir <- tryCanonicalizePath sandboxDir' + setFileHidden sandboxDir + + -- Determine which compiler to use (using the value from ~/.cabal/config). + userConfig <- loadConfig verbosity (globalConfigFile globalFlags) NoFlag + (comp, platform, conf) <- configCompilerAuxEx (savedConfigureFlags userConfig) + + -- Create the package environment file. + pkgEnvFile <- getSandboxConfigFilePath globalFlags + createPackageEnvironmentFile verbosity sandboxDir pkgEnvFile + NoComments comp platform + (_sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags + let config = pkgEnvSavedConfig pkgEnv + configFlags = savedConfigureFlags config + + -- Create the index file if it doesn't exist. + indexFile <- tryGetIndexFilePath config + indexFileExists <- doesFileExist indexFile + if indexFileExists + then notice verbosity $ "Using an existing sandbox located at " ++ sandboxDir + else notice verbosity $ "Creating a new sandbox at " ++ sandboxDir + Index.createEmpty verbosity indexFile + + -- Create the package DB for the default compiler. + initPackageDBIfNeeded verbosity configFlags comp conf + maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile + (compilerId comp) platform + +-- | Entry point for the 'cabal sandbox-delete' command. +sandboxDelete :: Verbosity -> SandboxFlags -> GlobalFlags -> IO () +sandboxDelete verbosity _sandboxFlags globalFlags = do + (useSandbox, _) <- loadConfigOrSandboxConfig verbosity globalFlags mempty + case useSandbox of + NoSandbox -> die "Not in a sandbox." + UseSandbox sandboxDir -> do + curDir <- getCurrentDirectory + pkgEnvFile <- getSandboxConfigFilePath globalFlags + + -- Remove the @cabal.sandbox.config@ file, unless it's in a non-standard + -- location. + let isNonDefaultConfigLocation = + pkgEnvFile /= (curDir sandboxPackageEnvironmentFile) + + if isNonDefaultConfigLocation + then warn verbosity $ "Sandbox config file is in non-default location: '" + ++ pkgEnvFile ++ "'.\n Please delete manually." + else removeFile pkgEnvFile + + -- Remove the sandbox directory, unless we're using a shared sandbox. + let isNonDefaultSandboxLocation = + sandboxDir /= (curDir defaultSandboxLocation) + + when isNonDefaultSandboxLocation $ + die $ "Non-default sandbox location used: '" ++ sandboxDir + ++ "'.\nAssuming a shared sandbox. Please delete '" + ++ sandboxDir ++ "' manually." + + notice verbosity $ "Deleting the sandbox located at " ++ sandboxDir + removeDirectoryRecursive sandboxDir + +-- Common implementation of 'sandboxAddSource' and 'sandboxAddSourceSnapshot'. +doAddSource :: Verbosity -> [FilePath] -> FilePath -> PackageEnvironment + -> BuildTreeRefType + -> IO () +doAddSource verbosity buildTreeRefs sandboxDir pkgEnv refType = do + let savedConfig = pkgEnvSavedConfig pkgEnv + indexFile <- tryGetIndexFilePath savedConfig + + -- If we're running 'sandbox add-source' for the first time for this compiler, + -- we need to create an initial timestamp record. + (comp, platform, _) <- configCompilerAuxEx . savedConfigureFlags $ savedConfig + maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile + (compilerId comp) platform + + withAddTimestamps sandboxDir $ do + -- FIXME: path canonicalisation is done in addBuildTreeRefs, but we do it + -- twice because of the timestamps file. + buildTreeRefs' <- mapM tryCanonicalizePath buildTreeRefs + Index.addBuildTreeRefs verbosity indexFile buildTreeRefs' refType + return buildTreeRefs' + +-- | Entry point for the 'cabal sandbox add-source' command. +sandboxAddSource :: Verbosity -> [FilePath] -> SandboxFlags -> GlobalFlags + -> IO () +sandboxAddSource verbosity buildTreeRefs sandboxFlags globalFlags = do + (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags + + if fromFlagOrDefault False (sandboxSnapshot sandboxFlags) + then sandboxAddSourceSnapshot verbosity buildTreeRefs sandboxDir pkgEnv + else doAddSource verbosity buildTreeRefs sandboxDir pkgEnv LinkRef + +-- | Entry point for the 'cabal sandbox add-source --snapshot' command. +sandboxAddSourceSnapshot :: Verbosity -> [FilePath] -> FilePath + -> PackageEnvironment + -> IO () +sandboxAddSourceSnapshot verbosity buildTreeRefs sandboxDir pkgEnv = do + let snapshotDir = sandboxDir snapshotDirectoryName + + -- Use 'D.S.SrcDist.prepareTree' to copy each package's files to our private + -- location. + createDirectoryIfMissingVerbose verbosity True snapshotDir + + -- Collect the package descriptions first, so that if some path does not refer + -- to a cabal package, we fail immediately. + pkgs <- forM buildTreeRefs $ \buildTreeRef -> + inDir (Just buildTreeRef) $ + return . flattenPackageDescription + =<< readPackageDescription verbosity + =<< defaultPackageDesc verbosity + + -- Copy the package sources to "snapshots/$PKGNAME-$VERSION-tmp". If + -- 'prepareTree' throws an error at any point, the old snapshots will still be + -- in consistent state. + tmpDirs <- forM (zip buildTreeRefs pkgs) $ \(buildTreeRef, pkg) -> + inDir (Just buildTreeRef) $ do + let targetDir = snapshotDir (display . packageId $ pkg) + targetTmpDir = targetDir ++ "-tmp" + dirExists <- doesDirectoryExist targetTmpDir + when dirExists $ + removeDirectoryRecursive targetDir + createDirectory targetTmpDir + prepareTree verbosity pkg Nothing targetTmpDir knownSuffixHandlers + return (targetTmpDir, targetDir) + + -- Now rename the "snapshots/$PKGNAME-$VERSION-tmp" dirs to + -- "snapshots/$PKGNAME-$VERSION". + snapshots <- forM tmpDirs $ \(targetTmpDir, targetDir) -> do + dirExists <- doesDirectoryExist targetDir + when dirExists $ + removeDirectoryRecursive targetDir + renameDirectory targetTmpDir targetDir + return targetDir + + -- Once the packages are copied, just 'add-source' them as usual. + doAddSource verbosity snapshots sandboxDir pkgEnv SnapshotRef + +-- | Entry point for the 'cabal sandbox delete-source' command. +sandboxDeleteSource :: Verbosity -> [FilePath] -> SandboxFlags -> GlobalFlags + -> IO () +sandboxDeleteSource verbosity buildTreeRefs _sandboxFlags globalFlags = do + (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags + indexFile <- tryGetIndexFilePath (pkgEnvSavedConfig pkgEnv) + + withRemoveTimestamps sandboxDir $ do + Index.removeBuildTreeRefs verbosity indexFile buildTreeRefs + + notice verbosity $ "Note: 'sandbox delete-source' only unregisters the " ++ + "source dependency, but does not remove the package " ++ + "from the sandbox package DB.\n\n" ++ + "Use 'sandbox hc-pkg -- unregister' to do that." + +-- | Entry point for the 'cabal sandbox list-sources' command. +sandboxListSources :: Verbosity -> SandboxFlags -> GlobalFlags + -> IO () +sandboxListSources verbosity _sandboxFlags globalFlags = do + (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags + indexFile <- tryGetIndexFilePath (pkgEnvSavedConfig pkgEnv) + + refs <- Index.listBuildTreeRefs verbosity + Index.ListIgnored Index.LinksAndSnapshots indexFile + when (null refs) $ + notice verbosity $ "Index file '" ++ indexFile + ++ "' has no references to local build trees." + when (not . null $ refs) $ do + notice verbosity $ "Source dependencies registered " + ++ "in the current sandbox ('" ++ sandboxDir ++ "'):\n\n" + mapM_ putStrLn refs + notice verbosity $ "\nTo unregister source dependencies, " + ++ "use the 'sandbox delete-source' command." + +-- | Invoke the @hc-pkg@ tool with provided arguments, restricted to the +-- sandbox. +sandboxHcPkg :: Verbosity -> SandboxFlags -> GlobalFlags -> [String] -> IO () +sandboxHcPkg verbosity _sandboxFlags globalFlags extraArgs = do + (_sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags + let configFlags = savedConfigureFlags . pkgEnvSavedConfig $ pkgEnv + dbStack = configPackageDB' configFlags + (comp, _platform, conf) <- configCompilerAux' configFlags + + Register.invokeHcPkg verbosity comp conf dbStack extraArgs + +-- | Check which type of package environment we're in and return a +-- correctly-initialised @SavedConfig@ and a @UseSandbox@ value that indicates +-- whether we're working in a sandbox. +loadConfigOrSandboxConfig :: Verbosity + -> GlobalFlags -- ^ For @--config-file@ and + -- @--sandbox-config-file@. + -> Flag Bool -- ^ Ignored if we're in a sandbox. + -> IO (UseSandbox, SavedConfig) +loadConfigOrSandboxConfig verbosity globalFlags userInstallFlag = do + let configFileFlag = globalConfigFile globalFlags + sandboxConfigFileFlag = globalSandboxConfigFile globalFlags + + pkgEnvDir <- getPkgEnvDir globalFlags + pkgEnvType <- case sandboxConfigFileFlag of + NoFlag -> classifyPackageEnvironment pkgEnvDir + Flag _ -> return SandboxPackageEnvironment + + case pkgEnvType of + -- A @cabal.sandbox.config@ file (and possibly @cabal.config@) is present. + SandboxPackageEnvironment -> do + (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags + -- ^ Prints an error message and exits on error. + let config = pkgEnvSavedConfig pkgEnv + return (UseSandbox sandboxDir, config) + + -- Only @cabal.config@ is present. + UserPackageEnvironment -> do + config <- loadConfig verbosity configFileFlag userInstallFlag + userConfig <- loadUserConfig verbosity pkgEnvDir + return (NoSandbox, config `mappend` userConfig) + + -- Neither @cabal.sandbox.config@ nor @cabal.config@ are present. + AmbientPackageEnvironment -> do + config <- loadConfig verbosity configFileFlag userInstallFlag + return (NoSandbox, config) + +-- | If we're in a sandbox, call @withSandboxBinDirOnSearchPath@, otherwise do +-- nothing. +maybeWithSandboxDirOnSearchPath :: UseSandbox -> IO a -> IO a +maybeWithSandboxDirOnSearchPath NoSandbox act = act +maybeWithSandboxDirOnSearchPath (UseSandbox sandboxDir) act = + withSandboxBinDirOnSearchPath sandboxDir $ act + +-- | Had reinstallAddSourceDeps actually reinstalled any dependencies? +data WereDepsReinstalled = ReinstalledSomeDeps | NoDepsReinstalled + +-- | Reinstall those add-source dependencies that have been modified since +-- we've last installed them. Assumes that we're working inside a sandbox. +reinstallAddSourceDeps :: Verbosity + -> ConfigFlags -> ConfigExFlags + -> InstallFlags -> GlobalFlags + -> FilePath + -> IO WereDepsReinstalled +reinstallAddSourceDeps verbosity configFlags' configExFlags + installFlags globalFlags sandboxDir = topHandler' $ do + let sandboxDistPref = sandboxBuildDir sandboxDir + configFlags = configFlags' + { configDistPref = Flag sandboxDistPref } + haddockFlags = mempty + { haddockDistPref = Flag sandboxDistPref } + (comp, platform, conf) <- configCompilerAux' configFlags + retVal <- newIORef NoDepsReinstalled + + withSandboxPackageInfo verbosity configFlags globalFlags + comp platform conf sandboxDir $ \sandboxPkgInfo -> + unless (null $ modifiedAddSourceDependencies sandboxPkgInfo) $ do + + let args :: InstallArgs + args = ((configPackageDB' configFlags) + ,(globalRepos globalFlags) + ,comp, platform, conf + ,UseSandbox sandboxDir, Just sandboxPkgInfo + ,globalFlags, configFlags, configExFlags, installFlags + ,haddockFlags) + + -- This can actually be replaced by a call to 'install', but we use a + -- lower-level API because of layer separation reasons. Additionally, we + -- might want to use some lower-level features this in the future. + withSandboxBinDirOnSearchPath sandboxDir $ do + installContext <- makeInstallContext verbosity args Nothing + installPlan <- foldProgress logMsg die' return =<< + makeInstallPlan verbosity args installContext + + processInstallPlan verbosity args installContext installPlan + writeIORef retVal ReinstalledSomeDeps + + readIORef retVal + + where + die' message = die (message ++ installFailedInSandbox) + -- TODO: use a better error message, remove duplication. + installFailedInSandbox = + "Note: when using a sandbox, all packages are required to have \ + consistent dependencies. \ + Try reinstalling/unregistering the offending packages or \ + recreating the sandbox." + logMsg message rest = debugNoWrap verbosity message >> rest + + topHandler' = topHandlerWith $ \_ -> do + warn verbosity "Couldn't reinstall some add-source dependencies." + -- Here we can't know whether any deps have been reinstalled, so we have + -- to be conservative. + return ReinstalledSomeDeps + +-- | Produce a 'SandboxPackageInfo' and feed it to the given action. Note that +-- we don't update the timestamp file here - this is done in +-- 'postInstallActions'. +withSandboxPackageInfo :: Verbosity -> ConfigFlags -> GlobalFlags + -> Compiler -> Platform -> ProgramConfiguration + -> FilePath + -> (SandboxPackageInfo -> IO ()) + -> IO () +withSandboxPackageInfo verbosity configFlags globalFlags + comp platform conf sandboxDir cont = do + -- List all add-source deps. + indexFile <- tryGetIndexFilePath' globalFlags + buildTreeRefs <- Index.listBuildTreeRefs verbosity + Index.DontListIgnored Index.OnlyLinks indexFile + let allAddSourceDepsSet = S.fromList buildTreeRefs + + -- List all packages installed in the sandbox. + installedPkgIndex <- getInstalledPackagesInSandbox verbosity + configFlags comp conf + + -- Get the package descriptions for all add-source deps. + depsCabalFiles <- mapM findPackageDesc buildTreeRefs + depsPkgDescs <- mapM (readPackageDescription verbosity) depsCabalFiles + let depsMap = M.fromList (zip buildTreeRefs depsPkgDescs) + isInstalled pkgid = not . null + . InstalledPackageIndex.lookupSourcePackageId installedPkgIndex $ pkgid + installedDepsMap = M.filter (isInstalled . packageId) depsMap + + -- Get the package ids of modified (and installed) add-source deps. + modifiedAddSourceDeps <- listModifiedDeps verbosity sandboxDir + (compilerId comp) platform installedDepsMap + -- 'fromJust' here is safe because 'modifiedAddSourceDeps' are guaranteed to + -- be a subset of the keys of 'depsMap'. + let modifiedDeps = [ (modDepPath, fromJust $ M.lookup modDepPath depsMap) + | modDepPath <- modifiedAddSourceDeps ] + modifiedDepsMap = M.fromList modifiedDeps + + assert (all (`S.member` allAddSourceDepsSet) modifiedAddSourceDeps) (return ()) + unless (null modifiedDeps) $ + notice verbosity $ "Some add-source dependencies have been modified. " + ++ "They will be reinstalled..." + + -- Get the package ids of the remaining add-source deps (some are possibly not + -- installed). + let otherDeps = M.assocs (depsMap `M.difference` modifiedDepsMap) + + -- Finally, assemble a 'SandboxPackageInfo'. + cont $ SandboxPackageInfo (map toSourcePackage modifiedDeps) + (map toSourcePackage otherDeps) installedPkgIndex allAddSourceDepsSet + + where + toSourcePackage (path, pkgDesc) = SourcePackage + (packageId pkgDesc) pkgDesc (LocalUnpackedPackage path) Nothing + +-- | Same as 'withSandboxPackageInfo' if we're inside a sandbox and a no-op +-- otherwise. +maybeWithSandboxPackageInfo :: Verbosity -> ConfigFlags -> GlobalFlags + -> Compiler -> Platform -> ProgramConfiguration + -> UseSandbox + -> (Maybe SandboxPackageInfo -> IO ()) + -> IO () +maybeWithSandboxPackageInfo verbosity configFlags globalFlags + comp platform conf useSandbox cont = + case useSandbox of + NoSandbox -> cont Nothing + UseSandbox sandboxDir -> withSandboxPackageInfo verbosity + configFlags globalFlags + comp platform conf sandboxDir + (\spi -> cont (Just spi)) + +-- | Check if a sandbox is present and call @reinstallAddSourceDeps@ in that +-- case. +maybeReinstallAddSourceDeps :: Verbosity + -> Flag (Maybe Int) -- ^ The '-j' flag + -> ConfigFlags -- ^ Saved configure flags + -- (from dist/setup-config) + -> GlobalFlags + -> IO (UseSandbox, WereDepsReinstalled) +maybeReinstallAddSourceDeps verbosity numJobsFlag configFlags' globalFlags' = do + currentDir <- getCurrentDirectory + pkgEnvType <- classifyPackageEnvironment currentDir + case pkgEnvType of + AmbientPackageEnvironment -> return (NoSandbox, NoDepsReinstalled) + UserPackageEnvironment -> return (NoSandbox, NoDepsReinstalled) + SandboxPackageEnvironment -> do + (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags' + + -- Actually reinstall the modified add-source deps. + let config = pkgEnvSavedConfig pkgEnv + configFlags = savedConfigureFlags config + `mappendSomeSavedFlags` + configFlags' + configExFlags = defaultConfigExFlags + `mappend` savedConfigureExFlags config + installFlags' = defaultInstallFlags + `mappend` savedInstallFlags config + installFlags = installFlags' { + installNumJobs = installNumJobs installFlags' + `mappend` numJobsFlag + } + globalFlags = savedGlobalFlags config + -- This makes it possible to override things like 'remote-repo-cache' + -- from the command line. These options are hidden, and are only + -- useful for debugging, so this should be fine. + `mappend` globalFlags' + depsReinstalled <- reinstallAddSourceDeps verbosity + configFlags configExFlags installFlags globalFlags + sandboxDir + return (UseSandbox sandboxDir, depsReinstalled) + + where + + -- NOTE: we can't simply do @sandboxConfigFlags `mappend` savedFlags@ + -- because we don't want to auto-enable things like 'library-profiling' for + -- all add-source dependencies even if the user has passed + -- '--enable-library-profiling' to 'cabal configure'. These options are + -- supposed to be set in 'cabal.config'. + mappendSomeSavedFlags :: ConfigFlags -> ConfigFlags -> ConfigFlags + mappendSomeSavedFlags sandboxConfigFlags savedFlags = + sandboxConfigFlags { + configHcFlavor = configHcFlavor sandboxConfigFlags + `mappend` configHcFlavor savedFlags, + configHcPath = configHcPath sandboxConfigFlags + `mappend` configHcPath savedFlags, + configHcPkg = configHcPkg sandboxConfigFlags + `mappend` configHcPkg savedFlags, + configProgramPaths = configProgramPaths sandboxConfigFlags + `mappend` configProgramPaths savedFlags, + configProgramArgs = configProgramArgs sandboxConfigFlags + `mappend` configProgramArgs savedFlags + -- NOTE: We don't touch the @configPackageDBs@ field because + -- @sandboxConfigFlags@ contains the sandbox location which was set when + -- creating @cabal.sandbox.config@. + -- FIXME: Is this compatible with the 'inherit' feature? + } + +-- +-- Utils (transitionary) +-- +-- FIXME: configPackageDB' and configCompilerAux' don't really belong in this +-- module +-- + +configPackageDB' :: ConfigFlags -> PackageDBStack +configPackageDB' cfg = + interpretPackageDbFlags userInstall (configPackageDBs cfg) + where + userInstall = fromFlagOrDefault True (configUserInstall cfg) + +configCompilerAux' :: ConfigFlags + -> IO (Compiler, Platform, ProgramConfiguration) +configCompilerAux' configFlags = + configCompilerAuxEx configFlags + --FIXME: make configCompilerAux use a sensible verbosity + { configVerbosity = fmap lessVerbose (configVerbosity configFlags) } diff --git a/Distribution/Client/Sandbox/Index.hs b/Distribution/Client/Sandbox/Index.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Sandbox/Index.hs @@ -0,0 +1,237 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Sandbox.Index +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Querying and modifying local build tree references in the package index. +----------------------------------------------------------------------------- + +module Distribution.Client.Sandbox.Index ( + createEmpty, + addBuildTreeRefs, + removeBuildTreeRefs, + ListIgnoredBuildTreeRefs(..), RefTypesToList(..), + listBuildTreeRefs, + validateIndexPath, + + defaultIndexFileName + ) where + +import qualified Distribution.Client.Tar as Tar +import Distribution.Client.IndexUtils ( BuildTreeRefType(..) + , refTypeFromTypeCode + , typeCodeFromRefType + , getSourcePackagesStrict ) +import Distribution.Client.PackageIndex ( allPackages ) +import Distribution.Client.Types ( Repo(..), LocalRepo(..) + , SourcePackageDb(..) + , SourcePackage(..), PackageLocation(..) ) +import Distribution.Client.Utils ( byteStringToFilePath, filePathToByteString + , makeAbsoluteToCwd, tryCanonicalizePath + , canonicalizePathNoThrow ) + +import Distribution.Simple.Utils ( die, debug, findPackageDesc ) +import Distribution.Verbosity ( Verbosity ) + +import qualified Data.ByteString.Lazy as BS +import Control.Exception ( evaluate ) +import Control.Monad ( liftM, unless ) +import Data.List ( (\\), intersect, nub ) +import Data.Maybe ( catMaybes ) +import System.Directory ( createDirectoryIfMissing, + doesDirectoryExist, doesFileExist, + renameFile ) +import System.FilePath ( (), (<.>), takeDirectory, takeExtension ) +import System.IO ( IOMode(..), SeekMode(..) + , hSeek, withBinaryFile ) + +-- | A reference to a local build tree. +data BuildTreeRef = BuildTreeRef { + buildTreeRefType :: !BuildTreeRefType, + buildTreePath :: !FilePath + } + +defaultIndexFileName :: FilePath +defaultIndexFileName = "00-index.tar" + +-- | Given a path, ensure that it refers to a local build tree. +buildTreeRefFromPath :: BuildTreeRefType -> FilePath -> IO (Maybe BuildTreeRef) +buildTreeRefFromPath refType dir = do + dirExists <- doesDirectoryExist dir + unless dirExists $ + die $ "directory '" ++ dir ++ "' does not exist" + _ <- findPackageDesc dir + return . Just $ BuildTreeRef refType dir + +-- | Given a tar archive entry, try to parse it as a local build tree reference. +readBuildTreeRef :: Tar.Entry -> Maybe BuildTreeRef +readBuildTreeRef entry = case Tar.entryContent entry of + (Tar.OtherEntryType typeCode bs size) + | (Tar.isBuildTreeRefTypeCode typeCode) + && (size == BS.length bs) -> Just $! BuildTreeRef + (refTypeFromTypeCode typeCode) + (byteStringToFilePath bs) + | otherwise -> Nothing + _ -> Nothing + +-- | Given a sequence of tar archive entries, extract all references to local +-- build trees. +readBuildTreeRefs :: Tar.Entries -> [BuildTreeRef] +readBuildTreeRefs = + catMaybes + . Tar.foldrEntries (\e r -> readBuildTreeRef e : r) + [] error + +-- | Given a path to a tar archive, extract all references to local build trees. +readBuildTreeRefsFromFile :: FilePath -> IO [BuildTreeRef] +readBuildTreeRefsFromFile = liftM (readBuildTreeRefs . Tar.read) . BS.readFile + +-- | Given a local build tree ref, serialise it to a tar archive entry. +writeBuildTreeRef :: BuildTreeRef -> Tar.Entry +writeBuildTreeRef (BuildTreeRef refType path) = Tar.simpleEntry tarPath content + where + bs = filePathToByteString path + -- Provide a filename for tools that treat custom entries as ordinary files. + tarPath' = "local-build-tree-reference" + -- fromRight can't fail because the path is shorter than 255 characters. + tarPath = fromRight $ Tar.toTarPath True tarPath' + content = Tar.OtherEntryType (typeCodeFromRefType refType) bs (BS.length bs) + + -- TODO: Move this to D.C.Utils? + fromRight (Left err) = error err + fromRight (Right a) = a + +-- | Check that the provided path is either an existing directory, or a tar +-- archive in an existing directory. +validateIndexPath :: FilePath -> IO FilePath +validateIndexPath path' = do + path <- makeAbsoluteToCwd path' + if (== ".tar") . takeExtension $ path + then return path + else do dirExists <- doesDirectoryExist path + unless dirExists $ + die $ "directory does not exist: '" ++ path ++ "'" + return $ path defaultIndexFileName + +-- | Create an empty index file. +createEmpty :: Verbosity -> FilePath -> IO () +createEmpty verbosity path = do + indexExists <- doesFileExist path + if indexExists + then debug verbosity $ "Package index already exists: " ++ path + else do + debug verbosity $ "Creating the index file '" ++ path ++ "'" + createDirectoryIfMissing True (takeDirectory path) + -- Equivalent to 'tar cvf empty.tar --files-from /dev/null'. + let zeros = BS.replicate (512*20) 0 + BS.writeFile path zeros + +-- | Add given local build tree references to the index. +addBuildTreeRefs :: Verbosity -> FilePath -> [FilePath] -> BuildTreeRefType + -> IO () +addBuildTreeRefs _ _ [] _ = + error "Distribution.Client.Sandbox.Index.addBuildTreeRefs: unexpected" +addBuildTreeRefs verbosity path l' refType = do + checkIndexExists path + l <- liftM nub . mapM tryCanonicalizePath $ l' + treesInIndex <- fmap (map buildTreePath) (readBuildTreeRefsFromFile path) + -- Add only those paths that aren't already in the index. + treesToAdd <- mapM (buildTreeRefFromPath refType) (l \\ treesInIndex) + let entries = map writeBuildTreeRef (catMaybes treesToAdd) + unless (null entries) $ do + offset <- + fmap (Tar.foldrEntries (\e acc -> Tar.entrySizeInBytes e + acc) 0 error + . Tar.read) $ BS.readFile path + _ <- evaluate offset + debug verbosity $ "Writing at offset: " ++ show offset + withBinaryFile path ReadWriteMode $ \h -> do + hSeek h AbsoluteSeek (fromIntegral offset) + BS.hPut h (Tar.write entries) + debug verbosity $ "Successfully appended to '" ++ path ++ "'" + +-- | Remove given local build tree references from the index. +removeBuildTreeRefs :: Verbosity -> FilePath -> [FilePath] -> IO [FilePath] +removeBuildTreeRefs _ _ [] = + error "Distribution.Client.Sandbox.Index.removeBuildTreeRefs: unexpected" +removeBuildTreeRefs verbosity path l' = do + checkIndexExists path + l <- mapM canonicalizePathNoThrow l' + let tmpFile = path <.> "tmp" + -- Performance note: on my system, it takes 'index --remove-source' + -- approx. 3,5s to filter a 65M file. Real-life indices are expected to be + -- much smaller. + BS.writeFile tmpFile . Tar.writeEntries . Tar.filterEntries (p l) . Tar.read + =<< BS.readFile path + -- This invalidates the cache, so we don't have to update it explicitly. + renameFile tmpFile path + debug verbosity $ "Successfully renamed '" ++ tmpFile + ++ "' to '" ++ path ++ "'" + -- FIXME: return only the refs that vere actually removed. + return l + where + p l entry = case readBuildTreeRef entry of + Nothing -> True + -- FIXME: removing snapshot deps is done with `delete-source + -- .cabal-sandbox/snapshots/$SNAPSHOT_NAME`. Perhaps we also want to + -- support removing snapshots by providing the original path. + (Just (BuildTreeRef _ pth)) -> pth `notElem` l + +-- | A build tree ref can become ignored if the user later adds a build tree ref +-- with the same package ID. We display ignored build tree refs when the user +-- runs 'cabal sandbox list-sources', but do not look at their timestamps in +-- 'reinstallAddSourceDeps'. +data ListIgnoredBuildTreeRefs = ListIgnored | DontListIgnored + +-- | Which types of build tree refs should be listed? +data RefTypesToList = OnlySnapshots | OnlyLinks | LinksAndSnapshots + +-- | List the local build trees that are referred to from the index. +listBuildTreeRefs :: Verbosity -> ListIgnoredBuildTreeRefs -> RefTypesToList + -> FilePath + -> IO [FilePath] +listBuildTreeRefs verbosity listIgnored refTypesToList path = do + checkIndexExists path + buildTreeRefs <- + case listIgnored of + DontListIgnored -> do + paths <- listWithoutIgnored + case refTypesToList of + LinksAndSnapshots -> return paths + _ -> do + allPathsFiltered <- fmap (map buildTreePath . filter predicate) + listWithIgnored + _ <- evaluate (length allPathsFiltered) + return (paths `intersect` allPathsFiltered) + + ListIgnored -> fmap (map buildTreePath . filter predicate) listWithIgnored + + _ <- evaluate (length buildTreeRefs) + return buildTreeRefs + + where + predicate :: BuildTreeRef -> Bool + predicate = case refTypesToList of + OnlySnapshots -> (==) SnapshotRef . buildTreeRefType + OnlyLinks -> (==) LinkRef . buildTreeRefType + LinksAndSnapshots -> const True + + listWithIgnored :: IO [BuildTreeRef] + listWithIgnored = readBuildTreeRefsFromFile $ path + + listWithoutIgnored :: IO [FilePath] + listWithoutIgnored = do + let repo = Repo { repoKind = Right LocalRepo + , repoLocalDir = takeDirectory path } + pkgIndex <- fmap packageIndex + . getSourcePackagesStrict verbosity $ [repo] + return [ pkgPath | (LocalUnpackedPackage pkgPath) <- + map packageSource . allPackages $ pkgIndex ] + + +-- | Check that the package index file exists and exit with error if it does not. +checkIndexExists :: FilePath -> IO () +checkIndexExists path = do + indexExists <- doesFileExist path + unless indexExists $ + die $ "index does not exist: '" ++ path ++ "'" diff --git a/Distribution/Client/Sandbox/PackageEnvironment.hs b/Distribution/Client/Sandbox/PackageEnvironment.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Sandbox/PackageEnvironment.hs @@ -0,0 +1,497 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Sandbox.PackageEnvironment +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Utilities for working with the package environment file. Patterned after +-- Distribution.Client.Config. +----------------------------------------------------------------------------- + +module Distribution.Client.Sandbox.PackageEnvironment ( + PackageEnvironment(..) + , IncludeComments(..) + , PackageEnvironmentType(..) + , classifyPackageEnvironment + , createPackageEnvironmentFile + , tryLoadSandboxPackageEnvironmentFile + , readPackageEnvironmentFile + , showPackageEnvironment + , showPackageEnvironmentWithComments + , setPackageDB + , loadUserConfig + + , basePackageEnvironment + , initialPackageEnvironment + , commentPackageEnvironment + , sandboxPackageEnvironmentFile + , userPackageEnvironmentFile + ) where + +import Distribution.Client.Config ( SavedConfig(..), commentSavedConfig, + loadConfig, configFieldDescriptions, + installDirsFields, defaultCompiler ) +import Distribution.Client.ParseUtils ( parseFields, ppFields, ppSection ) +import Distribution.Client.Setup ( GlobalFlags(..), ConfigExFlags(..) + , InstallFlags(..) + , defaultSandboxLocation ) +import Distribution.Simple.Compiler ( Compiler, PackageDB(..) + , compilerFlavor, showCompilerId ) +import Distribution.Simple.InstallDirs ( InstallDirs(..), PathTemplate + , defaultInstallDirs, combineInstallDirs + , fromPathTemplate, toPathTemplate ) +import Distribution.Simple.Setup ( Flag(..), ConfigFlags(..), + fromFlagOrDefault, toFlag ) +import Distribution.Simple.Utils ( die, info, notice, warn, lowercase ) +import Distribution.ParseUtils ( FieldDescr(..), ParseResult(..), + commaListField, + liftField, lineNo, locatedErrorMsg, + parseFilePathQ, readFields, + showPWarning, simpleField, syntaxError ) +import Distribution.System ( Platform ) +import Distribution.Verbosity ( Verbosity, normal ) +import Control.Monad ( foldM, when, unless ) +import Data.List ( partition ) +import Data.Monoid ( Monoid(..) ) +import Distribution.Compat.Exception ( catchIO ) +import System.Directory ( doesDirectoryExist, doesFileExist, + renameFile ) +import System.FilePath ( (<.>), (), takeDirectory ) +import System.IO.Error ( isDoesNotExistError ) +import Text.PrettyPrint ( ($+$) ) + +import qualified Text.PrettyPrint as Disp +import qualified Distribution.Compat.ReadP as Parse +import qualified Distribution.ParseUtils as ParseUtils ( Field(..) ) +import qualified Distribution.Text as Text + + +-- +-- * Configuration saved in the package environment file +-- + +-- TODO: would be nice to remove duplication between +-- D.C.Sandbox.PackageEnvironment and D.C.Config. +data PackageEnvironment = PackageEnvironment { + -- The 'inherit' feature is not used ATM, but could be useful in the future + -- for constructing nested sandboxes (see discussion in #1196). + pkgEnvInherit :: Flag FilePath, + pkgEnvSavedConfig :: SavedConfig +} + +instance Monoid PackageEnvironment where + mempty = PackageEnvironment { + pkgEnvInherit = mempty, + pkgEnvSavedConfig = mempty + } + + mappend a b = PackageEnvironment { + pkgEnvInherit = combine pkgEnvInherit, + pkgEnvSavedConfig = combine pkgEnvSavedConfig + } + where + combine f = f a `mappend` f b + +-- | The automatically-created package environment file that should not be +-- touched by the user. +sandboxPackageEnvironmentFile :: FilePath +sandboxPackageEnvironmentFile = "cabal.sandbox.config" + +-- | Optional package environment file that can be used to customize the default +-- settings. Created by the user. +userPackageEnvironmentFile :: FilePath +userPackageEnvironmentFile = "cabal.config" + +-- | Type of the current package environment. +data PackageEnvironmentType = + SandboxPackageEnvironment -- ^ './cabal.sandbox.config' + | UserPackageEnvironment -- ^ './cabal.config' + | AmbientPackageEnvironment -- ^ '~/.cabal/config' + +-- | Is there a 'cabal.sandbox.config' or 'cabal.config' in this +-- directory? +classifyPackageEnvironment :: FilePath -> IO PackageEnvironmentType +classifyPackageEnvironment pkgEnvDir = do + isSandbox <- configExists sandboxPackageEnvironmentFile + isUser <- configExists userPackageEnvironmentFile + case (isSandbox, isUser) of + (True, _) -> return SandboxPackageEnvironment + (False, True) -> return UserPackageEnvironment + (False, False) -> return AmbientPackageEnvironment + where + configExists fname = doesFileExist (pkgEnvDir fname) + +-- | Defaults common to 'initialPackageEnvironment' and +-- 'commentPackageEnvironment'. +commonPackageEnvironmentConfig :: FilePath -> SavedConfig +commonPackageEnvironmentConfig sandboxDir = + mempty { + savedConfigureFlags = mempty { + -- TODO: Currently, we follow cabal-dev and set 'user-install: False' in + -- the config file. In the future we may want to distinguish between + -- global, sandbox and user install types. + configUserInstall = toFlag False, + configInstallDirs = installDirs + }, + savedUserInstallDirs = installDirs, + savedGlobalInstallDirs = installDirs, + savedGlobalFlags = mempty { + globalLogsDir = toFlag $ sandboxDir "logs", + -- Is this right? cabal-dev uses the global world file. + globalWorldFile = toFlag $ sandboxDir "world" + } + } + where + installDirs = sandboxInstallDirs sandboxDir + +-- | 'commonPackageEnvironmentConfig' wrapped inside a 'PackageEnvironment'. +commonPackageEnvironment :: FilePath -> PackageEnvironment +commonPackageEnvironment sandboxDir = mempty { + pkgEnvSavedConfig = commonPackageEnvironmentConfig sandboxDir + } + +-- | Given a path to a sandbox, return the corresponding InstallDirs record. +sandboxInstallDirs :: FilePath -> InstallDirs (Flag PathTemplate) +sandboxInstallDirs sandboxDir = mempty { + prefix = toFlag (toPathTemplate sandboxDir) + } + +-- | These are the absolute basic defaults, the fields that must be +-- initialised. When we load the package environment from the file we layer the +-- loaded values over these ones. +basePackageEnvironment :: PackageEnvironment +basePackageEnvironment = + mempty { + pkgEnvSavedConfig = mempty { + savedConfigureFlags = mempty { + configHcFlavor = toFlag defaultCompiler, + configVerbosity = toFlag normal + } + } + } + +-- | Initial configuration that we write out to the package environment file if +-- it does not exist. When the package environment gets loaded this +-- configuration gets layered on top of 'basePackageEnvironment'. +initialPackageEnvironment :: FilePath -> Compiler -> Platform + -> IO PackageEnvironment +initialPackageEnvironment sandboxDir compiler platform = do + defInstallDirs <- defaultInstallDirs (compilerFlavor compiler) + {- userInstall= -} False {- _hasLibs= -} False + let initialConfig = commonPackageEnvironmentConfig sandboxDir + installDirs = combineInstallDirs (\d f -> Flag $ fromFlagOrDefault d f) + defInstallDirs (savedUserInstallDirs initialConfig) + return $ mempty { + pkgEnvSavedConfig = initialConfig { + savedUserInstallDirs = installDirs, + savedGlobalInstallDirs = installDirs, + savedGlobalFlags = (savedGlobalFlags initialConfig) { + globalLocalRepos = [sandboxDir "packages"] + }, + savedConfigureFlags = setPackageDB sandboxDir compiler platform + (savedConfigureFlags initialConfig), + savedInstallFlags = (savedInstallFlags initialConfig) { + installSummaryFile = [toPathTemplate (sandboxDir + "logs" "build.log")] + } + } + } + +-- | Use the package DB location specific for this compiler. +setPackageDB :: FilePath -> Compiler -> Platform -> ConfigFlags -> ConfigFlags +setPackageDB sandboxDir compiler platform configFlags = + configFlags { + configPackageDBs = [Just (SpecificPackageDB $ sandboxDir + (Text.display platform ++ "-" + ++ showCompilerId compiler + ++ "-packages.conf.d"))] + } + +-- | Almost the same as 'savedConf `mappend` pkgEnv', but some settings are +-- overridden instead of mappend'ed. +overrideSandboxSettings :: PackageEnvironment -> PackageEnvironment -> + PackageEnvironment +overrideSandboxSettings pkgEnv0 pkgEnv = + pkgEnv { + pkgEnvSavedConfig = mappendedConf { + savedConfigureFlags = (savedConfigureFlags mappendedConf) { + configPackageDBs = configPackageDBs pkgEnvConfigureFlags + } + , savedInstallFlags = (savedInstallFlags mappendedConf) { + installSummaryFile = installSummaryFile pkgEnvInstallFlags + } + }, + pkgEnvInherit = pkgEnvInherit pkgEnv0 + } + where + pkgEnvConf = pkgEnvSavedConfig pkgEnv + mappendedConf = (pkgEnvSavedConfig pkgEnv0) `mappend` pkgEnvConf + pkgEnvConfigureFlags = savedConfigureFlags pkgEnvConf + pkgEnvInstallFlags = savedInstallFlags pkgEnvConf + +-- | Default values that get used if no value is given. Used here to include in +-- comments when we write out the initial package environment. +commentPackageEnvironment :: FilePath -> IO PackageEnvironment +commentPackageEnvironment sandboxDir = do + commentConf <- commentSavedConfig + let baseConf = commonPackageEnvironmentConfig sandboxDir + return $ mempty { + pkgEnvSavedConfig = commentConf `mappend` baseConf + } + +-- | If this package environment inherits from some other package environment, +-- return that package environment; otherwise return mempty. +inheritedPackageEnvironment :: Verbosity -> PackageEnvironment + -> IO PackageEnvironment +inheritedPackageEnvironment verbosity pkgEnv = do + case (pkgEnvInherit pkgEnv) of + NoFlag -> return mempty + confPathFlag@(Flag _) -> do + conf <- loadConfig verbosity confPathFlag NoFlag + return $ mempty { pkgEnvSavedConfig = conf } + +-- | Load the user package environment if it exists (the optional "cabal.config" +-- file). +userPackageEnvironment :: Verbosity -> FilePath -> IO PackageEnvironment +userPackageEnvironment verbosity pkgEnvDir = do + let path = pkgEnvDir userPackageEnvironmentFile + minp <- readPackageEnvironmentFile mempty path + case minp of + Nothing -> return mempty + Just (ParseOk warns parseResult) -> do + when (not $ null warns) $ warn verbosity $ + unlines (map (showPWarning path) warns) + return parseResult + Just (ParseFailed err) -> do + let (line, msg) = locatedErrorMsg err + warn verbosity $ "Error parsing user package environment file " ++ path + ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg + return mempty + +-- | Same as @userPackageEnvironmentFile@, but returns a SavedConfig. +loadUserConfig :: Verbosity -> FilePath -> IO SavedConfig +loadUserConfig verbosity pkgEnvDir = fmap pkgEnvSavedConfig + $ userPackageEnvironment verbosity pkgEnvDir + +-- | Common error handling code used by 'tryLoadSandboxPackageEnvironment' and +-- 'updatePackageEnvironment'. +handleParseResult :: Verbosity -> FilePath + -> Maybe (ParseResult PackageEnvironment) + -> IO PackageEnvironment +handleParseResult verbosity path minp = + case minp of + Nothing -> die $ + "The package environment file '" ++ path ++ "' doesn't exist" + Just (ParseOk warns parseResult) -> do + when (not $ null warns) $ warn verbosity $ + unlines (map (showPWarning path) warns) + return parseResult + Just (ParseFailed err) -> do + let (line, msg) = locatedErrorMsg err + die $ "Error parsing package environment file " ++ path + ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg + +-- | Try to load the given package environment file, exiting with error if it +-- doesn't exist. Also returns the path to the sandbox directory. The path +-- parameter should refer to an existing file. +tryLoadSandboxPackageEnvironmentFile :: Verbosity -> FilePath -> (Flag FilePath) + -> IO (FilePath, PackageEnvironment) +tryLoadSandboxPackageEnvironmentFile verbosity pkgEnvFile configFileFlag = do + let pkgEnvDir = takeDirectory pkgEnvFile + minp <- readPackageEnvironmentFile mempty pkgEnvFile + pkgEnv <- handleParseResult verbosity pkgEnvFile minp + + -- Get the saved sandbox directory. + -- TODO: Use substPathTemplate with compilerTemplateEnv ++ platformTemplateEnv. + let sandboxDir = fromFlagOrDefault defaultSandboxLocation + . fmap fromPathTemplate . prefix . savedUserInstallDirs + . pkgEnvSavedConfig $ pkgEnv + + -- Do some sanity checks + dirExists <- doesDirectoryExist sandboxDir + -- TODO: Also check for an initialised package DB? + unless dirExists $ + die ("No sandbox exists at " ++ sandboxDir) + info verbosity $ "Using a sandbox located at " ++ sandboxDir + + let base = basePackageEnvironment + let common = commonPackageEnvironment sandboxDir + user <- userPackageEnvironment verbosity pkgEnvDir + inherited <- inheritedPackageEnvironment verbosity user + + -- Layer the package environment settings over settings from ~/.cabal/config. + cabalConfig <- loadConfig verbosity configFileFlag NoFlag + return (sandboxDir, + updateInstallDirs $ + (base `mappend` (toPkgEnv cabalConfig) `mappend` + common `mappend` inherited `mappend` user) + `overrideSandboxSettings` pkgEnv) + where + toPkgEnv config = mempty { pkgEnvSavedConfig = config } + + updateInstallDirs pkgEnv = + let config = pkgEnvSavedConfig pkgEnv + configureFlags = savedConfigureFlags config + installDirs = savedUserInstallDirs config + in pkgEnv { + pkgEnvSavedConfig = config { + savedConfigureFlags = configureFlags { + configInstallDirs = installDirs + } + } + } + +-- | Should the generated package environment file include comments? +data IncludeComments = IncludeComments | NoComments + +-- | Create a new package environment file, replacing the existing one if it +-- exists. Note that the path parameters should point to existing directories. +createPackageEnvironmentFile :: Verbosity -> FilePath -> FilePath + -> IncludeComments + -> Compiler + -> Platform + -> IO () +createPackageEnvironmentFile verbosity sandboxDir pkgEnvFile incComments + compiler platform = do + notice verbosity $ "Writing a default package environment file to " + ++ pkgEnvFile + + commentPkgEnv <- commentPackageEnvironment sandboxDir + initialPkgEnv <- initialPackageEnvironment sandboxDir compiler platform + writePackageEnvironmentFile pkgEnvFile incComments commentPkgEnv initialPkgEnv + +-- | Descriptions of all fields in the package environment file. +pkgEnvFieldDescrs :: [FieldDescr PackageEnvironment] +pkgEnvFieldDescrs = [ + simpleField "inherit" + (fromFlagOrDefault Disp.empty . fmap Disp.text) (optional parseFilePathQ) + pkgEnvInherit (\v pkgEnv -> pkgEnv { pkgEnvInherit = v }) + + -- FIXME: Should we make these fields part of ~/.cabal/config ? + , commaListField "constraints" + Text.disp Text.parse + (configExConstraints . savedConfigureExFlags . pkgEnvSavedConfig) + (\v pkgEnv -> updateConfigureExFlags pkgEnv + (\flags -> flags { configExConstraints = v })) + + , commaListField "preferences" + Text.disp Text.parse + (configPreferences . savedConfigureExFlags . pkgEnvSavedConfig) + (\v pkgEnv -> updateConfigureExFlags pkgEnv + (\flags -> flags { configPreferences = v })) + ] + ++ map toPkgEnv configFieldDescriptions' + where + optional = Parse.option mempty . fmap toFlag + + configFieldDescriptions' :: [FieldDescr SavedConfig] + configFieldDescriptions' = filter + (\(FieldDescr name _ _) -> name /= "preference" && name /= "constraint") + configFieldDescriptions + + toPkgEnv :: FieldDescr SavedConfig -> FieldDescr PackageEnvironment + toPkgEnv fieldDescr = + liftField pkgEnvSavedConfig + (\savedConfig pkgEnv -> pkgEnv { pkgEnvSavedConfig = savedConfig}) + fieldDescr + + updateConfigureExFlags :: PackageEnvironment + -> (ConfigExFlags -> ConfigExFlags) + -> PackageEnvironment + updateConfigureExFlags pkgEnv f = pkgEnv { + pkgEnvSavedConfig = (pkgEnvSavedConfig pkgEnv) { + savedConfigureExFlags = f . savedConfigureExFlags . pkgEnvSavedConfig + $ pkgEnv + } + } + +-- | Read the package environment file. +readPackageEnvironmentFile :: PackageEnvironment -> FilePath + -> IO (Maybe (ParseResult PackageEnvironment)) +readPackageEnvironmentFile initial file = + handleNotExists $ + fmap (Just . parsePackageEnvironment initial) (readFile file) + where + handleNotExists action = catchIO action $ \ioe -> + if isDoesNotExistError ioe + then return Nothing + else ioError ioe + +-- | Parse the package environment file. +parsePackageEnvironment :: PackageEnvironment -> String + -> ParseResult PackageEnvironment +parsePackageEnvironment initial str = do + fields <- readFields str + let (knownSections, others) = partition isKnownSection fields + pkgEnv <- parse others + let config = pkgEnvSavedConfig pkgEnv + installDirs0 = savedUserInstallDirs config + -- 'install-dirs' is the only section that we care about. + installDirs <- foldM parseSection installDirs0 knownSections + return pkgEnv { + pkgEnvSavedConfig = config { + savedUserInstallDirs = installDirs, + savedGlobalInstallDirs = installDirs + } + } + + where + isKnownSection :: ParseUtils.Field -> Bool + isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True + isKnownSection _ = False + + parse :: [ParseUtils.Field] -> ParseResult PackageEnvironment + parse = parseFields pkgEnvFieldDescrs initial + + parseSection :: InstallDirs (Flag PathTemplate) + -> ParseUtils.Field + -> ParseResult (InstallDirs (Flag PathTemplate)) + parseSection accum (ParseUtils.Section line "install-dirs" name fs) + | name' == "" = do accum' <- parseFields installDirsFields accum fs + return accum' + | otherwise = + syntaxError line $ + "Named 'install-dirs' section: '" ++ name + ++ "'. Note that named 'install-dirs' sections are not allowed in the '" + ++ userPackageEnvironmentFile ++ "' file." + where name' = lowercase name + parseSection _accum f = + syntaxError (lineNo f) "Unrecognized stanza." + +-- | Write out the package environment file. +writePackageEnvironmentFile :: FilePath -> IncludeComments + -> PackageEnvironment -> PackageEnvironment + -> IO () +writePackageEnvironmentFile path incComments comments pkgEnv = do + let tmpPath = (path <.> "tmp") + writeFile tmpPath $ explanation ++ pkgEnvStr ++ "\n" + renameFile tmpPath path + where + pkgEnvStr = case incComments of + IncludeComments -> showPackageEnvironmentWithComments + (Just comments) pkgEnv + NoComments -> showPackageEnvironment pkgEnv + explanation = unlines + ["-- This is a Cabal package environment file." + ,"-- THIS FILE IS AUTO-GENERATED. DO NOT EDIT DIRECTLY." + ,"-- Please create a 'cabal.config' file in the same directory" + ,"-- if you want to change the default settings for this sandbox." + ,"","" + ] + +-- | Pretty-print the package environment. +showPackageEnvironment :: PackageEnvironment -> String +showPackageEnvironment pkgEnv = showPackageEnvironmentWithComments Nothing pkgEnv + +-- | Pretty-print the package environment with default values for empty fields +-- commented out (just like the default ~/.cabal/config). +showPackageEnvironmentWithComments :: (Maybe PackageEnvironment) + -> PackageEnvironment + -> String +showPackageEnvironmentWithComments mdefPkgEnv pkgEnv = Disp.render $ + ppFields pkgEnvFieldDescrs mdefPkgEnv pkgEnv + $+$ Disp.text "" + $+$ ppSection "install-dirs" "" installDirsFields + (fmap installDirsSection mdefPkgEnv) (installDirsSection pkgEnv) + where + installDirsSection = savedUserInstallDirs . pkgEnvSavedConfig diff --git a/Distribution/Client/Sandbox/Timestamp.hs b/Distribution/Client/Sandbox/Timestamp.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Sandbox/Timestamp.hs @@ -0,0 +1,288 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Sandbox.Timestamp +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Timestamp file handling (for add-source dependencies). +----------------------------------------------------------------------------- + +module Distribution.Client.Sandbox.Timestamp ( + AddSourceTimestamp, + withAddTimestamps, + withRemoveTimestamps, + withUpdateTimestamps, + maybeAddCompilerTimestampRecord, + isDepModified, + listModifiedDeps, + ) where + +import Control.Monad (filterM, forM, when) +import Data.Char (isSpace) +import Data.List (partition) +import System.Directory (renameFile) +import System.FilePath ((<.>), ()) +import qualified Data.Map as M + +import Distribution.Compiler (CompilerId) +import Distribution.Package (packageName) +import Distribution.PackageDescription.Configuration (flattenPackageDescription) +import Distribution.PackageDescription.Parse (readPackageDescription) +import Distribution.Simple.Setup (Flag (..), + SDistFlags (..), + defaultSDistFlags, + sdistCommand) +import Distribution.Simple.Utils (debug, die, + findPackageDesc, warn) +import Distribution.System (Platform) +import Distribution.Text (display) +import Distribution.Verbosity (Verbosity, lessVerbose, + normal) +import Distribution.Version (Version (..), + orLaterVersion) + +import Distribution.Client.Sandbox.Index + (ListIgnoredBuildTreeRefs (DontListIgnored), RefTypesToList(OnlyLinks) + ,listBuildTreeRefs) +import Distribution.Client.SetupWrapper (SetupScriptOptions (..), + defaultSetupScriptOptions, + setupWrapper) +import Distribution.Client.Utils (inDir, removeExistingFile, + tryCanonicalizePath) + +import Distribution.Compat.Exception (catchIO) +import Distribution.Client.Compat.Time (EpochTime, getCurTime, + getModTime) + + +-- | Timestamp of an add-source dependency. +type AddSourceTimestamp = (FilePath, EpochTime) +-- | Timestamp file record - a string identifying the compiler & platform plus a +-- list of add-source timestamps. +type TimestampFileRecord = (String, [AddSourceTimestamp]) + +timestampRecordKey :: CompilerId -> Platform -> String +timestampRecordKey compId platform = display platform ++ "-" ++ display compId + +-- | The 'add-source-timestamps' file keeps the timestamps of all add-source +-- dependencies. It is initially populated by 'sandbox add-source' and kept +-- current by 'reinstallAddSourceDeps' and 'configure -w'. The user can install +-- add-source deps manually with 'cabal install' after having edited them, so we +-- can err on the side of caution sometimes. +-- FIXME: We should keep this info in the index file, together with build tree +-- refs. +timestampFileName :: FilePath +timestampFileName = "add-source-timestamps" + +-- | Read the timestamp file. Exits with error if the timestamp file is +-- corrupted. Returns an empty list if the file doesn't exist. +readTimestampFile :: FilePath -> IO [TimestampFileRecord] +readTimestampFile timestampFile = do + timestampString <- readFile timestampFile `catchIO` \_ -> return "[]" + case reads timestampString of + [(timestamps, s)] | all isSpace s -> return timestamps + _ -> + die $ "The timestamps file is corrupted. " + ++ "Please delete & recreate the sandbox." + +-- | Write the timestamp file, atomically. +writeTimestampFile :: FilePath -> [TimestampFileRecord] -> IO () +writeTimestampFile timestampFile timestamps = do + writeFile timestampTmpFile (show timestamps) + renameFile timestampTmpFile timestampFile + where + timestampTmpFile = timestampFile <.> "tmp" + +-- | Read, process and write the timestamp file in one go. +withTimestampFile :: FilePath + -> ([TimestampFileRecord] -> IO [TimestampFileRecord]) + -> IO () +withTimestampFile sandboxDir process = do + let timestampFile = sandboxDir timestampFileName + timestampRecords <- readTimestampFile timestampFile >>= process + writeTimestampFile timestampFile timestampRecords + +-- | Given a list of 'AddSourceTimestamp's, a list of paths to add-source deps +-- we've added and an initial timestamp, add an 'AddSourceTimestamp' to the list +-- for each path. If a timestamp for a given path already exists in the list, +-- update it. +addTimestamps :: EpochTime -> [AddSourceTimestamp] -> [FilePath] + -> [AddSourceTimestamp] +addTimestamps initial timestamps newPaths = + [ (p, initial) | p <- newPaths ] ++ oldTimestamps + where + (oldTimestamps, _toBeUpdated) = + partition (\(path, _) -> path `notElem` newPaths) timestamps + +-- | Given a list of 'AddSourceTimestamp's, a list of paths to add-source deps +-- we've reinstalled and a new timestamp value, update the timestamp value for +-- the deps in the list. If there are new paths in the list, ignore them. +updateTimestamps :: [AddSourceTimestamp] -> [FilePath] -> EpochTime + -> [AddSourceTimestamp] +updateTimestamps timestamps pathsToUpdate newTimestamp = + foldr updateTimestamp [] timestamps + where + updateTimestamp t@(path, _oldTimestamp) rest + | path `elem` pathsToUpdate = (path, newTimestamp) : rest + | otherwise = t : rest + +-- | Given a list of 'TimestampFileRecord's and a list of paths to add-source +-- deps we've removed, remove those deps from the list. +removeTimestamps :: [AddSourceTimestamp] -> [FilePath] -> [AddSourceTimestamp] +removeTimestamps l pathsToRemove = foldr removeTimestamp [] l + where + removeTimestamp t@(path, _oldTimestamp) rest = + if path `elem` pathsToRemove + then rest + else t : rest + +-- | If a timestamp record for this compiler doesn't exist, add a new one. +maybeAddCompilerTimestampRecord :: Verbosity -> FilePath -> FilePath + -> CompilerId -> Platform + -> IO () +maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile + compId platform = do + buildTreeRefs <- listBuildTreeRefs verbosity DontListIgnored OnlyLinks + indexFile + withTimestampFile sandboxDir $ \timestampRecords -> do + let key = timestampRecordKey compId platform + case lookup key timestampRecords of + Just _ -> return timestampRecords + Nothing -> do now <- getCurTime + let timestamps = map (\p -> (p, now)) buildTreeRefs + return $ (key, timestamps):timestampRecords + +-- | Given an IO action that returns a list of build tree refs, add those +-- build tree refs to the timestamps file (for all compilers). +withAddTimestamps :: FilePath -> IO [FilePath] -> IO () +withAddTimestamps sandboxDir act = do + let initialTimestamp = 0 + withActionOnAllTimestamps (addTimestamps initialTimestamp) sandboxDir act + +-- | Given an IO action that returns a list of build tree refs, remove those +-- build tree refs from the timestamps file (for all compilers). +withRemoveTimestamps :: FilePath -> IO [FilePath] -> IO () +withRemoveTimestamps = withActionOnAllTimestamps removeTimestamps + +-- | Given an IO action that returns a list of build tree refs, update the +-- timestamps of the returned build tree refs to the current time (only for the +-- given compiler & platform). +withUpdateTimestamps :: FilePath -> CompilerId -> Platform + ->([AddSourceTimestamp] -> IO [FilePath]) + -> IO () +withUpdateTimestamps = + withActionOnCompilerTimestamps updateTimestamps + +-- | Helper for implementing 'withAddTimestamps' and +-- 'withRemoveTimestamps'. Runs a given action on the list of +-- 'AddSourceTimestamp's for all compilers, applies 'f' to the result and then +-- updates the timestamp file. The IO action is run only once. +withActionOnAllTimestamps :: ([AddSourceTimestamp] -> [FilePath] + -> [AddSourceTimestamp]) + -> FilePath + -> IO [FilePath] + -> IO () +withActionOnAllTimestamps f sandboxDir act = + withTimestampFile sandboxDir $ \timestampRecords -> do + paths <- act + return [(key, f timestamps paths) | (key, timestamps) <- timestampRecords] + +-- | Helper for implementing 'withUpdateTimestamps'. Runs a given action on the +-- list of 'AddSourceTimestamp's for this compiler, applies 'f' to the result +-- and then updates the timestamp file record. The IO action is run only once. +withActionOnCompilerTimestamps :: ([AddSourceTimestamp] + -> [FilePath] -> EpochTime + -> [AddSourceTimestamp]) + -> FilePath + -> CompilerId + -> Platform + -> ([AddSourceTimestamp] -> IO [FilePath]) + -> IO () +withActionOnCompilerTimestamps f sandboxDir compId platform act = do + let needle = timestampRecordKey compId platform + withTimestampFile sandboxDir $ \timestampRecords -> do + timestampRecords' <- forM timestampRecords $ \r@(key, timestamps) -> + if key == needle + then do paths <- act timestamps + now <- getCurTime + return (key, f timestamps paths now) + else return r + return timestampRecords' + +-- | List all source files of a given add-source dependency. Exits with error if +-- something is wrong (e.g. there is no .cabal file in the given directory). +-- FIXME: This function is not thread-safe because of 'inDir'. +allPackageSourceFiles :: Verbosity -> FilePath -> IO [FilePath] +allPackageSourceFiles verbosity packageDir = inDir (Just packageDir) $ do + pkg <- fmap (flattenPackageDescription) + . readPackageDescription verbosity =<< findPackageDesc packageDir + + let file = "cabal-sdist-list-sources" + flags = defaultSDistFlags { + sDistVerbosity = Flag $ if verbosity == normal + then lessVerbose verbosity else verbosity, + sDistListSources = Flag file + } + setupOpts = defaultSetupScriptOptions { + -- 'sdist --list-sources' was introduced in Cabal 1.18. + useCabalVersion = orLaterVersion $ Version [1,18,0] [] + } + + doListSources :: IO [FilePath] + doListSources = do + setupWrapper verbosity setupOpts (Just pkg) sdistCommand (const flags) [] + srcs <- fmap lines . readFile $ file + mapM tryCanonicalizePath srcs + + onFailedListSources :: IO () + onFailedListSources = warn verbosity $ + "Could not list sources of the add-source dependency '" + ++ display (packageName pkg) ++ "'. Skipping the timestamp check." + + -- Run setup sdist --list-sources=TMPFILE + ret <- doListSources `catchIO` (\_ -> onFailedListSources >> return []) + removeExistingFile file + return ret + +-- | Has this dependency been modified since we have last looked at it? +isDepModified :: Verbosity -> EpochTime -> AddSourceTimestamp -> IO Bool +isDepModified verbosity now (packageDir, timestamp) = do + debug verbosity ("Checking whether the dependency is modified: " ++ packageDir) + depSources <- allPackageSourceFiles verbosity packageDir + go depSources + + where + go [] = return False + go (dep:rest) = do + -- FIXME: What if the clock jumps backwards at any point? For now we only + -- print a warning. + modTime <- getModTime dep + when (modTime > now) $ + warn verbosity $ "File '" ++ dep + ++ "' has a modification time that is in the future." + if modTime >= timestamp + then do + debug verbosity ("Dependency has a modified source file: " ++ dep) + return True + else go rest + +-- | List all modified dependencies. +listModifiedDeps :: Verbosity -> FilePath -> CompilerId -> Platform + -> M.Map FilePath a + -- ^ The set of all installed add-source deps. + -> IO [FilePath] +listModifiedDeps verbosity sandboxDir compId platform installedDepsMap = do + timestampRecords <- readTimestampFile (sandboxDir timestampFileName) + let needle = timestampRecordKey compId platform + timestamps <- maybe noTimestampRecord return + (lookup needle timestampRecords) + now <- getCurTime + fmap (map fst) . filterM (isDepModified verbosity now) + . filter (\ts -> fst ts `M.member` installedDepsMap) + $ timestamps + + where + noTimestampRecord = die $ "Сouldn't find a timestamp record for the given " + ++ "compiler/platform pair. " + ++ "Please report this on the Cabal bug tracker: " + ++ "https://github.com/haskell/cabal/issues/new ." diff --git a/Distribution/Client/Sandbox/Types.hs b/Distribution/Client/Sandbox/Types.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Sandbox/Types.hs @@ -0,0 +1,61 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Sandbox.Types +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Helpers for writing code that works both inside and outside a sandbox. +----------------------------------------------------------------------------- + +module Distribution.Client.Sandbox.Types ( + UseSandbox(..), isUseSandbox, whenUsingSandbox, + SandboxPackageInfo(..) + ) where + +import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex +import Distribution.Client.Types (SourcePackage) + +import Data.Monoid +import qualified Data.Set as S + +-- | Are we using a sandbox? +data UseSandbox = UseSandbox FilePath | NoSandbox + +instance Monoid UseSandbox where + mempty = NoSandbox + + NoSandbox `mappend` s = s + u0@(UseSandbox _) `mappend` NoSandbox = u0 + (UseSandbox _) `mappend` u1@(UseSandbox _) = u1 + +-- | Convert a @UseSandbox@ value to a boolean. Useful in conjunction with +-- @when@. +isUseSandbox :: UseSandbox -> Bool +isUseSandbox (UseSandbox _) = True +isUseSandbox NoSandbox = False + +-- | Execute an action only if we're in a sandbox, feeding to it the path to the +-- sandbox directory. +whenUsingSandbox :: UseSandbox -> (FilePath -> IO ()) -> IO () +whenUsingSandbox NoSandbox _ = return () +whenUsingSandbox (UseSandbox sandboxDir) act = act sandboxDir + +-- | Data about the packages installed in the sandbox that is passed from +-- 'reinstallAddSourceDeps' to the solver. +data SandboxPackageInfo = SandboxPackageInfo { + modifiedAddSourceDependencies :: ![SourcePackage], + -- ^ Modified add-source deps that we want to reinstall. These are guaranteed + -- to be already installed in the sandbox. + + otherAddSourceDependencies :: ![SourcePackage], + -- ^ Remaining add-source deps. Some of these may be not installed in the + -- sandbox. + + otherInstalledSandboxPackages :: !InstalledPackageIndex.PackageIndex, + -- ^ All packages installed in the sandbox. Intersection with + -- 'modifiedAddSourceDependencies' and/or 'otherAddSourceDependencies' can be + -- non-empty. + + allAddSourceDependencies :: !(S.Set FilePath) + -- ^ A set of paths to all add-source dependencies, for convenience. + } diff --git a/Distribution/Client/Setup.hs b/Distribution/Client/Setup.hs --- a/Distribution/Client/Setup.hs +++ b/Distribution/Client/Setup.hs @@ -15,18 +15,23 @@ , configureCommand, ConfigFlags(..), filterConfigureFlags , configureExCommand, ConfigExFlags(..), defaultConfigExFlags , configureExOptions + , buildCommand, BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..) + , testCommand, benchmarkCommand , installCommand, InstallFlags(..), installOptions, defaultInstallFlags , listCommand, ListFlags(..) , updateCommand , upgradeCommand , infoCommand, InfoFlags(..) , fetchCommand, FetchFlags(..) + , getCommand, unpackCommand, GetFlags(..) , checkCommand , uploadCommand, UploadFlags(..) , reportCommand, ReportFlags(..) - , unpackCommand, UnpackFlags(..) + , runCommand , initCommand, IT.InitFlags(..) , sdistCommand, SDistFlags(..), SDistExFlags(..), ArchiveFormat(..) + , win32SelfUpgradeCommand, Win32SelfUpgradeFlags(..) + , sandboxCommand, defaultSandboxLocation, SandboxFlags(..) , parsePackageArgs --TODO: stop exporting these: @@ -49,18 +54,20 @@ ( defaultProgramConfiguration ) import Distribution.Simple.Command hiding (boolOpt) import qualified Distribution.Simple.Setup as Cabal - ( configureCommand, sdistCommand, haddockCommand ) import Distribution.Simple.Setup - ( ConfigFlags(..), SDistFlags(..), HaddockFlags(..) ) -import Distribution.Simple.Setup - ( Flag(..), toFlag, fromFlag, flagToMaybe, flagToList + ( ConfigFlags(..), BuildFlags(..), TestFlags(..), BenchmarkFlags(..) + , SDistFlags(..), HaddockFlags(..) + , Flag(..), toFlag, fromFlag, flagToMaybe, flagToList , optionVerbosity, boolOpt, trueArg, falseArg ) import Distribution.Simple.InstallDirs - ( PathTemplate, toPathTemplate, fromPathTemplate ) + ( PathTemplate, InstallDirs(sysconfdir) + , toPathTemplate, fromPathTemplate ) import Distribution.Version ( Version(Version), anyVersion, thisVersion ) import Distribution.Package ( PackageIdentifier, packageName, packageVersion, Dependency(..) ) +import Distribution.PackageDescription + ( RepoKind(..) ) import Distribution.Text ( Text(..), display ) import Distribution.ReadE @@ -93,26 +100,28 @@ -- | Flags that apply at the top level, not to any sub-command. data GlobalFlags = GlobalFlags { - globalVersion :: Flag Bool, - globalNumericVersion :: Flag Bool, - globalConfigFile :: Flag FilePath, - globalRemoteRepos :: [RemoteRepo], -- ^ Available Hackage servers. - globalCacheDir :: Flag FilePath, - globalLocalRepos :: [FilePath], - globalLogsDir :: Flag FilePath, - globalWorldFile :: Flag FilePath + globalVersion :: Flag Bool, + globalNumericVersion :: Flag Bool, + globalConfigFile :: Flag FilePath, + globalSandboxConfigFile :: Flag FilePath, + globalRemoteRepos :: [RemoteRepo], -- ^ Available Hackage servers. + globalCacheDir :: Flag FilePath, + globalLocalRepos :: [FilePath], + globalLogsDir :: Flag FilePath, + globalWorldFile :: Flag FilePath } defaultGlobalFlags :: GlobalFlags defaultGlobalFlags = GlobalFlags { - globalVersion = Flag False, - globalNumericVersion = Flag False, - globalConfigFile = mempty, - globalRemoteRepos = [], - globalCacheDir = mempty, - globalLocalRepos = mempty, - globalLogsDir = mempty, - globalWorldFile = mempty + globalVersion = Flag False, + globalNumericVersion = Flag False, + globalConfigFile = mempty, + globalSandboxConfigFile = mempty, + globalRemoteRepos = [], + globalCacheDir = mempty, + globalLocalRepos = mempty, + globalLogsDir = mempty, + globalWorldFile = mempty } globalCommand :: CommandUI GlobalFlags @@ -132,7 +141,7 @@ ++ " " ++ pname ++ " update\n", commandDefaultFlags = defaultGlobalFlags, commandOptions = \showOrParseArgs -> - (case showOrParseArgs of ShowArgs -> take 2; ParseArgs -> id) + (case showOrParseArgs of ShowArgs -> take 4; ParseArgs -> id) [option ['V'] ["version"] "Print version information" globalVersion (\v flags -> flags { globalVersion = v }) @@ -148,6 +157,12 @@ globalConfigFile (\v flags -> flags { globalConfigFile = v }) (reqArgFlag "FILE") + ,option [] ["sandbox-config-file"] + "Set an alternate location for the sandbox config file \ + (default: './cabal.sandbox.config')" + globalConfigFile (\v flags -> flags { globalSandboxConfigFile = v }) + (reqArgFlag "FILE") + ,option [] ["remote-repo"] "The name and url for a remote repository" globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v }) @@ -177,24 +192,26 @@ instance Monoid GlobalFlags where mempty = GlobalFlags { - globalVersion = mempty, - globalNumericVersion = mempty, - globalConfigFile = mempty, - globalRemoteRepos = mempty, - globalCacheDir = mempty, - globalLocalRepos = mempty, - globalLogsDir = mempty, - globalWorldFile = mempty + globalVersion = mempty, + globalNumericVersion = mempty, + globalConfigFile = mempty, + globalSandboxConfigFile = mempty, + globalRemoteRepos = mempty, + globalCacheDir = mempty, + globalLocalRepos = mempty, + globalLogsDir = mempty, + globalWorldFile = mempty } mappend a b = GlobalFlags { - globalVersion = combine globalVersion, - globalNumericVersion = combine globalNumericVersion, - globalConfigFile = combine globalConfigFile, - globalRemoteRepos = combine globalRemoteRepos, - globalCacheDir = combine globalCacheDir, - globalLocalRepos = combine globalLocalRepos, - globalLogsDir = combine globalLogsDir, - globalWorldFile = combine globalWorldFile + globalVersion = combine globalVersion, + globalNumericVersion = combine globalNumericVersion, + globalConfigFile = combine globalConfigFile, + globalSandboxConfigFile = combine globalConfigFile, + globalRemoteRepos = combine globalRemoteRepos, + globalCacheDir = combine globalCacheDir, + globalLocalRepos = combine globalLocalRepos, + globalLogsDir = combine globalLogsDir, + globalWorldFile = combine globalWorldFile } where combine field = field a `mappend` field b @@ -224,10 +241,26 @@ filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags filterConfigureFlags flags cabalLibVersion - | cabalLibVersion >= Version [1,3,10] [] = flags - -- older Cabal does not grok the constraints flag: - | otherwise = flags { configConstraints = [] } + | cabalLibVersion >= Version [1,18,0] [] = flags + | cabalLibVersion < Version [1,3,10] [] = flags_1_3_10 + | cabalLibVersion < Version [1,10,0] [] = flags_1_10_0 + | cabalLibVersion < Version [1,14,0] [] = flags_1_14_0 + | cabalLibVersion < Version [1,18,0] [] = flags_1_18_0 + -- A no-op that silences the "pattern match is non-exhaustive" warning. + | otherwise = flags + where + -- Cabal < 1.18.0 doesn't know about --extra-prog-path and --sysconfdir. + flags_1_18_0 = flags { configProgramPathExtra = [] + , configInstallDirs = configInstallDirs_1_18_0} + configInstallDirs_1_18_0 = (configInstallDirs flags) { sysconfdir = NoFlag } + -- Cabal < 1.14.0 doesn't know about --disable-benchmarks. + flags_1_14_0 = flags_1_18_0 { configBenchmarks = NoFlag } + -- Cabal < 1.10.0 doesn't know about --disable-tests. + flags_1_10_0 = flags_1_14_0 { configTests = NoFlag } + -- Cabal < 1.3.10 does not grok the constraints flag. + flags_1_3_10 = flags_1_10_0 { configConstraints = [] } + -- ------------------------------------------------------------ -- * Config extra flags -- ------------------------------------------------------------ @@ -299,6 +332,99 @@ where combine field = field a `mappend` field b -- ------------------------------------------------------------ +-- * Build flags +-- ------------------------------------------------------------ + +data SkipAddSourceDepsCheck = + SkipAddSourceDepsCheck | DontSkipAddSourceDepsCheck + deriving Eq + +data BuildExFlags = BuildExFlags { + buildNumJobs :: Flag (Maybe Int), + buildOnly :: Flag SkipAddSourceDepsCheck +} + +buildExOptions :: ShowOrParseArgs -> [OptionField BuildExFlags] +buildExOptions _showOrParseArgs = + option "j" ["jobs"] + "Run NUM jobs simultaneously (or '$ncpus' if no NUM is given)" + buildNumJobs (\v flags -> flags { buildNumJobs = v }) + (optArg "NUM" (fmap Flag numJobsParser) + (Flag Nothing) + (map (Just . maybe "$ncpus" show) . flagToList)) + + : option [] ["only"] + "Don't reinstall add-source dependencies (sandbox-only)" + buildOnly (\v flags -> flags { buildOnly = v }) + (noArg (Flag SkipAddSourceDepsCheck)) + + : [] + +buildCommand :: CommandUI (BuildFlags, BuildExFlags) +buildCommand = parent { + commandDefaultFlags = (commandDefaultFlags parent, mempty), + commandOptions = + \showOrParseArgs -> liftOptions fst setFst + (commandOptions parent showOrParseArgs) + ++ + liftOptions snd setSnd (buildExOptions showOrParseArgs) + } + where + setFst a (_,b) = (a,b) + setSnd b (a,_) = (a,b) + + parent = Cabal.buildCommand defaultProgramConfiguration + +instance Monoid BuildExFlags where + mempty = BuildExFlags { + buildNumJobs = mempty, + buildOnly = mempty + } + mappend a b = BuildExFlags { + buildNumJobs = combine buildNumJobs, + buildOnly = combine buildOnly + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Test command +-- ------------------------------------------------------------ + +testCommand :: CommandUI (TestFlags, BuildExFlags) +testCommand = parent { + commandDefaultFlags = (commandDefaultFlags parent, mempty), + commandOptions = + \showOrParseArgs -> liftOptions fst setFst + (commandOptions parent showOrParseArgs) + ++ + liftOptions snd setSnd (buildExOptions showOrParseArgs) + } + where + setFst a (_,b) = (a,b) + setSnd b (a,_) = (a,b) + + parent = Cabal.testCommand + +-- ------------------------------------------------------------ +-- * Bench command +-- ------------------------------------------------------------ + +benchmarkCommand :: CommandUI (BenchmarkFlags, BuildExFlags) +benchmarkCommand = parent { + commandDefaultFlags = (commandDefaultFlags parent, mempty), + commandOptions = + \showOrParseArgs -> liftOptions fst setFst + (commandOptions parent showOrParseArgs) + ++ + liftOptions snd setSnd (buildExOptions showOrParseArgs) + } + where + setFst a (_,b) = (a,b) + setSnd b (a,_) = (a,b) + + parent = Cabal.benchmarkCommand + +-- ------------------------------------------------------------ -- * Fetch command -- ------------------------------------------------------------ @@ -375,9 +501,9 @@ updateCommand :: CommandUI (Flag Verbosity) updateCommand = CommandUI { commandName = "update", - commandSynopsis = "Updates list of known packages", + commandSynopsis = "Updates list of known packages.", commandDescription = Nothing, - commandUsage = usagePackages "update", + commandUsage = usageFlags "update", commandDefaultFlags = toFlag normal, commandOptions = \_ -> [optionVerbosity id const] } @@ -387,7 +513,7 @@ commandName = "upgrade", commandSynopsis = "(command disabled, use install instead)", commandDescription = Nothing, - commandUsage = usagePackages "upgrade", + commandUsage = usageFlagsOrPackages "upgrade", commandDefaultFlags = (mempty, mempty, mempty, mempty), commandOptions = commandOptions installCommand } @@ -406,13 +532,36 @@ checkCommand :: CommandUI (Flag Verbosity) checkCommand = CommandUI { commandName = "check", - commandSynopsis = "Check the package for common mistakes", + commandSynopsis = "Check the package for common mistakes.", commandDescription = Nothing, commandUsage = \pname -> "Usage: " ++ pname ++ " check\n", commandDefaultFlags = toFlag normal, commandOptions = \_ -> [] } +runCommand :: CommandUI (BuildFlags, BuildExFlags) +runCommand = CommandUI { + commandName = "run", + commandSynopsis = "Runs the compiled executable.", + commandDescription = Nothing, + commandUsage = + \pname -> "Usage: " ++ pname + ++ " run [FLAGS] [EXECUTABLE] [-- EXECUTABLE_FLAGS]\n\n" + ++ "Flags for run:", + commandDefaultFlags = mempty, + commandOptions = + \showOrParseArgs -> liftOptions fst setFst + (Cabal.buildOptions progConf showOrParseArgs) + ++ + liftOptions snd setSnd + (buildExOptions showOrParseArgs) + } + where + setFst a (_,b) = (a,b) + setSnd b (a,_) = (a,b) + + progConf = defaultProgramConfiguration + -- ------------------------------------------------------------ -- * Report flags -- ------------------------------------------------------------ @@ -470,52 +619,74 @@ where combine field = field a `mappend` field b -- ------------------------------------------------------------ --- * Unpack flags +-- * Get flags -- ------------------------------------------------------------ -data UnpackFlags = UnpackFlags { - unpackDestDir :: Flag FilePath, - unpackVerbosity :: Flag Verbosity, - unpackPristine :: Flag Bool - } +data GetFlags = GetFlags { + getDestDir :: Flag FilePath, + getPristine :: Flag Bool, + getSourceRepository :: Flag (Maybe RepoKind), + getVerbosity :: Flag Verbosity + } -defaultUnpackFlags :: UnpackFlags -defaultUnpackFlags = UnpackFlags { - unpackDestDir = mempty, - unpackVerbosity = toFlag normal, - unpackPristine = toFlag False +defaultGetFlags :: GetFlags +defaultGetFlags = GetFlags { + getDestDir = mempty, + getPristine = mempty, + getSourceRepository = mempty, + getVerbosity = toFlag normal } -unpackCommand :: CommandUI UnpackFlags -unpackCommand = CommandUI { - commandName = "unpack", - commandSynopsis = "Unpacks packages for user inspection.", - commandDescription = Nothing, - commandUsage = usagePackages "unpack", +getCommand :: CommandUI GetFlags +getCommand = CommandUI { + commandName = "get", + commandSynopsis = "Gets a package's source code.", + commandDescription = Just $ \_ -> + "Creates a local copy of a package's source code. By default it gets " + ++ "the source\ntarball and unpacks it in a local subdirectory. " + ++ "Alternatively, with -s it will\nget the code from the source " + ++ "repository specified by the package.\n", + commandUsage = usagePackages "get", commandDefaultFlags = mempty, commandOptions = \_ -> [ - optionVerbosity unpackVerbosity (\v flags -> flags { unpackVerbosity = v }) + optionVerbosity getVerbosity (\v flags -> flags { getVerbosity = v }) ,option "d" ["destdir"] - "where to unpack the packages, defaults to the current directory." - unpackDestDir (\v flags -> flags { unpackDestDir = v }) + "Where to place the package source, defaults to the current directory." + getDestDir (\v flags -> flags { getDestDir = v }) (reqArgFlag "PATH") + ,option "s" ["source-repository"] + "Copy the package's source repository (ie git clone, darcs get, etc as appropriate)." + getSourceRepository (\v flags -> flags { getSourceRepository = v }) + (optArg "[head|this|...]" (readP_to_E (const "invalid source-repository") + (fmap (toFlag . Just) parse)) + (Flag Nothing) + (map (fmap show) . flagToList)) + , option [] ["pristine"] ("Unpack the original pristine tarball, rather than updating the " ++ ".cabal file with the latest revision from the package archive.") - unpackPristine (\v flags -> flags { unpackPristine = v }) + getPristine (\v flags -> flags { getPristine = v }) trueArg ] } -instance Monoid UnpackFlags where - mempty = defaultUnpackFlags - mappend a b = UnpackFlags { - unpackDestDir = combine unpackDestDir, - unpackVerbosity = combine unpackVerbosity, - unpackPristine = combine unpackPristine +-- 'cabal unpack' is a deprecated alias for 'cabal get'. +unpackCommand :: CommandUI GetFlags +unpackCommand = getCommand { + commandName = "unpack", + commandUsage = usagePackages "unpack" } + +instance Monoid GetFlags where + mempty = defaultGetFlags + mappend a b = GetFlags { + getDestDir = combine getDestDir, + getPristine = combine getPristine, + getSourceRepository = combine getSourceRepository, + getVerbosity = combine getVerbosity + } where combine field = field a `mappend` field b -- ------------------------------------------------------------ @@ -540,7 +711,7 @@ commandName = "list", commandSynopsis = "List packages matching a search string.", commandDescription = Nothing, - commandUsage = usagePackages "list", + commandUsage = usageFlagsOrPackages "list", commandDefaultFlags = defaultListFlags, commandOptions = \_ -> [ optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v }) @@ -667,7 +838,7 @@ installCommand = CommandUI { commandName = "install", commandSynopsis = "Installs a list of packages.", - commandUsage = usagePackages "install", + commandUsage = usageFlagsOrPackages "install", commandDescription = Just $ \pname -> let original = case commandDescription configureCommand of Just desc -> desc pname ++ "\n" @@ -696,18 +867,19 @@ get3 (_,_,c,_) = c; set3 c (a,b,_,d) = (a,b,c,d) get4 (_,_,_,d) = d; set4 d (a,b,c,_) = (a,b,c,d) - haddockOptions showOrParseArgs - = [ opt { optionName = "haddock-" ++ name, - optionDescr = [ fmapOptFlags (\(_, lflags) -> ([], map ("haddock-" ++) lflags)) descr - | descr <- optionDescr opt] } - | opt <- commandOptions Cabal.haddockCommand showOrParseArgs - , let name = optionName opt - , name `elem` ["hoogle", "html", "html-location", - "executables", "internal", "css", - "hyperlink-source", "hscolour-css", - "contents-location"] - ] - +haddockOptions :: ShowOrParseArgs -> [OptionField HaddockFlags] +haddockOptions showOrParseArgs + = [ opt { optionName = "haddock-" ++ name, + optionDescr = [ fmapOptFlags (\(_, lflags) -> ([], map ("haddock-" ++) lflags)) descr + | descr <- optionDescr opt] } + | opt <- commandOptions Cabal.haddockCommand showOrParseArgs + , let name = optionName opt + , name `elem` ["hoogle", "html", "html-location", + "executables", "internal", "css", + "hyperlink-source", "hscolour-css", + "contents-location"] + ] + where fmapOptFlags :: (OptFlags -> OptFlags) -> OptDescr a -> OptDescr a fmapOptFlags modify (ReqArg d f p r w) = ReqArg d (modify f) p r w fmapOptFlags modify (OptArg d f p r i w) = OptArg d (modify f) p r i w @@ -764,6 +936,11 @@ installOnlyDeps (\v flags -> flags { installOnlyDeps = v }) (yesNoOpt showOrParseArgs) + , option [] ["dependencies-only"] + "A synonym for --only-dependencies" + installOnlyDeps (\v flags -> flags { installOnlyDeps = v }) + (yesNoOpt showOrParseArgs) + , option [] ["root-cmd"] "Command used to gain root privileges, when installing with --global." installRootCmd (\v flags -> flags { installRootCmd = v }) @@ -799,22 +976,21 @@ (yesNoOpt showOrParseArgs) , option "j" ["jobs"] - "Run NUM jobs simultaneously." + "Run NUM jobs simultaneously (or '$ncpus' if no NUM is given)." installNumJobs (\v flags -> flags { installNumJobs = v }) - (optArg "NUM" (readP_to_E (\_ -> "jobs should be a number") - (fmap (toFlag . Just) - (Parse.readS_to_P reads))) + (optArg "NUM" (fmap Flag numJobsParser) (Flag Nothing) - (map (fmap show) . flagToList)) - ] ++ case showOrParseArgs of -- TODO: remove when "cabal install" avoids + (map (Just . maybe "$ncpus" show) . flagToList)) + ] ++ case showOrParseArgs of -- TODO: remove when "cabal install" + -- avoids ParseArgs -> - option [] ["only"] + [ option [] ["only"] "Only installs the package in the current directory." installOnly (\v flags -> flags { installOnly = v }) - trueArg - : [] + trueArg ] _ -> [] + instance Monoid InstallFlags where mempty = InstallFlags { installDocumentation = mempty, @@ -884,7 +1060,7 @@ uploadCommand :: CommandUI UploadFlags uploadCommand = CommandUI { commandName = "upload", - commandSynopsis = "Uploads source packages to Hackage", + commandSynopsis = "Uploads source packages to Hackage.", commandDescription = Just $ \_ -> "You can store your Hackage login in the ~/.cabal/config file\n", commandUsage = \pname -> @@ -976,6 +1152,11 @@ IT.minimal (\v flags -> flags { IT.minimal = v }) trueArg + , option [] ["overwrite"] + "Overwrite any existing .cabal, LICENSE, or Setup.hs files without warning." + IT.overwrite (\v flags -> flags { IT.overwrite = v }) + trueArg + , option [] ["package-dir"] "Root directory of the package (default = current directory)." IT.packageDir (\v flags -> flags { IT.packageDir = v }) @@ -1033,6 +1214,12 @@ (reqArg' "CATEGORY" (\s -> toFlag $ maybe (Left s) Right (readMaybe s)) (flagToList . fmap (either id show))) + , option ['x'] ["extra-source-file"] + "Extra source file to be distributed with tarball." + IT.extraSrc (\v flags -> flags { IT.extraSrc = v }) + (reqArg' "FILE" (Just . (:[])) + (fromMaybe [])) + , option [] ["is-library"] "Build a library." IT.packageType (\v flags -> flags { IT.packageType = v }) @@ -1044,20 +1231,36 @@ (\v flags -> flags { IT.packageType = v }) (noArg (Flag IT.Executable)) + , option [] ["language"] + "Specify the default language." + IT.language + (\v flags -> flags { IT.language = v }) + (reqArg "LANGUAGE" (readP_to_E ("Cannot parse language: "++) + (toFlag `fmap` parse)) + (flagToList . fmap display)) + , option ['o'] ["expose-module"] "Export a module from the package." IT.exposedModules (\v flags -> flags { IT.exposedModules = v }) (reqArg "MODULE" (readP_to_E ("Cannot parse module name: "++) ((Just . (:[])) `fmap` parse)) - (fromMaybe [] . fmap (fmap display))) + (maybe [] (fmap display))) + , option [] ["extension"] + "Use a LANGUAGE extension (in the other-extensions field)." + IT.otherExts + (\v flags -> flags { IT.otherExts = v }) + (reqArg "EXTENSION" (readP_to_E ("Cannot parse extension: "++) + ((Just . (:[])) `fmap` parse)) + (maybe [] (fmap display))) + , option ['d'] ["dependency"] "Package dependency." IT.dependencies (\v flags -> flags { IT.dependencies = v }) (reqArg "PACKAGE" (readP_to_E ("Cannot parse dependency: "++) ((Just . (:[])) `fmap` parse)) - (fromMaybe [] . fmap (fmap display))) + (maybe [] (fmap display))) , option [] ["source-dir"] "Directory containing package source." @@ -1130,6 +1333,121 @@ combine field = field a `mappend` field b -- ------------------------------------------------------------ +-- * Win32SelfUpgrade flags +-- ------------------------------------------------------------ + +data Win32SelfUpgradeFlags = Win32SelfUpgradeFlags { + win32SelfUpgradeVerbosity :: Flag Verbosity +} + +defaultWin32SelfUpgradeFlags :: Win32SelfUpgradeFlags +defaultWin32SelfUpgradeFlags = Win32SelfUpgradeFlags { + win32SelfUpgradeVerbosity = toFlag normal +} + +win32SelfUpgradeCommand :: CommandUI Win32SelfUpgradeFlags +win32SelfUpgradeCommand = CommandUI { + commandName = "win32selfupgrade", + commandSynopsis = "Self-upgrade the executable on Windows", + commandDescription = Nothing, + commandUsage = \pname -> + "Usage: " ++ pname ++ " win32selfupgrade PID PATH\n\n" + ++ "Flags for win32selfupgrade:", + commandDefaultFlags = defaultWin32SelfUpgradeFlags, + commandOptions = \_ -> + [optionVerbosity win32SelfUpgradeVerbosity + (\v flags -> flags { win32SelfUpgradeVerbosity = v}) + ] +} + +instance Monoid Win32SelfUpgradeFlags where + mempty = defaultWin32SelfUpgradeFlags + mappend a b = Win32SelfUpgradeFlags { + win32SelfUpgradeVerbosity = combine win32SelfUpgradeVerbosity + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Sandbox-related flags +-- ------------------------------------------------------------ + +data SandboxFlags = SandboxFlags { + sandboxVerbosity :: Flag Verbosity, + sandboxSnapshot :: Flag Bool, -- FIXME: this should be an 'add-source'-only + -- flag. + sandboxLocation :: Flag FilePath +} + +defaultSandboxLocation :: FilePath +defaultSandboxLocation = ".cabal-sandbox" + +defaultSandboxFlags :: SandboxFlags +defaultSandboxFlags = SandboxFlags { + sandboxVerbosity = toFlag normal, + sandboxSnapshot = toFlag False, + sandboxLocation = toFlag defaultSandboxLocation + } + +sandboxCommand :: CommandUI SandboxFlags +sandboxCommand = CommandUI { + commandName = "sandbox", + commandSynopsis = "Create/modify/delete a sandbox.", + commandDescription = Nothing, + commandUsage = \pname -> + "Usage: " ++ pname ++ " sandbox init\n" + ++ " or: " ++ pname ++ " sandbox delete\n" + ++ " or: " ++ pname ++ " sandbox add-source [PATHS]\n\n" + ++ " or: " ++ pname ++ " sandbox hc-pkg -- [ARGS]\n" + ++ " or: " ++ pname ++ " sandbox list-sources\n\n" + ++ "Flags for sandbox:", + + commandDefaultFlags = defaultSandboxFlags, + commandOptions = \_ -> + [ optionVerbosity sandboxVerbosity + (\v flags -> flags { sandboxVerbosity = v }) + + , option [] ["snapshot"] + "Take a snapshot instead of creating a link (only applies to 'add-source')" + sandboxSnapshot (\v flags -> flags { sandboxSnapshot = v }) + trueArg + + , option [] ["sandbox"] + "Sandbox location (default: './.cabal-sandbox')." + sandboxLocation (\v flags -> flags { sandboxLocation = v }) + (reqArgFlag "DIR") + ] + } + +instance Monoid SandboxFlags where + mempty = SandboxFlags { + sandboxVerbosity = mempty, + sandboxSnapshot = mempty, + sandboxLocation = mempty + } + mappend a b = SandboxFlags { + sandboxVerbosity = combine sandboxVerbosity, + sandboxSnapshot = combine sandboxSnapshot, + sandboxLocation = combine sandboxLocation + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Shared options utils +-- ------------------------------------------------------------ + +-- | Common parser for the @-j@ flag of @build@ and @install@. +numJobsParser :: ReadE (Maybe Int) +numJobsParser = ReadE $ \s -> + case s of + "$ncpus" -> Right Nothing + _ -> case reads s of + [(n, "")] + | n < 1 -> Left "The number of jobs should be 1 or more." + | n > 64 -> Left "You probably don't want that many jobs." + | otherwise -> Right (Just n) + _ -> Left "The jobs value should be a number or '$ncpus'" + +-- ------------------------------------------------------------ -- * GetOpt Utils -- ------------------------------------------------------------ @@ -1141,7 +1459,7 @@ -> [OptionField a] -> [OptionField b] liftOptions get set = map (liftOption get set) -yesNoOpt :: ShowOrParseArgs -> MkOptDescr (b -> Flag Bool) (Flag Bool -> (b -> b)) b +yesNoOpt :: ShowOrParseArgs -> MkOptDescr (b -> Flag Bool) (Flag Bool -> b -> b) b yesNoOpt ShowArgs sf lf = trueArg sf lf yesNoOpt _ sf lf = boolOpt' flagToMaybe Flag (sf, lf) ([], map ("no-" ++) lf) sf lf @@ -1187,10 +1505,20 @@ ] -usagePackages :: String -> String -> String -usagePackages name pname = +usageFlagsOrPackages :: String -> String -> String +usageFlagsOrPackages name pname = "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n" ++ " or: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n\n" + ++ "Flags for " ++ name ++ ":" + +usagePackages :: String -> String -> String +usagePackages name pname = + "Usage: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n\n" + ++ "Flags for " ++ name ++ ":" + +usageFlags :: String -> String -> String +usageFlags name pname = + "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n\n" ++ "Flags for " ++ name ++ ":" --TODO: do we want to allow per-package flags? diff --git a/Distribution/Client/SetupWrapper.hs b/Distribution/Client/SetupWrapper.hs --- a/Distribution/Client/SetupWrapper.hs +++ b/Distribution/Client/SetupWrapper.hs @@ -26,8 +26,10 @@ ( Version(..), VersionRange, anyVersion , intersectVersionRanges, orLaterVersion , withinRange ) +import Distribution.InstalledPackageInfo (installedPackageId, sourcePackageId) import Distribution.Package - ( PackageIdentifier(..), PackageName(..), Package(..), packageName + ( InstalledPackageId(..), PackageIdentifier(..), + PackageName(..), Package(..), packageName , packageVersion, Dependency(..) ) import Distribution.PackageDescription ( GenericPackageDescription(packageDescription) @@ -36,19 +38,25 @@ import Distribution.PackageDescription.Parse ( readPackageDescription ) import Distribution.Simple.Configure - ( configCompiler ) + ( configCompilerEx ) +import Distribution.Compiler ( buildCompilerId ) import Distribution.Simple.Compiler - ( CompilerFlavor(GHC), Compiler, compilerVersion, showCompilerId + ( CompilerFlavor(GHC), Compiler(compilerId) + , compilerVersion , PackageDB(..), PackageDBStack ) import Distribution.Simple.Program ( ProgramConfiguration, emptyProgramConfiguration - , getDbProgramOutput, runDbProgram, ghcProgram ) + , getProgramSearchPath, getDbProgramOutput, runDbProgram, ghcProgram ) +import Distribution.Simple.Program.Find + ( programSearchPathAsPATHVar ) +import Distribution.Simple.Program.Run + ( getEffectiveEnvironment ) import Distribution.Simple.BuildPaths ( defaultDistPref, exeExtension ) import Distribution.Simple.Command ( CommandUI(..), commandShowOptions ) -import Distribution.Simple.GHC - ( ghcVerbosityOptions ) +import Distribution.Simple.Program.GHC + ( GhcMode(..), GhcOptions(..), renderGhcOptions ) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.PackageIndex (PackageIndex) import Distribution.Client.Config @@ -57,12 +65,15 @@ ( getInstalledPackages ) import Distribution.Client.JobControl ( Lock, criticalSection ) +import Distribution.Simple.Setup + ( Flag(..) ) import Distribution.Simple.Utils ( die, debug, info, cabalVersion, findPackageDesc, comparing , createDirectoryIfMissingVerbose, installExecutableFile - , rewriteFile, intercalate ) + , moreRecentFile, rewriteFile, intercalate ) import Distribution.Client.Utils - ( moreRecentFile, inDir ) + ( inDir, tryCanonicalizePath ) +import Distribution.System ( Platform(..), buildPlatform ) import Distribution.Text ( display ) import Distribution.Verbosity @@ -70,19 +81,21 @@ import Distribution.Compat.Exception ( catchIO ) -import System.Directory ( doesFileExist, canonicalizePath ) +import System.Directory ( doesFileExist ) import System.FilePath ( (), (<.>) ) import System.IO ( Handle, hPutStr ) import System.Exit ( ExitCode(..), exitWith ) import System.Process ( runProcess, waitForProcess ) import Control.Monad ( when, unless ) -import Data.List ( maximumBy ) +import Data.List ( foldl1' ) import Data.Maybe ( fromMaybe, isJust ) +import Data.Monoid ( mempty ) import Data.Char ( isSpace ) data SetupScriptOptions = SetupScriptOptions { useCabalVersion :: VersionRange, useCompiler :: Maybe Compiler, + usePlatform :: Maybe Platform, usePackageDB :: PackageDBStack, usePackageIndex :: Maybe PackageIndex, useProgramConfig :: ProgramConfiguration, @@ -93,6 +106,16 @@ -- Used only when calling setupWrapper from parallel code to serialise -- access to the setup cache; should be Nothing otherwise. + -- + -- Note: setup exe cache + ------------------------ + -- When we are installing in parallel, we always use the external setup + -- method. Since compiling the setup script each time adds noticeable + -- overhead, we use a shared setup script cache + -- ('~/.cabal/setup-exe-cache'). For each (compiler, platform, Cabal + -- version) combination the cache holds a compiled setup script + -- executable. This only affects the Simple build type; for the Custom, + -- Configure and Make build types we always compile the setup script anew. setupCacheLock :: Maybe Lock } @@ -100,6 +123,7 @@ defaultSetupScriptOptions = SetupScriptOptions { useCabalVersion = anyVersion, useCompiler = Nothing, + usePlatform = Nothing, usePackageDB = [GlobalPackageDB, UserPackageDB], usePackageIndex = Nothing, useProgramConfig = emptyProgramConfiguration, @@ -193,9 +217,11 @@ setupHs <- updateSetupScript cabalLibVersion bt debug verbosity $ "Using " ++ setupHs ++ " as setup script." path <- case bt of + -- TODO: Should we also cache the setup exe for the Make and Configure build + -- types? Simple -> getCachedSetupExecutable options' cabalLibVersion setupHs - _ -> compileSetupExecutable options' cabalLibVersion setupHs - invokeSetupScript path (mkargs cabalLibVersion) + _ -> compileSetupExecutable options' cabalLibVersion setupHs False + invokeSetupScript options' path (mkargs cabalLibVersion) where workingDir = case fromMaybe "" (useWorkingDir options) of @@ -204,6 +230,14 @@ setupDir = workingDir useDistPref options "setup" setupVersionFile = setupDir "setup" <.> "version" + maybeGetInstalledPackages :: SetupScriptOptions -> Compiler + -> ProgramConfiguration -> IO PackageIndex + maybeGetInstalledPackages options' comp conf = + case usePackageIndex options' of + Just index -> return index + Nothing -> getInstalledPackages verbosity + comp (usePackageDB options') conf + cabalLibVersionToUse :: IO (Version, SetupScriptOptions) cabalLibVersionToUse = do savedVersion <- savedCabalVersion @@ -211,7 +245,7 @@ Just version | version `withinRange` useCabalVersion options -> return (version, options) _ -> do (comp, conf, options') <- configureCompiler options - version <- installedCabalVersion options comp conf + version <- installedCabalVersion options' comp conf writeFile setupVersionFile (show version ++ "\n") return (version, options') @@ -226,19 +260,34 @@ installedCabalVersion _ _ _ | packageName pkg == PackageName "Cabal" = return (packageVersion pkg) installedCabalVersion options' comp conf = do - index <- case usePackageIndex options' of - Just index -> return index - Nothing -> getInstalledPackages verbosity - comp (usePackageDB options') conf - - let cabalDep = Dependency (PackageName "Cabal") (useCabalVersion options) + index <- maybeGetInstalledPackages options' comp conf + let cabalDep = Dependency (PackageName "Cabal") (useCabalVersion options') case PackageIndex.lookupDependency index cabalDep of - [] -> die $ "The package requires Cabal library version " + [] -> die $ "The package '" ++ display (packageName pkg) + ++ "' requires Cabal library version " ++ display (useCabalVersion options) ++ " but no suitable version is installed." - pkgs -> return $ bestVersion (map fst pkgs) + pkgs -> return $ bestVersion id (map fst pkgs) + + bestVersion :: (a -> Version) -> [a] -> a + bestVersion f = firstMaximumBy (comparing (preference . f)) where - bestVersion = maximumBy (comparing preference) + -- Like maximumBy, but picks the first maximum element instead of the + -- last. In general, we expect the preferred version to go first in the + -- list. For the default case, this has the effect of choosing the version + -- installed in the user package DB instead of the global one. See #1463. + -- + -- Note: firstMaximumBy could be written as just + -- `maximumBy cmp . reverse`, but the problem is that the behaviour of + -- maximumBy is not fully specified in the case when there is not a single + -- greatest element. + firstMaximumBy :: (a -> a -> Ordering) -> [a] -> a + firstMaximumBy _ [] = + error "Distribution.Client.firstMaximumBy: empty list" + firstMaximumBy cmp xs = foldl1' maxBy xs + where + maxBy x y = case cmp x y of { GT -> x; EQ -> x; LT -> y; } + preference version = (sameVersion, sameMajorVersion ,stableVersion, latestVersion) where @@ -250,14 +299,37 @@ _ -> False latestVersion = version + -- TODO: This function looks a lot like @installedCabalVersion@ - can the + -- duplication be removed? + installedCabalPkgId :: SetupScriptOptions -> Compiler -> ProgramConfiguration + -> Version -> IO (Maybe InstalledPackageId) + installedCabalPkgId _ _ _ _ | packageName pkg == PackageName "Cabal" = + return Nothing + installedCabalPkgId options' compiler conf cabalLibVersion = do + index <- maybeGetInstalledPackages options' compiler conf + let cabalPkgid = PackageIdentifier (PackageName "Cabal") cabalLibVersion + case PackageIndex.lookupSourcePackageId index cabalPkgid of + [] -> die $ "The package '" ++ display (packageName pkg) + ++ "' requires Cabal library version " + ++ display (cabalLibVersion) + ++ " but no suitable version is installed." + iPkgInfos -> return . Just . installedPackageId + . bestVersion (pkgVersion . sourcePackageId) $ iPkgInfos + configureCompiler :: SetupScriptOptions -> IO (Compiler, ProgramConfiguration, SetupScriptOptions) configureCompiler options' = do (comp, conf) <- case useCompiler options' of Just comp -> return (comp, useProgramConfig options') - Nothing -> configCompiler (Just GHC) Nothing Nothing - (useProgramConfig options') verbosity - return (comp, conf, options' { useCompiler = Just comp, + Nothing -> do (comp, _, conf) <- + configCompilerEx (Just GHC) Nothing Nothing + (useProgramConfig options') verbosity + return (comp, conf) + -- Whenever we need to call configureCompiler, we also need to access the + -- package index, so let's cache it here. + index <- maybeGetInstalledPackages options' comp conf + return (comp, conf, options' { useCompiler = Just comp, + usePackageIndex = Just index, useProgramConfig = conf }) -- | Decide which Setup.hs script to use, creating it if necessary. @@ -299,6 +371,7 @@ let setupCacheDir = cabalDir "setup-exe-cache" let setupProgFile = setupCacheDir ("setup-" ++ cabalVersionString ++ "-" + ++ platformString ++ "-" ++ compilerVersionString) <.> exeExtension setupProgFileExists <- doesFileExist setupProgFile @@ -313,39 +386,51 @@ "Found cached setup executable: " ++ setupProgFile else do debug verbosity $ "Setup executable not found in the cache." - src <- compileSetupExecutable options' cabalLibVersion setupHsFile + src <- compileSetupExecutable options' cabalLibVersion setupHsFile True createDirectoryIfMissingVerbose verbosity True setupCacheDir installExecutableFile verbosity src setupProgFile return setupProgFile where cabalVersionString = "Cabal-" ++ (display cabalLibVersion) - compilerVersionString = fromMaybe "nonexisting-compiler" - (showCompilerId `fmap` useCompiler options') + compilerVersionString = display $ + fromMaybe buildCompilerId + (fmap compilerId . useCompiler $ options') + platformString = display $ + fromMaybe buildPlatform (usePlatform options') criticalSection' = fromMaybe id (fmap criticalSection $ setupCacheLock options') -- | If the Setup.hs is out of date wrt the executable then recompile it. -- Currently this is GHC only. It should really be generalised. -- - compileSetupExecutable :: SetupScriptOptions -> Version -> FilePath + compileSetupExecutable :: SetupScriptOptions -> Version -> FilePath -> Bool -> IO FilePath - compileSetupExecutable options' cabalLibVersion setupHsFile = do + compileSetupExecutable options' cabalLibVersion setupHsFile forceCompile = do setupHsNewer <- setupHsFile `moreRecentFile` setupProgFile cabalVersionNewer <- setupVersionFile `moreRecentFile` setupProgFile let outOfDate = setupHsNewer || cabalVersionNewer - when outOfDate $ do - debug verbosity "Setup script is out of date, compiling..." - (compiler, conf, _) <- configureCompiler options' - --TODO: get Cabal's GHC module to export a GhcOptions type and render func - let ghcCmdLine = - ghcVerbosityOptions verbosity - ++ ["--make", setupHsFile, "-o", setupProgFile - ,"-odir", setupDir, "-hidir", setupDir - ,"-i", "-i" ++ workingDir ] - ++ ghcPackageDbOptions compiler (usePackageDB options') - ++ if packageName pkg == PackageName "Cabal" - then [] - else ["-package", display cabalPkgid] + when (outOfDate || forceCompile) $ do + debug verbosity "Setup executable needs to be updated, compiling..." + (compiler, conf, options'') <- configureCompiler options' + let cabalPkgid = PackageIdentifier (PackageName "Cabal") cabalLibVersion + maybeCabalInstalledPkgId <- installedCabalPkgId options'' compiler conf + cabalLibVersion + let ghcOptions = mempty { + ghcOptVerbosity = Flag verbosity + , ghcOptMode = Flag GhcModeMake + , ghcOptInputFiles = [setupHsFile] + , ghcOptOutputFile = Flag setupProgFile + , ghcOptObjDir = Flag setupDir + , ghcOptHiDir = Flag setupDir + , ghcOptSourcePathClear = Flag True + , ghcOptSourcePath = [workingDir] + , ghcOptPackageDBs = usePackageDB options'' + , ghcOptPackages = + maybe [] + (\cabalInstalledPkgId -> [(cabalInstalledPkgId, cabalPkgid)]) + maybeCabalInstalledPkgId + } + let ghcCmdLine = renderGhcOptions (compilerVersion compiler) ghcOptions case useLoggingHandle options of Nothing -> runDbProgram verbosity ghcProgram conf ghcCmdLine @@ -356,29 +441,11 @@ return setupProgFile where setupProgFile = setupDir "setup" <.> exeExtension - cabalPkgid = PackageIdentifier (PackageName "Cabal") cabalLibVersion - ghcPackageDbOptions :: Compiler -> PackageDBStack -> [String] - ghcPackageDbOptions compiler dbstack = case dbstack of - (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs - (GlobalPackageDB:dbs) -> ("-no-user-" ++ packageDbFlag) - : concatMap specific dbs - _ -> ierror - where - specific (SpecificPackageDB db) = [ '-':packageDbFlag, db ] - specific _ = ierror - ierror = error "internal error: unexpected package db stack" - - packageDbFlag - | compilerVersion compiler < Version [7,5] [] - = "package-conf" - | otherwise - = "package-db" - - invokeSetupScript :: FilePath -> [String] -> IO () - invokeSetupScript path args = do + invokeSetupScript :: SetupScriptOptions -> FilePath -> [String] -> IO () + invokeSetupScript options' path args = do info verbosity $ unwords (path : args) - case useLoggingHandle options of + case useLoggingHandle options' of Nothing -> return () Just logHandle -> info verbosity $ "Redirecting build log to " ++ show logHandle @@ -387,10 +454,14 @@ -- be turned into an absolute path. On some systems, runProcess will take -- path as relative to the new working directory instead of the current -- working directory. - path' <- canonicalizePath path + path' <- tryCanonicalizePath path + searchpath <- programSearchPathAsPATHVar + (getProgramSearchPath (useProgramConfig options')) + env <- getEffectiveEnvironment [("PATH", Just searchpath)] + process <- runProcess path' args - (useWorkingDir options) Nothing - Nothing (useLoggingHandle options) (useLoggingHandle options) + (useWorkingDir options') env + Nothing (useLoggingHandle options') (useLoggingHandle options') exitCode <- waitForProcess process unless (exitCode == ExitSuccess) $ exitWith exitCode diff --git a/Distribution/Client/SrcDist.hs b/Distribution/Client/SrcDist.hs --- a/Distribution/Client/SrcDist.hs +++ b/Distribution/Client/SrcDist.hs @@ -6,42 +6,34 @@ ) where -import Distribution.Simple.SrcDist - ( printPackageProblems, prepareTree, snapshotPackage ) +import Distribution.Client.SetupWrapper + ( SetupScriptOptions(..), defaultSetupScriptOptions, setupWrapper ) import Distribution.Client.Tar (createTarGzFile) import Distribution.Package - ( Package(..), packageVersion ) + ( Package(..) ) import Distribution.PackageDescription ( PackageDescription ) +import Distribution.PackageDescription.Configuration + ( flattenPackageDescription ) import Distribution.PackageDescription.Parse ( readPackageDescription ) import Distribution.Simple.Utils - ( defaultPackageDesc, die, warn, notice, setupMessage - , createDirectoryIfMissingVerbose, withTempDirectory - , withUTF8FileContents, writeUTF8File ) + ( createDirectoryIfMissingVerbose, defaultPackageDesc + , die, notice, withTempDirectory ) import Distribution.Client.Setup ( SDistFlags(..), SDistExFlags(..), ArchiveFormat(..) ) import Distribution.Simple.Setup - ( fromFlag, flagToMaybe ) -import Distribution.Verbosity (Verbosity) -import Distribution.Simple.PreProcess (knownSuffixHandlers) + ( Flag(..), sdistCommand, flagToList, fromFlag, fromFlagOrDefault ) import Distribution.Simple.BuildPaths ( srcPref) -import Distribution.Simple.Configure(maybeGetPersistBuildConfig) -import Distribution.PackageDescription.Configuration ( flattenPackageDescription ) import Distribution.Simple.Program (requireProgram, simpleProgram, programPath) import Distribution.Simple.Program.Db (emptyProgramDb) -import Distribution.Text - ( display ) -import Distribution.Version - ( Version ) +import Distribution.Text ( display ) +import Distribution.Verbosity (Verbosity, lessVerbose, normal) +import Distribution.Version (Version(..), orLaterVersion) -import System.Time (getClockTime, toCalendarTime) import System.FilePath ((), (<.>)) import Control.Monad (when, unless) -import Data.Maybe (isNothing) -import Data.Char (toLower) -import Data.List (isPrefixOf) import System.Directory (doesFileExist, removeFile, canonicalizePath) import System.Process (runProcess, waitForProcess) import System.Exit (ExitCode(..)) @@ -50,93 +42,79 @@ sdist :: SDistFlags -> SDistExFlags -> IO () sdist flags exflags = do pkg <- return . flattenPackageDescription - =<< readPackageDescription verbosity - =<< defaultPackageDesc verbosity - mb_lbi <- maybeGetPersistBuildConfig distPref - - -- do some QA - printPackageProblems verbosity pkg + =<< readPackageDescription verbosity + =<< defaultPackageDesc verbosity + let withDir = if not needMakeArchive then (\f -> f tmpTargetDir) + else withTempDirectory verbosity tmpTargetDir "sdist." + -- 'withTempDir' fails if we don't create 'tmpTargetDir'... + when needMakeArchive $ + createDirectoryIfMissingVerbose verbosity True tmpTargetDir + withDir $ \tmpDir -> do + let outDir = if isOutDirectory then tmpDir else tmpDir tarBallName pkg + flags' = (if not needMakeArchive then flags + else flags { sDistDirectory = Flag outDir }) + { sDistVerbosity = Flag $ if verbosity == normal + then lessVerbose verbosity + else verbosity } + unless isListSources $ + createDirectoryIfMissingVerbose verbosity True outDir - when (isNothing mb_lbi) $ - warn verbosity "Cannot run preprocessors. Run 'configure' command first." + -- Run 'setup sdist --output-directory=tmpDir' (or + -- '--list-source'/'--output-directory=someOtherDir') in case we were passed + -- those options. + setupWrapper verbosity setupOpts (Just pkg) sdistCommand (const flags') [] - date <- toCalendarTime =<< getClockTime - let pkg' | snapshot = snapshotPackage date pkg - | otherwise = pkg + -- Unless we were given --list-sources or --output-directory ourselves, + -- create an archive. + when needMakeArchive $ + createArchive verbosity pkg tmpDir distPref - case flagToMaybe (sDistDirectory flags) of - Just targetDir -> do - generateSourceDir targetDir pkg' mb_lbi - notice verbosity $ "Source directory created: " ++ targetDir + when isOutDirectory $ + notice verbosity $ "Source directory created: " ++ tmpTargetDir - Nothing -> do - createDirectoryIfMissingVerbose verbosity True tmpTargetDir - withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do - let targetDir = tmpDir tarBallName pkg' - generateSourceDir targetDir pkg' mb_lbi - targzFile <- createArchive verbosity format pkg' tmpDir targetPref - notice verbosity $ "Source tarball created: " ++ targzFile + when isListSources $ + notice verbosity $ "List of package sources written to file '" + ++ (fromFlag . sDistListSources $ flags) ++ "'" where - generateSourceDir targetDir pkg' mb_lbi = do - - setupMessage verbosity "Building source dist for" (packageId pkg') - prepareTree verbosity pkg' mb_lbi distPref targetDir pps - when snapshot $ - overwriteSnapshotPackageDesc verbosity pkg' targetDir + flagEnabled f = not . null . flagToList . f $ flags - verbosity = fromFlag (sDistVerbosity flags) - snapshot = fromFlag (sDistSnapshot flags) - format = fromFlag (sDistFormat exflags) - pps = knownSuffixHandlers - distPref = fromFlag $ sDistDistPref flags - targetPref = distPref - tmpTargetDir = srcPref distPref + isListSources = flagEnabled sDistListSources + isOutDirectory = flagEnabled sDistDirectory + needMakeArchive = not (isListSources || isOutDirectory) + verbosity = fromFlag (sDistVerbosity flags) + distPref = fromFlag (sDistDistPref flags) + tmpTargetDir = fromFlagOrDefault (srcPref distPref) (sDistDirectory flags) + setupOpts = defaultSetupScriptOptions { + -- The '--output-directory' sdist flag was introduced in Cabal 1.12, and + -- '--list-sources' in 1.17. + useCabalVersion = if isListSources + then orLaterVersion $ Version [1,17,0] [] + else orLaterVersion $ Version [1,12,0] [] + } + format = fromFlag (sDistFormat exflags) + createArchive = case format of + TargzFormat -> createTarGzArchive + ZipFormat -> createZipArchive tarBallName :: PackageDescription -> String tarBallName = display . packageId -overwriteSnapshotPackageDesc :: Verbosity -- ^verbosity - -> PackageDescription -- ^info from the cabal file - -> FilePath -- ^source tree - -> IO () -overwriteSnapshotPackageDesc verbosity pkg targetDir = do - -- We could just writePackageDescription targetDescFile pkg_descr, - -- but that would lose comments and formatting. - descFile <- defaultPackageDesc verbosity - withUTF8FileContents descFile $ - writeUTF8File (targetDir descFile) - . unlines . map (replaceVersion (packageVersion pkg)) . lines - - where - replaceVersion :: Version -> String -> String - replaceVersion version line - | "version:" `isPrefixOf` map toLower line - = "version: " ++ display version - | otherwise = line - --- | Create an archive from a tree of source files. --- -createArchive :: Verbosity - -> ArchiveFormat - -> PackageDescription - -> FilePath - -> FilePath - -> IO FilePath -createArchive _verbosity TargzFormat pkg tmpDir targetPref = do +-- | Create a tar.gz archive from a tree of source files. +createTarGzArchive :: Verbosity -> PackageDescription -> FilePath -> FilePath + -> IO () +createTarGzArchive verbosity pkg tmpDir targetPref = do createTarGzFile tarBallFilePath tmpDir (tarBallName pkg) - return tarBallFilePath + notice verbosity $ "Source tarball created: " ++ tarBallFilePath where tarBallFilePath = targetPref tarBallName pkg <.> "tar.gz" -createArchive verbosity ZipFormat pkg tmpDir targetPref = do - createZipFile verbosity zipFilePath tmpDir (tarBallName pkg) - return zipFilePath - where - zipFilePath = targetPref tarBallName pkg <.> "zip" - -createZipFile :: Verbosity -> FilePath -> FilePath -> FilePath -> IO () -createZipFile verbosity zipfile base dir = do +-- | Create a zip archive from a tree of source files. +createZipArchive :: Verbosity -> PackageDescription -> FilePath -> FilePath + -> IO () +createZipArchive verbosity pkg tmpDir targetPref = do + let dir = tarBallName pkg + zipfile = targetPref dir <.> "zip" (zipProg, _) <- requireProgram verbosity zipProgram emptyProgramDb -- zip has an annoying habbit of updating the target rather than creating @@ -146,15 +124,19 @@ alreadyExists <- doesFileExist zipfile when alreadyExists $ removeFile zipfile - -- we call zip with a different CWD, so have to make the path absolute - zipfileAbs <- canonicalizePath zipfile + -- We call zip with a different CWD, so have to make the path + -- absolute. Can't just use 'canonicalizePath zipfile' since this function + -- requires its argument to refer to an existing file. + zipfileAbs <- fmap ( dir <.> "zip") . canonicalizePath $ targetPref --TODO: use runProgramInvocation, but has to be able to set CWD - hnd <- runProcess (programPath zipProg) ["-q", "-r", zipfileAbs, dir] (Just base) + hnd <- runProcess (programPath zipProg) ["-q", "-r", zipfileAbs, dir] + (Just tmpDir) Nothing Nothing Nothing Nothing exitCode <- waitForProcess hnd unless (exitCode == ExitSuccess) $ die $ "Generating the zip file failed " ++ "(zip returned exit code " ++ show exitCode ++ ")" + notice verbosity $ "Source zip archive created: " ++ zipfile where zipProgram = simpleProgram "zip" diff --git a/Distribution/Client/Tar.hs b/Distribution/Client/Tar.hs --- a/Distribution/Client/Tar.hs +++ b/Distribution/Client/Tar.hs @@ -21,6 +21,7 @@ -- * Converting between internal and external representation read, write, + writeEntries, -- * Packing and unpacking files to\/from internal representation pack, @@ -38,6 +39,11 @@ DevMinor, TypeCode, Format(..), + buildTreeRefTypeCode, + buildTreeSnapshotTypeCode, + isBuildTreeRefTypeCode, + entrySizeInBlocks, + entrySizeInBytes, -- * Constructing simple entry values simpleEntry, @@ -79,15 +85,15 @@ import qualified System.FilePath.Windows as FilePath.Windows import qualified System.FilePath.Posix as FilePath.Posix import System.Directory - ( getDirectoryContents, doesDirectoryExist, getModificationTime + ( getDirectoryContents, doesDirectoryExist , getPermissions, createDirectoryIfMissing, copyFile ) import qualified System.Directory as Permissions ( Permissions(executable) ) -import Distribution.Compat.FilePerms +import Distribution.Client.Compat.FilePerms ( setFileExecutable ) import System.Posix.Types ( FileMode ) -import Distribution.Compat.Time +import Distribution.Client.Compat.Time import System.IO ( IOMode(ReadMode), openBinaryFile, hFileSize ) import System.IO.Unsafe (unsafeInterleaveIO) @@ -110,8 +116,9 @@ -> FilePath -- ^ Expected subdir (to check for tarbombs) -> FilePath -- ^ Tarball -> IO () -extractTarGzFile dir expected tar = do - unpack dir . checkTarbomb expected . read . GZipUtils.maybeDecompress =<< BS.readFile tar +extractTarGzFile dir expected tar = + unpack dir . checkTarbomb expected . read + . GZipUtils.maybeDecompress =<< BS.readFile tar -- -- * Entry type @@ -148,11 +155,41 @@ entryFormat :: !Format } +-- | Type code for the local build tree reference entry type. We don't use the +-- symbolic link entry type because it allows only 100 ASCII characters for the +-- path. +buildTreeRefTypeCode :: TypeCode +buildTreeRefTypeCode = 'C' + +-- | Type code for the local build tree snapshot entry type. +buildTreeSnapshotTypeCode :: TypeCode +buildTreeSnapshotTypeCode = 'S' + +-- | Is this a type code for a build tree reference? +isBuildTreeRefTypeCode :: TypeCode -> Bool +isBuildTreeRefTypeCode typeCode + | (typeCode == buildTreeRefTypeCode + || typeCode == buildTreeSnapshotTypeCode) = True + | otherwise = False + -- | Native 'FilePath' of the file or directory within the archive. -- entryPath :: Entry -> FilePath entryPath = fromTarPath . entryTarPath +-- | Return the size of an entry in bytes. +entrySizeInBytes :: Entry -> FileSize +entrySizeInBytes = (*512) . fromIntegral . entrySizeInBlocks + +-- | Return the number of blocks in an entry. +entrySizeInBlocks :: Entry -> Int +entrySizeInBlocks entry = 1 + case entryContent entry of + NormalFile _ size -> bytesToBlocks size + OtherEntryType _ _ size -> bytesToBlocks size + _ -> 0 + where + bytesToBlocks s = 1 + ((fromIntegral s - 1) `div` 512) + -- | The content of a tar archive entry, which depends on the type of entry. -- -- Portable archives should contain only 'NormalFile' and 'Directory'. @@ -340,7 +377,7 @@ Right (name, []) -> Right (TarPath name "") Right (name, first:rest) -> case packName prefixMax remainder of Left err -> Left err - Right (_ , (_:_)) -> Left "File name too long (cannot split)" + Right (_ , _ : _) -> Left "File name too long (cannot split)" Right (prefix, []) -> Right (TarPath name prefix) where -- drop the '/' between the name and prefix: @@ -362,7 +399,7 @@ where n' = n + length c packName' _ _ ok cs = (FilePath.Posix.joinPath ok, cs) --- | The tar format allows just 100 ASCII charcters for the 'SymbolicLink' and +-- | The tar format allows just 100 ASCII characters for the 'SymbolicLink' and -- 'HardLink' entry types. -- newtype LinkTarget = LinkTarget FilePath @@ -472,7 +509,7 @@ | not (FilePath.Native.isValid name) = Just $ "Invalid file name in tar archive: " ++ show name - | any (=="..") (FilePath.Native.splitDirectories name) + | ".." `elem` FilePath.Native.splitDirectories name = Just $ "Invalid file name in tar archive: " ++ show name | otherwise = Nothing @@ -490,8 +527,10 @@ checkEntryTarbomb expectedTopDir entry = case FilePath.Native.splitDirectories (entryPath entry) of (topDir:_) | topDir == expectedTopDir -> Nothing - _ -> Just $ "File in tar archive is not in the expected directory " - ++ show expectedTopDir + s -> Just $ "File in tar archive is not in the expected directory. " + ++ "Expected: " ++ show expectedTopDir + ++ " but got the following hierarchy: " + ++ show s -- @@ -628,7 +667,8 @@ getChars off len = BS.Char8.unpack . getBytes off len getString :: Int64 -> Int64 -> ByteString -> String -getString off len = BS.Char8.unpack . BS.Char8.takeWhile (/='\0') . getBytes off len +getString off len = BS.Char8.unpack . BS.Char8.takeWhile (/='\0') + . getBytes off len data Partial a = Error String | Ok a @@ -654,6 +694,11 @@ write :: [Entry] -> ByteString write es = BS.concat $ map putEntry es ++ [BS.replicate (512*2) 0] +-- | Same as 'write', but for 'Entries'. +writeEntries :: Entries -> ByteString +writeEntries entries = BS.concat $ foldrEntries (\e res -> putEntry e : res) + [BS.replicate (512*2) 0] error entries + putEntry :: Entry -> ByteString putEntry entry = case entryContent entry of NormalFile content size -> BS.concat [ header, content, padding size ] @@ -666,12 +711,15 @@ putHeader :: Entry -> ByteString putHeader entry = - BS.Char8.pack $ take 148 block - ++ putOct 7 checksum - ++ ' ' : drop 156 block + BS.concat [ BS.take 148 block + , BS.Char8.pack $ putOct 7 checksum + , BS.Char8.singleton ' ' + , BS.drop 156 block ] where - block = putHeaderNoChkSum entry - checksum = foldl' (\x y -> x + ord y) 0 block + -- putHeaderNoChkSum returns a String, so we convert it to the final + -- representation before calculating the checksum. + block = BS.Char8.pack . putHeaderNoChkSum $ entry + checksum = BS.Char8.foldl' (\x y -> x + ord y) 0 block putHeaderNoChkSum :: Entry -> String putHeaderNoChkSum Entry { diff --git a/Distribution/Client/Targets.hs b/Distribution/Client/Targets.hs --- a/Distribution/Client/Targets.hs +++ b/Distribution/Client/Targets.hs @@ -708,17 +708,22 @@ --FIXME: use Text instance for FlagName and FlagAssignment instance Text UserConstraint where - disp (UserConstraintVersion pkgname verrange) = disp pkgname <+> disp verrange - disp (UserConstraintInstalled pkgname) = disp pkgname <+> Disp.text "installed" - disp (UserConstraintSource pkgname) = disp pkgname <+> Disp.text "source" - disp (UserConstraintFlags pkgname flags) = disp pkgname <+> dispFlagAssignment flags + disp (UserConstraintVersion pkgname verrange) = disp pkgname + <+> disp verrange + disp (UserConstraintInstalled pkgname) = disp pkgname + <+> Disp.text "installed" + disp (UserConstraintSource pkgname) = disp pkgname + <+> Disp.text "source" + disp (UserConstraintFlags pkgname flags) = disp pkgname + <+> dispFlagAssignment flags where dispFlagAssignment = Disp.hsep . map dispFlagValue dispFlagValue (f, True) = Disp.char '+' <> dispFlagName f dispFlagValue (f, False) = Disp.char '-' <> dispFlagName f dispFlagName (FlagName f) = Disp.text f - disp (UserConstraintStanzas pkgname stanzas) = disp pkgname <+> dispStanzas stanzas + disp (UserConstraintStanzas pkgname stanzas) = disp pkgname + <+> dispStanzas stanzas where dispStanzas = Disp.hsep . map dispStanza dispStanza TestStanzas = Disp.text "test" @@ -729,7 +734,7 @@ spaces = Parse.satisfy isSpace >> Parse.skipSpaces parseConstraint pkgname = - (parse >>= return . UserConstraintVersion pkgname) + ((parse >>= return . UserConstraintVersion pkgname) +++ (do spaces _ <- Parse.string "installed" return (UserConstraintInstalled pkgname)) @@ -741,7 +746,7 @@ return (UserConstraintStanzas pkgname [TestStanzas])) +++ (do spaces _ <- Parse.string "bench" - return (UserConstraintStanzas pkgname [BenchStanzas])) + return (UserConstraintStanzas pkgname [BenchStanzas]))) <++ (parseFlagAssignment >>= (return . UserConstraintFlags pkgname)) parseFlagAssignment = Parse.many1 (spaces >> parseFlagValue) diff --git a/Distribution/Client/Types.hs b/Distribution/Client/Types.hs --- a/Distribution/Client/Types.hs +++ b/Distribution/Client/Types.hs @@ -30,7 +30,7 @@ import Data.Map (Map) import Network.URI (URI) import Data.ByteString.Lazy (ByteString) -import Distribution.Compat.Exception +import Control.Exception ( SomeException ) newtype Username = Username { unUsername :: String } diff --git a/Distribution/Client/Unpack.hs b/Distribution/Client/Unpack.hs deleted file mode 100644 --- a/Distribution/Client/Unpack.hs +++ /dev/null @@ -1,138 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Unpack --- Copyright : (c) Andrea Vezzosi 2008 --- Duncan Coutts 2011 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- ------------------------------------------------------------------------------ -module Distribution.Client.Unpack ( - - -- * Commands - unpack, - - ) where - -import Distribution.Package - ( PackageId, packageId, packageName ) -import Distribution.Simple.Setup - ( fromFlag, fromFlagOrDefault ) -import Distribution.Simple.Utils - ( notice, die, info, writeFileAtomic ) -import Distribution.Verbosity - ( Verbosity ) -import Distribution.Text(display) - -import Distribution.Client.Setup - ( GlobalFlags(..), UnpackFlags(..) ) -import Distribution.Client.Types -import Distribution.Client.Targets -import Distribution.Client.Dependency -import Distribution.Client.FetchUtils -import qualified Distribution.Client.Tar as Tar (extractTarGzFile) -import Distribution.Client.IndexUtils as IndexUtils - ( getSourcePackages ) - -import System.Directory - ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist ) -import Control.Monad - ( unless, when ) -import Data.Monoid - ( mempty ) -import System.FilePath - ( (), (<.>), addTrailingPathSeparator ) -import qualified Data.ByteString.Lazy.Char8 as BS - ( unpack ) - -unpack :: Verbosity - -> [Repo] - -> GlobalFlags - -> UnpackFlags - -> [UserTarget] - -> IO () -unpack verbosity _ _ _ [] = - notice verbosity "No packages requested. Nothing to do." - -unpack verbosity repos globalFlags unpackFlags userTargets = do - mapM_ checkTarget userTargets - - sourcePkgDb <- getSourcePackages verbosity repos - - pkgSpecifiers <- resolveUserTargets verbosity - (fromFlag $ globalWorldFile globalFlags) - (packageIndex sourcePkgDb) - userTargets - - pkgs <- either (die . unlines . map show) return $ - resolveWithoutDependencies - (resolverParams sourcePkgDb pkgSpecifiers) - - unless (null prefix) $ - createDirectoryIfMissing True prefix - - flip mapM_ pkgs $ \pkg -> do - location <- fetchPackage verbosity (packageSource pkg) - let pkgid = packageId pkg - descOverride | usePristine = Nothing - | otherwise = packageDescrOverride pkg - case location of - LocalTarballPackage tarballPath -> - unpackPackage verbosity prefix pkgid descOverride tarballPath - - RemoteTarballPackage _tarballURL tarballPath -> - unpackPackage verbosity prefix pkgid descOverride tarballPath - - RepoTarballPackage _repo _pkgid tarballPath -> - unpackPackage verbosity prefix pkgid descOverride tarballPath - - LocalUnpackedPackage _ -> - error "Distribution.Client.Unpack.unpack: the impossible happened." - - where - resolverParams sourcePkgDb pkgSpecifiers = - --TODO: add commandline constraint and preference args for unpack - - standardInstallPolicy mempty sourcePkgDb pkgSpecifiers - - prefix = fromFlagOrDefault "" (unpackDestDir unpackFlags) - usePristine = fromFlagOrDefault False (unpackPristine unpackFlags) - -checkTarget :: UserTarget -> IO () -checkTarget target = case target of - UserTargetLocalDir dir -> die (notTarball dir) - UserTargetLocalCabalFile file -> die (notTarball file) - _ -> return () - where - notTarball t = - "The 'unpack' command is for tarball packages. " - ++ "The target '" ++ t ++ "' is not a tarball." - -unpackPackage :: Verbosity -> FilePath -> PackageId - -> PackageDescriptionOverride - -> FilePath -> IO () -unpackPackage verbosity prefix pkgid descOverride pkgPath = do - let pkgdirname = display pkgid - pkgdir = prefix pkgdirname - pkgdir' = addTrailingPathSeparator pkgdir - existsDir <- doesDirectoryExist pkgdir - when existsDir $ die $ - "The directory \"" ++ pkgdir' ++ "\" already exists, not unpacking." - existsFile <- doesFileExist pkgdir - when existsFile $ die $ - "A file \"" ++ pkgdir ++ "\" is in the way, not unpacking." - notice verbosity $ "Unpacking to " ++ pkgdir' - Tar.extractTarGzFile prefix pkgdirname pkgPath - - case descOverride of - Nothing -> return () - Just pkgtxt -> do - let descFilePath = pkgdir display (packageName pkgid) <.> "cabal" - info verbosity $ - "Updating " ++ descFilePath - ++ " with the latest revision from the index." - writeFileAtomic descFilePath (BS.unpack pkgtxt) diff --git a/Distribution/Client/Update.hs b/Distribution/Client/Update.hs --- a/Distribution/Client/Update.hs +++ b/Distribution/Client/Update.hs @@ -16,6 +16,8 @@ import Distribution.Client.Types ( Repo(..), RemoteRepo(..), LocalRepo(..), SourcePackageDb(..) ) +import Distribution.Client.HttpUtils + ( DownloadResult(..) ) import Distribution.Client.FetchUtils ( downloadIndex ) import qualified Distribution.Client.PackageIndex as PackageIndex @@ -29,21 +31,20 @@ import Distribution.Version ( anyVersion, withinRange ) import Distribution.Simple.Utils - ( warn, notice, writeFileAtomic ) + ( writeFileAtomic, warn, notice ) import Distribution.Verbosity ( Verbosity ) import qualified Data.ByteString.Lazy as BS -import qualified Data.ByteString.Lazy.Char8 as BS.Char8 import Distribution.Client.GZipUtils (maybeDecompress) import qualified Data.Map as Map import System.FilePath (dropExtension) import Data.Maybe (fromMaybe) -import Control.Monad (when) +import Control.Monad (unless) -- | 'update' downloads the package list from all known servers update :: Verbosity -> [Repo] -> IO () -update verbosity [] = do +update verbosity [] = warn verbosity $ "No remote package servers have been specified. Usually " ++ "you would have one specified in the config file." update verbosity repos = do @@ -56,11 +57,13 @@ Left remoteRepo -> do notice verbosity $ "Downloading the latest package list from " ++ remoteRepoName remoteRepo - indexPath <- downloadIndex verbosity remoteRepo (repoLocalDir repo) - writeFileAtomic (dropExtension indexPath) . BS.Char8.unpack - . maybeDecompress - =<< BS.readFile indexPath - updateRepoIndexCache verbosity repo + downloadResult <- downloadIndex verbosity remoteRepo (repoLocalDir repo) + case downloadResult of + FileAlreadyInCache -> return () + FileDownloaded indexPath -> do + writeFileAtomic (dropExtension indexPath) . maybeDecompress + =<< BS.readFile indexPath + updateRepoIndexCache verbosity repo checkForSelfUpgrade :: Verbosity -> [Repo] -> IO () checkForSelfUpgrade verbosity repos = do @@ -76,8 +79,7 @@ , version > currentVersion , version `withinRange` preferredVersionRange ] - when (not (null laterPreferredVersions)) $ + unless (null laterPreferredVersions) $ notice verbosity $ "Note: there is a new version of cabal-install available.\n" ++ "To upgrade, run: cabal install cabal-install" - diff --git a/Distribution/Client/Utils.hs b/Distribution/Client/Utils.hs --- a/Distribution/Client/Utils.hs +++ b/Distribution/Client/Utils.hs @@ -1,20 +1,41 @@ -{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE ForeignFunctionInterface, CPP #-} module Distribution.Client.Utils ( MergeResult(..) , mergeBy, duplicates, duplicatesBy - , moreRecentFile, inDir, numberOfProcessors ) + , inDir, numberOfProcessors + , removeExistingFile + , makeAbsoluteToCwd, filePathToByteString + , byteStringToFilePath, tryCanonicalizePath + , canonicalizePathNoThrow ) where +import Distribution.Compat.Exception ( catchIO ) +import qualified Data.ByteString.Lazy as BS +import Control.Monad + ( when ) +import Data.Bits + ( (.|.), shiftL, shiftR ) +import Data.Char + ( ord, chr ) import Data.List ( sortBy, groupBy ) +import Data.Word + ( Word8, Word32) import Foreign.C.Types ( CInt(..) ) -import System.Directory - ( doesFileExist, getModificationTime - , getCurrentDirectory, setCurrentDirectory ) -import System.IO.Unsafe ( unsafePerformIO ) import qualified Control.Exception as Exception ( finally ) +import System.Directory + ( canonicalizePath, doesFileExist, getCurrentDirectory + , removeFile, setCurrentDirectory ) +import System.FilePath + ( (), isAbsolute ) +import System.IO.Unsafe ( unsafePerformIO ) +#if defined(mingw32_HOST_OS) +import Control.Monad (liftM2, unless) +import System.Directory (doesDirectoryExist) +#endif + -- | Generic merging utility. For sorted input lists this is a full outer join. -- -- * The result list never contains @(Nothing, Nothing)@. @@ -44,22 +65,16 @@ moreThanOne (_:_:_) = True moreThanOne _ = False --- | Compare the modification times of two files to see if the first is newer --- than the second. The first file must exist but the second need not. --- The expected use case is when the second file is generated using the first. --- In this use case, if the result is True then the second file is out of date. --- -moreRecentFile :: FilePath -> FilePath -> IO Bool -moreRecentFile a b = do - exists <- doesFileExist b - if not exists - then return True - else do tb <- getModificationTime b - ta <- getModificationTime a - return (ta > tb) +-- | Like 'removeFile', but does not throw an exception when the file does not +-- exist. +removeExistingFile :: FilePath -> IO () +removeExistingFile path = do + exists <- doesFileExist path + when exists $ + removeFile path -- | Executes the action in the specified directory. -inDir :: Maybe FilePath -> IO () -> IO () +inDir :: Maybe FilePath -> IO a -> IO a inDir Nothing m = m inDir (Just d) m = do old <- getCurrentDirectory @@ -72,3 +87,65 @@ -- program, so unsafePerformIO is safe here. numberOfProcessors :: Int numberOfProcessors = fromEnum $ unsafePerformIO c_getNumberOfProcessors + +-- | Given a relative path, make it absolute relative to the current +-- directory. Absolute paths are returned unmodified. +makeAbsoluteToCwd :: FilePath -> IO FilePath +makeAbsoluteToCwd path | isAbsolute path = return path + | otherwise = do cwd <- getCurrentDirectory + return $! cwd path + +-- | Convert a 'FilePath' to a lazy 'ByteString'. Each 'Char' is +-- encoded as a little-endian 'Word32'. +filePathToByteString :: FilePath -> BS.ByteString +filePathToByteString p = + BS.pack $ foldr conv [] codepts + where + codepts :: [Word32] + codepts = map (fromIntegral . ord) p + + conv :: Word32 -> [Word8] -> [Word8] + conv w32 rest = b0:b1:b2:b3:rest + where + b0 = fromIntegral $ w32 + b1 = fromIntegral $ w32 `shiftR` 8 + b2 = fromIntegral $ w32 `shiftR` 16 + b3 = fromIntegral $ w32 `shiftR` 24 + +-- | Reverse operation to 'filePathToByteString'. +byteStringToFilePath :: BS.ByteString -> FilePath +byteStringToFilePath bs | bslen `mod` 4 /= 0 = unexpected + | otherwise = go 0 + where + unexpected = "Distribution.Client.Utils.byteStringToFilePath: unexpected" + bslen = BS.length bs + + go i | i == bslen = [] + | otherwise = (chr . fromIntegral $ w32) : go (i+4) + where + w32 :: Word32 + w32 = b0 .|. (b1 `shiftL` 8) .|. (b2 `shiftL` 16) .|. (b3 `shiftL` 24) + b0 = fromIntegral $ BS.index bs i + b1 = fromIntegral $ BS.index bs (i + 1) + b2 = fromIntegral $ BS.index bs (i + 2) + b3 = fromIntegral $ BS.index bs (i + 3) + +-- | Workaround for the inconsistent behaviour of 'canonicalizePath'. It throws +-- an error if the path refers to a non-existent file on *nix, but not on +-- Windows. +tryCanonicalizePath :: FilePath -> IO FilePath +tryCanonicalizePath path = do + ret <- canonicalizePath path +#if defined(mingw32_HOST_OS) + exists <- liftM2 (||) (doesFileExist ret) (doesDirectoryExist ret) + unless exists $ + error $ ret ++ ": canonicalizePath: does not exist " + ++ "(No such file or directory)" +#endif + return ret + +-- | A non-throwing wrapper for 'canonicalizePath'. If 'canonicalizePath' throws +-- an exception, returns the path argument unmodified. +canonicalizePathNoThrow :: FilePath -> IO FilePath +canonicalizePathNoThrow path = do + canonicalizePath path `catchIO` (\_ -> return path) diff --git a/Distribution/Client/Win32SelfUpgrade.hs b/Distribution/Client/Win32SelfUpgrade.hs --- a/Distribution/Client/Win32SelfUpgrade.hs +++ b/Distribution/Client/Win32SelfUpgrade.hs @@ -1,6 +1,4 @@ {-# LANGUAGE CPP, ForeignFunctionInterface #-} -{-# OPTIONS_NHC98 -cpp #-} -{-# OPTIONS_JHC -fcpp -fffi #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.Win32SelfUpgrade @@ -122,7 +120,7 @@ let args = mkArgs (show ourPID) tmpPath log $ "launching child " ++ unwords (dstPath : map show args) - runProcess dstPath args Nothing Nothing Nothing Nothing Nothing + _ <- runProcess dstPath args Nothing Nothing Nothing Nothing Nothing log $ "waiting for the child to start up" waitForSingleObject event (10*1000) -- wait at most 10 sec diff --git a/Distribution/Client/World.hs b/Distribution/Client/World.hs --- a/Distribution/Client/World.hs +++ b/Distribution/Client/World.hs @@ -102,7 +102,7 @@ all (`elem` pkgsNewWorld) pkgsOldWorld) then do info verbosity "Updating world file..." - writeFileAtomic world $ unlines + writeFileAtomic world . B.pack $ unlines [ (display pkg) | pkg <- pkgsNewWorld] else info verbosity "World file is already up to date." diff --git a/Distribution/Compat/Exception.hs b/Distribution/Compat/Exception.hs deleted file mode 100644 --- a/Distribution/Compat/Exception.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -cpp #-} -{-# OPTIONS_NHC98 -cpp #-} -{-# OPTIONS_JHC -fcpp #-} --- #hide -module Distribution.Compat.Exception ( - SomeException, - onException, - catchIO, - handleIO, - catchExit, - throwIOIO - ) where - -import System.Exit -import qualified Control.Exception as Exception -#if MIN_VERSION_base(4,0,0) -import Control.Exception (SomeException) -#else -import Control.Exception (Exception) -type SomeException = Exception -#endif - -onException :: IO a -> IO b -> IO a -#if MIN_VERSION_base(4,0,0) -onException = Exception.onException -#else -onException io what = io `Exception.catch` \e -> do what - Exception.throw e -#endif - -throwIOIO :: Exception.IOException -> IO a -#if MIN_VERSION_base(4,0,0) -throwIOIO = Exception.throwIO -#else -throwIOIO = Exception.throwIO . Exception.IOException -#endif - -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#if MIN_VERSION_base(4,0,0) -catchIO = Exception.catch -#else -catchIO = Exception.catchJust Exception.ioErrors -#endif - -handleIO :: (Exception.IOException -> IO a) -> IO a -> IO a -handleIO = flip catchIO - -catchExit :: IO a -> (ExitCode -> IO a) -> IO a -#if MIN_VERSION_base(4,0,0) -catchExit = Exception.catch -#else -catchExit = Exception.catchJust exitExceptions - where exitExceptions (Exception.ExitException ee) = Just ee - exitExceptions _ = Nothing -#endif diff --git a/Distribution/Compat/FilePerms.hs b/Distribution/Compat/FilePerms.hs deleted file mode 100644 --- a/Distribution/Compat/FilePerms.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE CPP #-} --- #hide -module Distribution.Compat.FilePerms ( - setFileOrdinary, - setFileExecutable, - ) where - -#ifndef mingw32_HOST_OS -import System.Posix.Types - ( FileMode ) -import System.Posix.Internals - ( c_chmod ) -import Foreign.C - ( withCString ) -#if MIN_VERSION_base(4,0,0) -import Foreign.C - ( throwErrnoPathIfMinus1_ ) -#else -import Foreign.C - ( throwErrnoIfMinus1_ ) -#endif -#endif /* mingw32_HOST_OS */ - -setFileOrdinary, setFileExecutable :: FilePath -> IO () -#ifndef mingw32_HOST_OS -setFileOrdinary path = setFileMode path 0o644 -- file perms -rw-r--r-- -setFileExecutable path = setFileMode path 0o755 -- file perms -rwxr-xr-x - -setFileMode :: FilePath -> FileMode -> IO () -setFileMode name m = - withCString name $ \s -> do -#if __GLASGOW_HASKELL__ >= 608 - throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m) -#else - throwErrnoIfMinus1_ name (c_chmod s m) -#endif -#else -setFileOrdinary _ = return () -setFileExecutable _ = return () -#endif diff --git a/Distribution/Compat/Time.hs b/Distribution/Compat/Time.hs deleted file mode 100644 --- a/Distribution/Compat/Time.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE CPP #-} -module Distribution.Compat.Time where - -import Data.Int (Int64) -import System.Directory (getModificationTime) - -#if MIN_VERSION_directory(1,2,0) -import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixDayLength) -import Data.Time (getCurrentTime, diffUTCTime) -#else -import System.Time (ClockTime(..), getClockTime, diffClockTimes, normalizeTimeDiff, tdDay) -#endif - --- | The number of seconds since the UNIX epoch -type EpochTime = Int64 - -getModTime :: FilePath -> IO EpochTime -getModTime path = do -#if MIN_VERSION_directory(1,2,0) - (truncate . utcTimeToPOSIXSeconds) `fmap` getModificationTime path -#else - (TOD s _) <- getModificationTime path - return $! fromIntegral s -#endif - --- | Return age of given file in days. -getFileAge :: FilePath -> IO Int -getFileAge file = do - t0 <- getModificationTime file -#if MIN_VERSION_directory(1,2,0) - t1 <- getCurrentTime - let days = truncate $ (t1 `diffUTCTime` t0) / posixDayLength -#else - t1 <- getClockTime - let days = (tdDay . normalizeTimeDiff) (t1 `diffClockTimes` t0) -#endif - return days diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -17,29 +17,36 @@ ( GlobalFlags(..), globalCommand, globalRepos , ConfigFlags(..) , ConfigExFlags(..), defaultConfigExFlags, configureExCommand + , BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..) + , buildCommand, testCommand, benchmarkCommand , InstallFlags(..), defaultInstallFlags , installCommand, upgradeCommand , FetchFlags(..), fetchCommand + , GetFlags(..), getCommand, unpackCommand , checkCommand , updateCommand , ListFlags(..), listCommand , InfoFlags(..), infoCommand , UploadFlags(..), uploadCommand , ReportFlags(..), reportCommand + , runCommand , InitFlags(initVerbosity), initCommand , SDistFlags(..), SDistExFlags(..), sdistCommand + , Win32SelfUpgradeFlags(..), win32SelfUpgradeCommand + , SandboxFlags(..), sandboxCommand , reportCommand - , unpackCommand, UnpackFlags(..) ) + ) import Distribution.Simple.Setup - ( BuildFlags(..), buildCommand - , HaddockFlags(..), haddockCommand + ( HaddockFlags(..), haddockCommand , HscolourFlags(..), hscolourCommand + , ReplFlags(..), replCommand , CopyFlags(..), copyCommand , RegisterFlags(..), registerCommand , CleanFlags(..), cleanCommand - , TestFlags(..), testCommand - , BenchmarkFlags(..), benchmarkCommand - , Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe ) + , TestFlags(..), BenchmarkFlags(..) + , Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe, toFlag + , configAbsolutePaths + ) import Distribution.Client.SetupWrapper ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) @@ -47,51 +54,91 @@ ( SavedConfig(..), loadConfig, defaultConfigFile ) import Distribution.Client.Targets ( readUserTargets ) +import qualified Distribution.Client.List as List + ( list, info ) -import Distribution.Client.List (list, info) -import Distribution.Client.Install (install, upgrade) -import Distribution.Client.Configure (configure) -import Distribution.Client.Update (update) -import Distribution.Client.Fetch (fetch) -import Distribution.Client.Check as Check (check) +import Distribution.Client.Install (install) +import Distribution.Client.Configure (configure) +import Distribution.Client.Update (update) +import Distribution.Client.Fetch (fetch) +import Distribution.Client.Check as Check (check) --import Distribution.Client.Clean (clean) -import Distribution.Client.Upload as Upload (upload, check, report) -import Distribution.Client.SrcDist (sdist) -import Distribution.Client.Unpack (unpack) -import Distribution.Client.Init (initCabal) +import Distribution.Client.Upload as Upload (upload, check, report) +import Distribution.Client.Run (run, splitRunArgs) +import Distribution.Client.SrcDist (sdist) +import Distribution.Client.Get (get) +import Distribution.Client.Sandbox (sandboxInit + ,sandboxAddSource + ,sandboxDelete + ,sandboxDeleteSource + ,sandboxListSources + ,sandboxHcPkg + ,dumpPackageEnvironment + + ,getSandboxConfigFilePath + ,loadConfigOrSandboxConfig + ,initPackageDBIfNeeded + ,maybeWithSandboxDirOnSearchPath + ,maybeWithSandboxPackageInfo + ,WereDepsReinstalled(..) + ,maybeReinstallAddSourceDeps + ,tryGetIndexFilePath + ,sandboxBuildDir + + ,configCompilerAux' + ,configPackageDB') +import Distribution.Client.Sandbox.PackageEnvironment + (setPackageDB + ,userPackageEnvironmentFile) +import Distribution.Client.Sandbox.Timestamp (maybeAddCompilerTimestampRecord) +import Distribution.Client.Sandbox.Types (UseSandbox(..), whenUsingSandbox) +import Distribution.Client.Init (initCabal) import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade -import Distribution.Simple.Compiler - ( Compiler, PackageDBStack ) -import Distribution.Simple.Program - ( ProgramConfiguration, defaultProgramConfiguration ) +import Distribution.PackageDescription + ( Executable(..) ) import Distribution.Simple.Command + ( CommandParse(..), CommandUI(..), Command + , commandsRun, commandAddAction, hiddenCommand ) +import Distribution.Simple.Compiler + ( Compiler(..) ) import Distribution.Simple.Configure - ( configCompilerAux, interpretPackageDbFlags ) + ( checkPersistBuildConfigOutdated, configCompilerAuxEx + , ConfigStateFileErrorType(..), localBuildInfoFile + , getPersistBuildConfig, tryGetPersistBuildConfig ) +import qualified Distribution.Simple.LocalBuildInfo as LBI +import Distribution.Simple.Program (defaultProgramConfiguration) +import qualified Distribution.Simple.Setup as Cabal import Distribution.Simple.Utils - ( cabalVersion, die, topHandler, intercalate ) + ( cabalVersion, die, notice, info, moreRecentFile, topHandler ) import Distribution.Text ( display ) import Distribution.Verbosity as Verbosity - ( Verbosity, normal, intToVerbosity, lessVerbose ) + ( Verbosity, normal ) +import Distribution.Version + ( Version(..), orLaterVersion ) import qualified Paths_cabal_install_bundle (version) import System.Environment (getArgs, getProgName) import System.Exit (exitFailure) import System.FilePath (splitExtension, takeExtension) +import System.IO (BufferMode(LineBuffering), + hSetBuffering, stdout) import System.Directory (doesFileExist) -import Data.List (intersperse) -import Data.Maybe (fromMaybe) +import Data.List (intercalate) import Data.Monoid (Monoid(..)) -import Control.Monad (unless) +import Control.Monad (when, unless) -- | Entry point -- main :: IO () -main = getArgs >>= mainWorker +main = do + -- Enable line buffering so that we can get fast feedback even when piped. + -- This is especially important for CI and build systems. + hSetBuffering stdout LineBuffering + getArgs >>= mainWorker mainWorker :: [String] -> IO () -mainWorker ("win32selfupgrade":args) = win32SelfUpgradeAction args mainWorker args = topHandler $ case commandsRun globalCommand commands args of CommandHelp help -> printGlobalHelp help @@ -116,8 +163,12 @@ putStr (help pname) putStr $ "\nYou can edit the cabal configuration file to set defaults:\n" ++ " " ++ configFile ++ "\n" + exists <- doesFileExist configFile + when (not exists) $ + putStrLn $ "This file will be generated with sensible " + ++ "defaults if you run 'cabal update'." printOptionsList = putStr . unlines - printErrors errs = die $ concat (intersperse "\n" errs) + printErrors errs = die $ intercalate "\n" errs printNumericVersion = putStrLn $ display Paths_cabal_install_bundle.version printVersion = putStrLn $ "cabal-install version " ++ display Paths_cabal_install_bundle.version @@ -131,15 +182,20 @@ ,listCommand `commandAddAction` listAction ,infoCommand `commandAddAction` infoAction ,fetchCommand `commandAddAction` fetchAction - ,unpackCommand `commandAddAction` unpackAction + ,getCommand `commandAddAction` getAction + ,hiddenCommand $ + unpackCommand `commandAddAction` unpackAction ,checkCommand `commandAddAction` checkAction ,sdistCommand `commandAddAction` sdistAction ,uploadCommand `commandAddAction` uploadAction ,reportCommand `commandAddAction` reportAction + ,runCommand `commandAddAction` runAction ,initCommand `commandAddAction` initAction ,configureExCommand `commandAddAction` configureAction - ,wrapperAction (buildCommand defaultProgramConfiguration) - buildVerbosity buildDistPref + ,buildCommand `commandAddAction` buildAction + ,replCommand defaultProgramConfiguration + `commandAddAction` replAction + ,sandboxCommand `commandAddAction` sandboxAction ,wrapperAction copyCommand copyVerbosity copyDistPref ,wrapperAction haddockCommand @@ -150,11 +206,12 @@ hscolourVerbosity hscolourDistPref ,wrapperAction registerCommand regVerbosity regDistPref - ,wrapperAction testCommand - testVerbosity testDistPref - ,wrapperAction benchmarkCommand - benchmarkVerbosity benchmarkDistPref - ,upgradeCommand `commandAddAction` upgradeAction + ,testCommand `commandAddAction` testAction + ,benchmarkCommand `commandAddAction` benchmarkAction + ,hiddenCommand $ + upgradeCommand `commandAddAction` upgradeAction + ,hiddenCommand $ + win32SelfUpgradeCommand`commandAddAction` win32SelfUpgradeAction ] wrapperAction :: Monoid flags @@ -178,16 +235,319 @@ -> [String] -> GlobalFlags -> IO () configureAction (configFlags, configExFlags) extraArgs globalFlags = do let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - config <- loadConfig verbosity (globalConfigFile globalFlags) - (configUserInstall configFlags) + + (useSandbox, config) <- loadConfigOrSandboxConfig verbosity + globalFlags (configUserInstall configFlags) let configFlags' = savedConfigureFlags config `mappend` configFlags configExFlags' = savedConfigureExFlags config `mappend` configExFlags globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, conf) <- configCompilerAux configFlags' - configure verbosity - (configPackageDB' configFlags') (globalRepos globalFlags') - comp conf configFlags' configExFlags' extraArgs + (comp, platform, conf) <- configCompilerAuxEx configFlags' + -- If we're working inside a sandbox and the user has set the -w option, we + -- may need to create a sandbox-local package DB for this compiler and add a + -- timestamp record for this compiler to the timestamp file. + let configFlags'' = case useSandbox of + NoSandbox -> configFlags' + (UseSandbox sandboxDir) -> setPackageDB sandboxDir + comp platform configFlags' + + whenUsingSandbox useSandbox $ \sandboxDir -> do + initPackageDBIfNeeded verbosity configFlags'' comp conf + + indexFile <- tryGetIndexFilePath config + maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile + (compilerId comp) platform + + maybeWithSandboxDirOnSearchPath useSandbox $ + configure verbosity + (configPackageDB' configFlags'') + (globalRepos globalFlags') + comp platform conf configFlags'' configExFlags' extraArgs + +buildAction :: (BuildFlags, BuildExFlags) -> [String] -> GlobalFlags -> IO () +buildAction (buildFlags, buildExFlags) extraArgs globalFlags = do + let distPref = fromFlagOrDefault (useDistPref defaultSetupScriptOptions) + (buildDistPref buildFlags) + verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags) + noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck + (buildOnly buildExFlags) + + -- Calls 'configureAction' to do the real work, so nothing special has to be + -- done to support sandboxes. + useSandbox <- reconfigure verbosity distPref + mempty [] globalFlags noAddSource (buildNumJobs buildExFlags) + (const Nothing) + + maybeWithSandboxDirOnSearchPath useSandbox $ + build verbosity distPref buildFlags extraArgs + + +-- | Actually do the work of building the package. This is separate from +-- 'buildAction' so that 'testAction' and 'benchmarkAction' do not invoke +-- 'reconfigure' twice. +build :: Verbosity -> FilePath -> BuildFlags -> [String] -> IO () +build verbosity distPref buildFlags extraArgs = + setupWrapper verbosity setupOptions Nothing + (Cabal.buildCommand progConf) (const buildFlags') extraArgs + where + progConf = defaultProgramConfiguration + setupOptions = defaultSetupScriptOptions { useDistPref = distPref } + buildFlags' = buildFlags + { buildVerbosity = toFlag verbosity + , buildDistPref = toFlag distPref + } + +replAction :: ReplFlags -> [String] -> GlobalFlags -> IO () +replAction replFlags extraArgs globalFlags = do + let distPref = fromFlagOrDefault (useDistPref defaultSetupScriptOptions) + (replDistPref replFlags) + verbosity = fromFlagOrDefault normal (replVerbosity replFlags) + noAddSource = case replReload replFlags of + Flag True -> SkipAddSourceDepsCheck + _ -> DontSkipAddSourceDepsCheck + + -- Calls 'configureAction' to do the real work, so nothing special has to be + -- done to support sandboxes. + useSandbox <- reconfigure verbosity distPref + mempty [] globalFlags noAddSource NoFlag + (const Nothing) + + maybeWithSandboxDirOnSearchPath useSandbox $ + let progConf = defaultProgramConfiguration + setupOptions = defaultSetupScriptOptions + { useCabalVersion = orLaterVersion $ Version [1,18,0] [] + , useDistPref = distPref + } + replFlags' = replFlags + { replVerbosity = toFlag verbosity + , replDistPref = toFlag distPref + } + in setupWrapper verbosity setupOptions Nothing + (Cabal.replCommand progConf) (const replFlags') extraArgs + + +-- | Re-configure the package in the current directory if needed. Deciding +-- when to reconfigure and with which options is convoluted: +-- +-- If we are reconfiguring, we must always run @configure@ with the +-- verbosity option we are given; however, that a previous configuration +-- uses a different verbosity setting is not reason enough to reconfigure. +-- +-- The package should be configured to use the same \"dist\" prefix as +-- given to the @build@ command, otherwise the build will probably +-- fail. Not only does this determine the \"dist\" prefix setting if we +-- need to reconfigure anyway, but an existing configuration should be +-- invalidated if its \"dist\" prefix differs. +-- +-- If the package has never been configured (i.e., there is no +-- LocalBuildInfo), we must configure first, using the default options. +-- +-- If the package has been configured, there will be a 'LocalBuildInfo'. +-- If there no package description file, we assume that the +-- 'PackageDescription' is up to date, though the configuration may need +-- to be updated for other reasons (see above). If there is a package +-- description file, and it has been modified since the 'LocalBuildInfo' +-- was generated, then we need to reconfigure. +-- +-- The caller of this function may also have specific requirements +-- regarding the flags the last configuration used. For example, +-- 'testAction' requires that the package be configured with test suites +-- enabled. The caller may pass the required settings to this function +-- along with a function to check the validity of the saved 'ConfigFlags'; +-- these required settings will be checked first upon determining that +-- a previous configuration exists. +reconfigure :: Verbosity -- ^ Verbosity setting + -> FilePath -- ^ \"dist\" prefix + -> ConfigFlags -- ^ Additional config flags to set. These flags + -- will be 'mappend'ed to the last used or + -- default 'ConfigFlags' as appropriate, so + -- this value should be 'mempty' with only the + -- required flags set. The required verbosity + -- and \"dist\" prefix flags will be set + -- automatically because they are always + -- required; therefore, it is not necessary to + -- set them here. + -> [String] -- ^ Extra arguments + -> GlobalFlags -- ^ Global flags + -> SkipAddSourceDepsCheck + -- ^ Should we skip the timestamp check for modified + -- add-source dependencies? + -> Flag (Maybe Int) + -- ^ -j flag for reinstalling add-source deps. + -> (ConfigFlags -> Maybe String) + -- ^ Check that the required flags are set in + -- the last used 'ConfigFlags'. If the required + -- flags are not set, provide a message to the + -- user explaining the reason for + -- reconfiguration. Because the correct \"dist\" + -- prefix setting is always required, it is checked + -- automatically; this function need not check + -- for it. + -> IO UseSandbox +reconfigure verbosity distPref addConfigFlags extraArgs globalFlags + skipAddSourceDepsCheck numJobsFlag checkFlags = do + eLbi <- tryGetPersistBuildConfig distPref + case eLbi of + Left (err, errCode) -> onNoBuildConfig err errCode + Right lbi -> onBuildConfig lbi + + where + + -- We couldn't load the saved package config file. + -- + -- If we're in a sandbox: add-source deps don't have to be reinstalled + -- (since we don't know the compiler & platform). + onNoBuildConfig :: String -> ConfigStateFileErrorType -> IO UseSandbox + onNoBuildConfig err errCode = do + let msg = case errCode of + ConfigStateFileMissing -> "Package has never been configured." + ConfigStateFileCantParse -> "Saved package config file seems " + ++ "to be corrupt." + ConfigStateFileBadVersion -> err + case errCode of + ConfigStateFileBadVersion -> info verbosity msg + _ -> do + notice verbosity + $ msg ++ " Configuring with default flags." ++ configureManually + configureAction (defaultFlags, defaultConfigExFlags) + extraArgs globalFlags + (useSandbox, _) <- loadConfigOrSandboxConfig verbosity globalFlags mempty + return useSandbox + + -- Package has been configured, but the configuration may be out of + -- date or required flags may not be set. + -- + -- If we're in a sandbox: reinstall the modified add-source deps and + -- force reconfigure if we did. + onBuildConfig :: LBI.LocalBuildInfo -> IO UseSandbox + onBuildConfig lbi = do + let configFlags = LBI.configFlags lbi + flags = mconcat [configFlags, addConfigFlags, distVerbFlags] + + -- Was the sandbox created after the package was already configured? We + -- may need to skip reinstallation of add-source deps and force + -- reconfigure. + let buildConfig = localBuildInfoFile distPref + sandboxConfig <- getSandboxConfigFilePath globalFlags + isSandboxConfigNewer <- + sandboxConfig `existsAndIsMoreRecentThan` buildConfig + + let skipAddSourceDepsCheck' + | isSandboxConfigNewer = SkipAddSourceDepsCheck + | otherwise = skipAddSourceDepsCheck + + (useSandbox, depsReinstalled) <- + case skipAddSourceDepsCheck' of + DontSkipAddSourceDepsCheck -> + maybeReinstallAddSourceDeps verbosity numJobsFlag flags globalFlags + SkipAddSourceDepsCheck -> do + (useSandbox, _) <- loadConfigOrSandboxConfig verbosity + globalFlags mempty + return (useSandbox, NoDepsReinstalled) + + -- Is the @cabal.config@ file newer than @dist/setup.config@? Then we need + -- to force reconfigure. Note that it's possible to use @cabal.config@ + -- even without sandboxes. + isUserPackageEnvironmentFileNewer <- + userPackageEnvironmentFile `existsAndIsMoreRecentThan` buildConfig + + -- Determine whether we need to reconfigure and which message to show to + -- the user if that is the case. + mMsg <- determineMessageToShow lbi configFlags depsReinstalled + isSandboxConfigNewer + isUserPackageEnvironmentFileNewer + case mMsg of + + -- No message for the user indicates that reconfiguration + -- is not required. + Nothing -> return useSandbox + + -- Show the message and reconfigure. + Just msg -> do + notice verbosity msg + configureAction (flags, defaultConfigExFlags) + extraArgs globalFlags + return useSandbox + + -- True if the first file exists and is more recent than the second file. + existsAndIsMoreRecentThan :: FilePath -> FilePath -> IO Bool + existsAndIsMoreRecentThan a b = do + exists <- doesFileExist a + if not exists + then return False + else a `moreRecentFile` b + + -- Determine what message, if any, to display to the user if reconfiguration + -- is required. + determineMessageToShow :: LBI.LocalBuildInfo -> ConfigFlags + -> WereDepsReinstalled -> Bool -> Bool + -> IO (Maybe String) + determineMessageToShow _ _ _ True _ = + -- The sandbox was created after the package was already configured. + return $! Just $! sandboxConfigNewerMessage + + determineMessageToShow _ _ _ False True = + -- The user package environment file was modified. + return $! Just $! userPackageEnvironmentFileModifiedMessage + + determineMessageToShow lbi configFlags depsReinstalled False False = do + let savedDistPref = fromFlagOrDefault + (useDistPref defaultSetupScriptOptions) + (configDistPref configFlags) + case depsReinstalled of + ReinstalledSomeDeps -> + -- Some add-source deps were reinstalled. + return $! Just $! reinstalledDepsMessage + NoDepsReinstalled -> + case checkFlags configFlags of + -- Flag required by the caller is not set. + Just msg -> return $! Just $! msg ++ configureManually + + Nothing + -- Required "dist" prefix is not set. + | savedDistPref /= distPref -> + return $! Just distPrefMessage + + -- All required flags are set, but the configuration + -- may be outdated. + | otherwise -> case LBI.pkgDescrFile lbi of + Nothing -> return Nothing + Just pdFile -> do + outdated <- checkPersistBuildConfigOutdated + distPref pdFile + return $! if outdated + then Just $! outdatedMessage pdFile + else Nothing + + defaultFlags = mappend addConfigFlags distVerbFlags + distVerbFlags = mempty + { configVerbosity = toFlag verbosity + , configDistPref = toFlag distPref + } + reconfiguringMostRecent = " Re-configuring with most recently used options." + configureManually = " If this fails, please run configure manually." + sandboxConfigNewerMessage = + "The sandbox was created after the package was already configured." + ++ reconfiguringMostRecent + ++ configureManually + userPackageEnvironmentFileModifiedMessage = + "The user package environment file ('" + ++ userPackageEnvironmentFile ++ "') was modified." + ++ reconfiguringMostRecent + ++ configureManually + distPrefMessage = + "Package previously configured with different \"dist\" prefix." + ++ reconfiguringMostRecent + ++ configureManually + outdatedMessage pdFile = + pdFile ++ " has been changed." + ++ reconfiguringMostRecent + ++ configureManually + reinstalledDepsMessage = + "Some add-source dependencies have been reinstalled." + ++ reconfiguringMostRecent + ++ configureManually + installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> GlobalFlags -> IO () installAction (configFlags, _, installFlags, _) _ _globalFlags @@ -199,29 +559,126 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags) extraArgs globalFlags = do let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + (useSandbox, config) <- loadConfigOrSandboxConfig verbosity + globalFlags (configUserInstall configFlags) targets <- readUserTargets verbosity extraArgs - config <- loadConfig verbosity (globalConfigFile globalFlags) - (configUserInstall configFlags) - let configFlags' = savedConfigureFlags config `mappend` configFlags - configExFlags' = defaultConfigExFlags `mappend` - savedConfigureExFlags config `mappend` configExFlags - installFlags' = defaultInstallFlags `mappend` - savedInstallFlags config `mappend` installFlags - globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, conf) <- configCompilerAux' configFlags' - install verbosity - (configPackageDB' configFlags') (globalRepos globalFlags') - comp conf globalFlags' configFlags' configExFlags' installFlags' haddockFlags - targets + -- TODO: It'd be nice if 'cabal install' picked up the '-w' flag passed to + -- 'configure' when run inside a sandbox. Right now, running + -- + -- $ cabal sandbox init && cabal configure -w /path/to/ghc + -- && cabal build && cabal install + -- + -- performs the compilation twice unless you also pass -w to 'install'. + -- However, this is the same behaviour that 'cabal install' has in the normal + -- mode of operation, so we stick to it for consistency. + + let sandboxDistPref = case useSandbox of + NoSandbox -> NoFlag + UseSandbox sandboxDir -> Flag $ sandboxBuildDir sandboxDir + configFlags' = savedConfigureFlags config `mappend` configFlags + configExFlags' = defaultConfigExFlags `mappend` + savedConfigureExFlags config `mappend` configExFlags + installFlags' = defaultInstallFlags `mappend` + savedInstallFlags config `mappend` installFlags + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, platform, conf) <- configCompilerAux' configFlags' + + -- If we're working inside a sandbox and the user has set the -w option, we + -- may need to create a sandbox-local package DB for this compiler and add a + -- timestamp record for this compiler to the timestamp file. + configFlags'' <- case useSandbox of + NoSandbox -> configAbsolutePaths $ configFlags' + (UseSandbox sandboxDir) -> + return $ (setPackageDB sandboxDir comp platform configFlags') { + configDistPref = sandboxDistPref + } + + whenUsingSandbox useSandbox $ \sandboxDir -> do + initPackageDBIfNeeded verbosity configFlags'' comp conf + + indexFile <- tryGetIndexFilePath config + maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile + (compilerId comp) platform + + -- FIXME: Passing 'SandboxPackageInfo' to install unconditionally here means + -- that 'cabal install some-package' inside a sandbox will sometimes reinstall + -- modified add-source deps, even if they are not among the dependencies of + -- 'some-package'. This can also prevent packages that depend on older + -- versions of add-source'd packages from building (see #1362). + maybeWithSandboxPackageInfo verbosity configFlags'' globalFlags' + comp platform conf useSandbox $ \mSandboxPkgInfo -> + maybeWithSandboxDirOnSearchPath useSandbox $ + install verbosity + (configPackageDB' configFlags'') + (globalRepos globalFlags') + comp platform conf + useSandbox mSandboxPkgInfo + globalFlags' configFlags'' configExFlags' + installFlags' haddockFlags + targets + +testAction :: (TestFlags, BuildExFlags) -> [String] -> GlobalFlags -> IO () +testAction (testFlags, buildExFlags) extraArgs globalFlags = do + let verbosity = fromFlagOrDefault normal (testVerbosity testFlags) + distPref = fromFlagOrDefault (useDistPref defaultSetupScriptOptions) + (testDistPref testFlags) + setupOptions = defaultSetupScriptOptions { useDistPref = distPref } + addConfigFlags = mempty { configTests = toFlag True } + checkFlags flags + | fromFlagOrDefault False (configTests flags) = Nothing + | otherwise = Just "Re-configuring with test suites enabled." + noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck + (buildOnly buildExFlags) + + -- reconfigure also checks if we're in a sandbox and reinstalls add-source + -- deps if needed. + useSandbox <- reconfigure verbosity distPref addConfigFlags [] + globalFlags noAddSource (buildNumJobs buildExFlags) checkFlags + + maybeWithSandboxDirOnSearchPath useSandbox $ + build verbosity distPref mempty extraArgs + + maybeWithSandboxDirOnSearchPath useSandbox $ + setupWrapper verbosity setupOptions Nothing + Cabal.testCommand (const testFlags) extraArgs + +benchmarkAction :: (BenchmarkFlags, BuildExFlags) -> [String] -> GlobalFlags + -> IO () +benchmarkAction (benchmarkFlags, buildExFlags) extraArgs globalFlags = do + let verbosity = fromFlagOrDefault normal + (benchmarkVerbosity benchmarkFlags) + distPref = fromFlagOrDefault (useDistPref defaultSetupScriptOptions) + (benchmarkDistPref benchmarkFlags) + setupOptions = defaultSetupScriptOptions { useDistPref = distPref } + addConfigFlags = mempty { configBenchmarks = toFlag True } + checkFlags flags + | fromFlagOrDefault False (configBenchmarks flags) = Nothing + | otherwise = Just "Re-configuring with benchmarks enabled." + noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck + (buildOnly buildExFlags) + + -- reconfigure also checks if we're in a sandbox and reinstalls add-source + -- deps if needed. + useSandbox <- reconfigure verbosity distPref addConfigFlags [] + globalFlags noAddSource (buildNumJobs buildExFlags) + checkFlags + + maybeWithSandboxDirOnSearchPath useSandbox $ + build verbosity distPref mempty extraArgs + + maybeWithSandboxDirOnSearchPath useSandbox $ + setupWrapper verbosity setupOptions Nothing + Cabal.benchmarkCommand (const benchmarkFlags) extraArgs + listAction :: ListFlags -> [String] -> GlobalFlags -> IO () listAction listFlags extraArgs globalFlags = do let verbosity = fromFlag (listVerbosity listFlags) - config <- loadConfig verbosity (globalConfigFile globalFlags) mempty + (_, config) <- loadConfigOrSandboxConfig verbosity globalFlags mempty let configFlags = savedConfigureFlags config globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, conf) <- configCompilerAux' configFlags - list verbosity + (comp, _, conf) <- configCompilerAux' configFlags + List.list verbosity (configPackageDB' configFlags) (globalRepos globalFlags') comp @@ -233,11 +690,11 @@ infoAction infoFlags extraArgs globalFlags = do let verbosity = fromFlag (infoVerbosity infoFlags) targets <- readUserTargets verbosity extraArgs - config <- loadConfig verbosity (globalConfigFile globalFlags) mempty + (_, config) <- loadConfigOrSandboxConfig verbosity globalFlags mempty let configFlags = savedConfigureFlags config globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, conf) <- configCompilerAux configFlags - info verbosity + (comp, _, conf) <- configCompilerAuxEx configFlags + List.info verbosity (configPackageDB' configFlags) (globalRepos globalFlags') comp @@ -248,7 +705,7 @@ updateAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO () updateAction verbosityFlag extraArgs globalFlags = do - unless (null extraArgs) $ do + unless (null extraArgs) $ die $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs let verbosity = fromFlag verbosityFlag config <- loadConfig verbosity (globalConfigFile globalFlags) mempty @@ -257,22 +714,18 @@ upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> GlobalFlags -> IO () -upgradeAction (configFlags, configExFlags, installFlags, haddockFlags) - extraArgs globalFlags = do - let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - targets <- readUserTargets verbosity extraArgs - config <- loadConfig verbosity (globalConfigFile globalFlags) - (configUserInstall configFlags) - let configFlags' = savedConfigureFlags config `mappend` configFlags - configExFlags' = savedConfigureExFlags config `mappend` configExFlags - installFlags' = defaultInstallFlags `mappend` - savedInstallFlags config `mappend` installFlags - globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, conf) <- configCompilerAux' configFlags' - upgrade verbosity - (configPackageDB' configFlags') (globalRepos globalFlags') - comp conf globalFlags' configFlags' configExFlags' installFlags' haddockFlags - targets +upgradeAction _ _ _ = die $ + "Use the 'cabal install' command instead of 'cabal upgrade'.\n" + ++ "You can install the latest version of a package using 'cabal install'. " + ++ "The 'cabal upgrade' command has been removed because people found it " + ++ "confusing and it often led to broken packages.\n" + ++ "If you want the old upgrade behaviour then use the install command " + ++ "with the --upgrade-dependencies flag (but check first with --dry-run " + ++ "to see what would happen). This will try to pick the latest versions " + ++ "of all dependencies, rather than the usual behaviour of trying to pick " + ++ "installed versions of all dependencies. If you do use " + ++ "--upgrade-dependencies, it is recommended that you do not upgrade core " + ++ "packages (e.g. by using appropriate --constraint= flags)." fetchAction :: FetchFlags -> [String] -> GlobalFlags -> IO () fetchAction fetchFlags extraArgs globalFlags = do @@ -281,10 +734,11 @@ config <- loadConfig verbosity (globalConfigFile globalFlags) mempty let configFlags = savedConfigureFlags config globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, conf) <- configCompilerAux' configFlags + (comp, platform, conf) <- configCompilerAux' configFlags fetch verbosity - (configPackageDB' configFlags) (globalRepos globalFlags') - comp conf globalFlags' fetchFlags + (configPackageDB' configFlags) + (globalRepos globalFlags') + comp platform conf globalFlags' fetchFlags targets uploadAction :: UploadFlags -> [String] -> GlobalFlags -> IO () @@ -321,7 +775,7 @@ checkAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO () checkAction verbosityFlag extraArgs _globalFlags = do - unless (null extraArgs) $ do + unless (null extraArgs) $ die $ "'check' doesn't take any extra arguments: " ++ unwords extraArgs allOk <- Check.check (fromFlag verbosityFlag) unless allOk exitFailure @@ -329,13 +783,13 @@ sdistAction :: (SDistFlags, SDistExFlags) -> [String] -> GlobalFlags -> IO () sdistAction (sdistFlags, sdistExFlags) extraArgs _globalFlags = do - unless (null extraArgs) $ do + unless (null extraArgs) $ die $ "'sdist' doesn't take any extra arguments: " ++ unwords extraArgs sdist sdistFlags sdistExFlags reportAction :: ReportFlags -> [String] -> GlobalFlags -> IO () reportAction reportFlags extraArgs globalFlags = do - unless (null extraArgs) $ do + unless (null extraArgs) $ die $ "'report' doesn't take any extra arguments: " ++ unwords extraArgs let verbosity = fromFlag (reportVerbosity reportFlags) @@ -347,55 +801,97 @@ (flagToMaybe $ reportUsername reportFlags') (flagToMaybe $ reportPassword reportFlags') -unpackAction :: UnpackFlags -> [String] -> GlobalFlags -> IO () -unpackAction unpackFlags extraArgs globalFlags = do - let verbosity = fromFlag (unpackVerbosity unpackFlags) +runAction :: (BuildFlags, BuildExFlags) -> [String] -> GlobalFlags -> IO () +runAction (buildFlags, buildExFlags) extraArgs globalFlags = do + let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags) + distPref = fromFlagOrDefault (useDistPref defaultSetupScriptOptions) + (buildDistPref buildFlags) + noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck + (buildOnly buildExFlags) + + -- reconfigure also checks if we're in a sandbox and reinstalls add-source + -- deps if needed. + useSandbox <- reconfigure verbosity distPref mempty [] + globalFlags noAddSource (buildNumJobs buildExFlags) + (const Nothing) + + lbi <- getPersistBuildConfig distPref + (exe, exeArgs) <- splitRunArgs lbi extraArgs + + maybeWithSandboxDirOnSearchPath useSandbox $ + build verbosity distPref mempty ["exe:" ++ exeName exe] + + maybeWithSandboxDirOnSearchPath useSandbox $ + run verbosity lbi exe exeArgs + +getAction :: GetFlags -> [String] -> GlobalFlags -> IO () +getAction getFlags extraArgs globalFlags = do + let verbosity = fromFlag (getVerbosity getFlags) targets <- readUserTargets verbosity extraArgs config <- loadConfig verbosity (globalConfigFile globalFlags) mempty let globalFlags' = savedGlobalFlags config `mappend` globalFlags - unpack verbosity - (globalRepos (savedGlobalFlags config)) - globalFlags' - unpackFlags - targets + get verbosity + (globalRepos (savedGlobalFlags config)) + globalFlags' + getFlags + targets +unpackAction :: GetFlags -> [String] -> GlobalFlags -> IO () +unpackAction getFlags extraArgs globalFlags = do + getAction getFlags extraArgs globalFlags + initAction :: InitFlags -> [String] -> GlobalFlags -> IO () initAction initFlags _extraArgs globalFlags = do let verbosity = fromFlag (initVerbosity initFlags) config <- loadConfig verbosity (globalConfigFile globalFlags) mempty let configFlags = savedConfigureFlags config - (comp, conf) <- configCompilerAux' configFlags + (comp, _, conf) <- configCompilerAux' configFlags initCabal verbosity (configPackageDB' configFlags) comp conf initFlags --- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details. --- -win32SelfUpgradeAction :: [String] -> IO () -win32SelfUpgradeAction (pid:path:rest) = - Win32SelfUpgrade.deleteOldExeFile verbosity (read pid) path - where - verbosity = case rest of - (['-','-','v','e','r','b','o','s','e','=',n]:_) | n `elem` ['0'..'9'] - -> fromMaybe Verbosity.normal (Verbosity.intToVerbosity (read [n])) - _ -> Verbosity.normal -win32SelfUpgradeAction _ = return () +sandboxAction :: SandboxFlags -> [String] -> GlobalFlags -> IO () +sandboxAction sandboxFlags extraArgs globalFlags = do + let verbosity = fromFlag (sandboxVerbosity sandboxFlags) + case extraArgs of + -- Basic sandbox commands. + ["init"] -> sandboxInit verbosity sandboxFlags globalFlags + ["delete"] -> sandboxDelete verbosity sandboxFlags globalFlags + ("add-source":extra) -> do + when (noExtraArgs extra) $ + die "The 'sandbox add-source' command expects at least one argument" + sandboxAddSource verbosity extra sandboxFlags globalFlags --- --- Utils (transitionary) --- + -- More advanced commands. + ("hc-pkg":extra) -> do + when (noExtraArgs extra) $ + die $ "The 'sandbox hc-pkg' command expects at least one argument" + sandboxHcPkg verbosity sandboxFlags globalFlags extra + ["buildopts"] -> die "Not implemented!" -configPackageDB' :: ConfigFlags -> PackageDBStack -configPackageDB' cfg = - interpretPackageDbFlags userInstall (configPackageDBs cfg) + -- Hidden commands. + ("delete-source":extra) -> do + when (noExtraArgs extra) $ + die "The 'sandbox delete-source' command expects \ + \at least one argument" + sandboxDeleteSource verbosity extra sandboxFlags globalFlags + ["list-sources"] -> sandboxListSources verbosity sandboxFlags globalFlags + ["dump-pkgenv"] -> dumpPackageEnvironment verbosity sandboxFlags globalFlags + + -- Error handling. + [] -> die $ "Please specify a subcommand (see 'help sandbox')" + _ -> die $ "Unknown 'sandbox' subcommand: " ++ unwords extraArgs + where - userInstall = fromFlagOrDefault True (configUserInstall cfg) + noExtraArgs = (<1) . length -configCompilerAux' :: ConfigFlags - -> IO (Compiler, ProgramConfiguration) -configCompilerAux' configFlags = - configCompilerAux configFlags - --FIXME: make configCompilerAux use a sensible verbosity - { configVerbosity = fmap lessVerbose (configVerbosity configFlags) } +-- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details. +-- +win32SelfUpgradeAction :: Win32SelfUpgradeFlags -> [String] -> GlobalFlags + -> IO () +win32SelfUpgradeAction selfUpgradeFlags (pid:path:_extraArgs) _globalFlags = do + let verbosity = fromFlag (win32SelfUpgradeVerbosity selfUpgradeFlags) + Win32SelfUpgrade.deleteOldExeFile verbosity (read pid) path +win32SelfUpgradeAction _ _ _ = return () diff --git a/cabal-install-bundle.cabal b/cabal-install-bundle.cabal --- a/cabal-install-bundle.cabal +++ b/cabal-install-bundle.cabal @@ -1,5 +1,5 @@ Name: cabal-install-bundle -Version: 0.16.0.2.1 +Version: 1.18.0.2 Synopsis: The (bundled) command-line interface for Cabal and Hackage. Description: This is cabal-install with bundled dependencies. Easier to bootstrap. License: BSD3 @@ -76,6 +76,14 @@ Control.Monad.Trans.Writer Control.Monad.Trans.Writer.Lazy Control.Monad.Trans.Writer.Strict + Control.Concurrent.STM + Control.Concurrent.STM.TBQueue + Control.Concurrent.STM.TQueue + Control.Concurrent.STM.TArray + Control.Concurrent.STM.TVar + Control.Concurrent.STM.TChan + Control.Concurrent.STM.TMVar + Control.Monad.STM Data.Functor.Compose Data.Functor.Constant Data.Functor.Identity @@ -166,6 +174,7 @@ Distribution.Client.Dependency.Modular.Version Distribution.Client.Fetch Distribution.Client.FetchUtils + Distribution.Client.Get Distribution.Client.GZipUtils Distribution.Client.Haddock Distribution.Client.HttpUtils @@ -181,21 +190,28 @@ Distribution.Client.List Distribution.Client.PackageIndex Distribution.Client.PackageUtils + Distribution.Client.ParseUtils + Distribution.Client.Run + Distribution.Client.Sandbox + Distribution.Client.Sandbox.Index + Distribution.Client.Sandbox.PackageEnvironment + Distribution.Client.Sandbox.Timestamp + Distribution.Client.Sandbox.Types Distribution.Client.Setup Distribution.Client.SetupWrapper Distribution.Client.SrcDist Distribution.Client.Tar Distribution.Client.Targets Distribution.Client.Types - Distribution.Client.Unpack Distribution.Client.Update Distribution.Client.Upload Distribution.Client.Utils Distribution.Client.World Distribution.Client.Win32SelfUpgrade - Distribution.Compat.Exception - Distribution.Compat.FilePerms - Distribution.Compat.Time + Distribution.Client.Compat.Environment + Distribution.Client.Compat.FilePerms + Distribution.Client.Compat.Semaphore + Distribution.Client.Compat.Time Paths_cabal_install_bundle build-depends: base >= 2 && < 99, Cabal >= 1.16, filepath, time, process, directory, pretty, containers, array, old-time, bytestring, unix