diff --git a/Codec/Compression/GZip.hs b/Codec/Compression/GZip.hs new file mode 100644 --- /dev/null +++ b/Codec/Compression/GZip.hs @@ -0,0 +1,130 @@ +----------------------------------------------------------------------------- +-- | +-- Copyright : (c) 2006-2008 Duncan Coutts +-- License : BSD-style +-- +-- Maintainer : duncan@haskell.org +-- Stability : provisional +-- Portability : portable (H98 + FFI) +-- +-- Compression and decompression of data streams in the gzip format. +-- +-- The format is described in detail in RFC #1952: +-- +-- +-- See also the zlib home page: +-- +----------------------------------------------------------------------------- +module Codec.Compression.GZip ( + + -- | This module provides pure functions for compressing and decompressing + -- streams of data in the gzip format and represented by lazy 'ByteString's. + -- This makes it easy to use either in memory or with disk or network IO. + -- + -- For example a simple gzip compression program is just: + -- + -- > import qualified Data.ByteString.Lazy as ByteString + -- > import qualified Codec.Compression.GZip as GZip + -- > + -- > main = ByteString.interact GZip.compress + -- + -- Or you could lazily read in and decompress a @.gz@ file using: + -- + -- > content <- fmap GZip.decompress (readFile file) + -- + + -- * Simple compression and decompression + compress, + decompress, + + -- * Extended api with control over compression parameters + compressWith, + decompressWith, + + CompressParams(..), defaultCompressParams, + DecompressParams(..), defaultDecompressParams, + + -- ** The compression parameter types + CompressionLevel(..), + defaultCompression, + noCompression, + bestSpeed, + bestCompression, + compressionLevel, + Method(..), + deflateMethod, + WindowBits(..), + defaultWindowBits, + windowBits, + MemoryLevel(..), + defaultMemoryLevel, + minMemoryLevel, + maxMemoryLevel, + memoryLevel, + CompressionStrategy(..), + defaultStrategy, + filteredStrategy, + huffmanOnlyStrategy, + + ) where + +import Data.ByteString.Lazy (ByteString) + +import qualified Codec.Compression.Zlib.Internal as Internal +import Codec.Compression.Zlib.Internal hiding (compress, decompress) + + +-- | Decompress a stream of data in the gzip format. +-- +-- There are a number of errors that can occur. In each case an exception will +-- be thrown. The possible error conditions are: +-- +-- * if the stream does not start with a valid gzip header +-- +-- * if the compressed stream is corrupted +-- +-- * if the compressed stream ends permaturely +-- +-- Note that the decompression is performed /lazily/. Errors in the data stream +-- may not be detected until the end of the stream is demanded (since it is +-- only at the end that the final checksum can be checked). If this is +-- important to you, you must make sure to consume the whole decompressed +-- stream before doing any IO action that depends on it. +-- +decompress :: ByteString -> ByteString +decompress = decompressWith defaultDecompressParams + + +-- | Like 'decompress' but with the ability to specify various decompression +-- parameters. Typical usage: +-- +-- > decompressWith defaultCompressParams { ... } +-- +decompressWith :: DecompressParams -> ByteString -> ByteString +decompressWith = Internal.decompress gzipFormat + + +-- | Compress a stream of data into the gzip format. +-- +-- This uses the default compression parameters. In partiular it uses the +-- default compression level which favours a higher compression ratio over +-- compression speed, though it does not use the maximum compression level. +-- +-- Use 'compressWith' to adjust the compression level or other compression +-- parameters. +-- +compress :: ByteString -> ByteString +compress = compressWith defaultCompressParams + + +-- | Like 'compress' but with the ability to specify various compression +-- parameters. Typical usage: +-- +-- > compressWith defaultCompressParams { ... } +-- +-- In particular you can set the compression level: +-- +-- > compressWith defaultCompressParams { compressLevel = BestCompression } +-- +compressWith :: CompressParams -> ByteString -> ByteString +compressWith = Internal.compress gzipFormat diff --git a/Codec/Compression/Zlib.hs b/Codec/Compression/Zlib.hs new file mode 100644 --- /dev/null +++ b/Codec/Compression/Zlib.hs @@ -0,0 +1,118 @@ +----------------------------------------------------------------------------- +-- | +-- Copyright : (c) 2006-2008 Duncan Coutts +-- License : BSD-style +-- +-- Maintainer : duncan@haskell.org +-- Stability : provisional +-- Portability : portable (H98 + FFI) +-- +-- Compression and decompression of data streams in the zlib format. +-- +-- The format is described in detail in RFC #1950: +-- +-- +-- See also the zlib home page: +-- +----------------------------------------------------------------------------- +module Codec.Compression.Zlib ( + + -- | This module provides pure functions for compressing and decompressing + -- streams of data in the zlib format and represented by lazy 'ByteString's. + -- This makes it easy to use either in memory or with disk or network IO. + + -- * Simple compression and decompression + compress, + decompress, + + -- * Extended api with control over compression parameters + compressWith, + decompressWith, + + CompressParams(..), defaultCompressParams, + DecompressParams(..), defaultDecompressParams, + + -- ** The compression parameter types + CompressionLevel(..), + defaultCompression, + noCompression, + bestSpeed, + bestCompression, + compressionLevel, + Method(..), + deflateMethod, + WindowBits(..), + defaultWindowBits, + windowBits, + MemoryLevel(..), + defaultMemoryLevel, + minMemoryLevel, + maxMemoryLevel, + memoryLevel, + CompressionStrategy(..), + defaultStrategy, + filteredStrategy, + huffmanOnlyStrategy, + + ) where + +import Data.ByteString.Lazy (ByteString) + +import qualified Codec.Compression.Zlib.Internal as Internal +import Codec.Compression.Zlib.Internal hiding (compress, decompress) + + +-- | Decompress a stream of data in the zlib format. +-- +-- There are a number of errors that can occur. In each case an exception will +-- be thrown. The possible error conditions are: +-- +-- * if the stream does not start with a valid gzip header +-- +-- * if the compressed stream is corrupted +-- +-- * if the compressed stream ends permaturely +-- +-- Note that the decompression is performed /lazily/. Errors in the data stream +-- may not be detected until the end of the stream is demanded (since it is +-- only at the end that the final checksum can be checked). If this is +-- important to you, you must make sure to consume the whole decompressed +-- stream before doing any IO action that depends on it. +-- +decompress :: ByteString -> ByteString +decompress = decompressWith defaultDecompressParams + + +-- | Like 'decompress' but with the ability to specify various decompression +-- parameters. Typical usage: +-- +-- > decompressWith defaultCompressParams { ... } +-- +decompressWith :: DecompressParams -> ByteString -> ByteString +decompressWith = Internal.decompress zlibFormat + + +-- | Compress a stream of data into the zlib format. +-- +-- This uses the default compression parameters. In partiular it uses the +-- default compression level which favours a higher compression ratio over +-- compression speed, though it does not use the maximum compression level. +-- +-- Use 'compressWith' to adjust the compression level or other compression +-- parameters. +-- +compress :: ByteString -> ByteString +compress = compressWith defaultCompressParams + + +-- | Like 'compress' but with the ability to specify various compression +-- parameters. Typical usage: +-- +-- > compressWith defaultCompressParams { ... } +-- +-- In particular you can set the compression level: +-- +-- > compressWith defaultCompressParams { compressLevel = BestCompression } +-- +compressWith :: CompressParams -> ByteString -> ByteString +compressWith = Internal.compress zlibFormat diff --git a/Codec/Compression/Zlib/Internal.hs b/Codec/Compression/Zlib/Internal.hs new file mode 100644 --- /dev/null +++ b/Codec/Compression/Zlib/Internal.hs @@ -0,0 +1,425 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Copyright : (c) 2006-2008 Duncan Coutts +-- License : BSD-style +-- +-- Maintainer : duncan@haskell.org +-- Stability : provisional +-- Portability : portable (H98 + FFI) +-- +-- Pure stream based interface to lower level zlib wrapper +-- +----------------------------------------------------------------------------- +module Codec.Compression.Zlib.Internal ( + + -- * Compression + compress, + CompressParams(..), + defaultCompressParams, + + -- * Decompression + decompress, + DecompressParams(..), + defaultDecompressParams, + + -- * The compression parameter types + Stream.Format(..), + Stream.gzipFormat, + Stream.zlibFormat, + Stream.rawFormat, + Stream.gzipOrZlibFormat, + Stream.CompressionLevel(..), + Stream.defaultCompression, + Stream.noCompression, + Stream.bestSpeed, + Stream.bestCompression, + Stream.compressionLevel, + Stream.Method(..), + Stream.deflateMethod, + Stream.WindowBits(..), + Stream.defaultWindowBits, + Stream.windowBits, + Stream.MemoryLevel(..), + Stream.defaultMemoryLevel, + Stream.minMemoryLevel, + Stream.maxMemoryLevel, + Stream.memoryLevel, + Stream.CompressionStrategy(..), + Stream.defaultStrategy, + Stream.filteredStrategy, + Stream.huffmanOnlyStrategy, + + -- * Low-level API to get explicit error reports + decompressWithErrors, + DecompressStream(..), + DecompressError(..), + foldDecompressStream, + fromDecompressStream, + ) where + +import Prelude hiding (length) +import Control.Monad (when) +import Control.Exception (assert) +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Internal as L +import qualified Data.ByteString.Internal as S + +import qualified Codec.Compression.Zlib.Stream as Stream +import Codec.Compression.Zlib.Stream (Stream) + +-- | The full set of parameters for compression. The defaults are +-- 'defaultCompressParams'. +-- +-- The 'compressBufferSize' is the size of the first output buffer containing +-- the compressed data. If you know an approximate upper bound on the size of +-- the compressed data then setting this parameter can save memory. The default +-- compression output buffer size is @16k@. If your extimate is wrong it does +-- not matter too much, the default buffer size will be used for the remaining +-- chunks. +-- +data CompressParams = CompressParams { + compressLevel :: !Stream.CompressionLevel, + compressMethod :: !Stream.Method, + compressWindowBits :: !Stream.WindowBits, + compressMemoryLevel :: !Stream.MemoryLevel, + compressStrategy :: !Stream.CompressionStrategy, + compressBufferSize :: !Int +} + +-- | The full set of parameters for decompression. The defaults are +-- 'defaultDecompressParams'. +-- +-- The 'decompressBufferSize' is the size of the first output buffer, +-- containing the uncompressed data. If you know an exact or approximate upper +-- bound on the size of the decompressed data then setting this parameter can +-- save memory. The default decompression output buffer size is @32k@. If your +-- extimate is wrong it does not matter too much, the default buffer size will +-- be used for the remaining chunks. +-- +-- One particular use case for setting the 'decompressBufferSize' is if you +-- know the exact size of the decompressed data and want to produce a strict +-- 'Data.ByteString.ByteString'. The compression and deccompression functions +-- use lazy 'Data.ByteString.Lazy.ByteString's but if you set the +-- 'decompressBufferSize' correctly then you can generate a lazy +-- 'Data.ByteString.Lazy.ByteString' with exactly one chunk, which can be +-- converted to a strict 'Data.ByteString.ByteString' in @O(1)@ time using +-- @'Data.ByteString.concat' . 'Data.ByteString.Lazy.toChunks'@. +-- +data DecompressParams = DecompressParams { + decompressWindowBits :: !Stream.WindowBits, + decompressBufferSize :: !Int +} + +-- | The default set of parameters for compression. This is typically used with +-- the @compressWith@ function with specific parameters overridden. +-- +defaultCompressParams :: CompressParams +defaultCompressParams = CompressParams { + compressLevel = Stream.defaultCompression, + compressMethod = Stream.deflateMethod, + compressWindowBits = Stream.defaultWindowBits, + compressMemoryLevel = Stream.defaultMemoryLevel, + compressStrategy = Stream.defaultStrategy, + compressBufferSize = defaultCompressBufferSize +} + +-- | The default set of parameters for decompression. This is typically used with +-- the @compressWith@ function with specific parameters overridden. +-- +defaultDecompressParams :: DecompressParams +defaultDecompressParams = DecompressParams { + decompressWindowBits = Stream.defaultWindowBits, + decompressBufferSize = defaultDecompressBufferSize +} + +-- | The default chunk sizes for the output of compression and decompression +-- are 16k and 32k respectively (less a small accounting overhead). +-- +defaultCompressBufferSize, defaultDecompressBufferSize :: Int +defaultCompressBufferSize = 16 * 1024 - L.chunkOverhead +defaultDecompressBufferSize = 32 * 1024 - L.chunkOverhead + +-- | A sequence of chunks of data produced from decompression. +-- +-- The difference from a simple list is that it contains a representation of +-- errors as data rather than as exceptions. This allows you to handle error +-- conditions explicitly. +-- +data DecompressStream = StreamEnd + | StreamChunk S.ByteString DecompressStream + + -- | An error code and a human readable error message. + | StreamError DecompressError String + +-- | The possible error cases when decompressing a stream. +-- +data DecompressError = + -- | The compressed data stream ended prematurely. This may happen if the + -- input data stream was truncated. + TruncatedInput + + -- | It is possible to do zlib compression with a custom dictionary. This + -- allows slightly higher compression ratios for short files. However such + -- compressed streams require the same dictionary when decompressing. This + -- zlib binding does not currently support custom dictionaries. This error + -- is for when we encounter a compressed stream that needs a dictionary. + | DictionaryRequired + + -- | If the compressed data stream is corrupted in any way then you will + -- get this error, for example if the input data just isn't a compressed + -- zlib data stream. In particular if the data checksum turns out to be + -- wrong then you will get all the decompressed data but this error at the + -- end, instead of the normal sucessful 'StreamEnd'. + | DataError + +-- | Fold an 'DecompressionStream'. Just like 'foldr' but with an extra error +-- case. For example to convert to a list and translate the errors into +-- exceptions: +-- +-- > foldDecompressStream (:) [] (\code msg -> error msg) +-- +foldDecompressStream :: (S.ByteString -> a -> a) -> a + -> (DecompressError -> String -> a) + -> DecompressStream -> a +foldDecompressStream chunk end err = fold + where + fold StreamEnd = end + fold (StreamChunk bs stream) = chunk bs (fold stream) + fold (StreamError code msg) = err code msg + +-- | Convert a 'DecompressStream' to a lazy 'ByteString'. If any decompression +-- errors are encountered then they are thrown as exceptions. +-- +-- This is a special case of 'foldDecompressStream'. +-- +fromDecompressStream :: DecompressStream -> L.ByteString +fromDecompressStream = + foldDecompressStream L.Chunk L.Empty + (\_code msg -> error ("Codec.Compression.Zlib: " ++ msg)) + +--TODO: throw DecompressError as an Exception class type and document that it +-- does this. + +-- | Compress a data stream. +-- +-- There are no expected error conditions. All input data streams are valid. It +-- is possible for unexpected errors to occur, such as running out of memory, +-- or finding the wrong version of the zlib C library, these are thrown as +-- exceptions. +-- +compress + :: Stream.Format + -> CompressParams + -> L.ByteString + -> L.ByteString +compress format + (CompressParams compLevel method bits memLevel strategy initChunkSize) + input = + L.fromChunks $ Stream.run $ do + Stream.deflateInit format compLevel method bits memLevel strategy + case L.toChunks input of + [] -> fillBuffers 20 [] --gzip header is 20 bytes, others even smaller + S.PS inFPtr offset length : chunks -> do + Stream.pushInputBuffer inFPtr offset length + fillBuffers initChunkSize chunks + + where + -- we flick between two states: + -- * where one or other buffer is empty + -- - in which case we refill one or both + -- * where both buffers are non-empty + -- - in which case we compress until a buffer is empty + + fillBuffers :: Int + -> [S.ByteString] + -> Stream [S.ByteString] + fillBuffers outChunkSize inChunks = do +#ifdef DEBUG + Stream.consistencyCheck +#endif + + -- in this state there are two possabilities: + -- * no outbut buffer space is available + -- - in which case we must make more available + -- * no input buffer is available + -- - in which case we must supply more + inputBufferEmpty <- Stream.inputBufferEmpty + outputBufferFull <- Stream.outputBufferFull + + assert (inputBufferEmpty || outputBufferFull) $ return () + + when outputBufferFull $ do + outFPtr <- Stream.unsafeLiftIO (S.mallocByteString outChunkSize) + Stream.pushOutputBuffer outFPtr 0 outChunkSize + + if inputBufferEmpty + then case inChunks of + [] -> drainBuffers [] + S.PS inFPtr offset length : inChunks' -> do + Stream.pushInputBuffer inFPtr offset length + drainBuffers inChunks' + else drainBuffers inChunks + + + drainBuffers :: + [S.ByteString] + -> Stream [S.ByteString] + drainBuffers inChunks = do + + inputBufferEmpty' <- Stream.inputBufferEmpty + outputBufferFull' <- Stream.outputBufferFull + assert(not outputBufferFull' + && (null inChunks || not inputBufferEmpty')) $ return () + -- this invariant guarantees we can always make forward progress + -- and that therefore a BufferError is impossible + + let flush = if null inChunks then Stream.Finish else Stream.NoFlush + status <- Stream.deflate flush + + case status of + Stream.Ok -> do + outputBufferFull <- Stream.outputBufferFull + if outputBufferFull + then do (outFPtr, offset, length) <- Stream.popOutputBuffer + outChunks <- Stream.unsafeInterleave + (fillBuffers defaultCompressBufferSize inChunks) + return (S.PS outFPtr offset length : outChunks) + else do fillBuffers defaultCompressBufferSize inChunks + + Stream.StreamEnd -> do + inputBufferEmpty <- Stream.inputBufferEmpty + assert inputBufferEmpty $ return () + outputBufferBytesAvailable <- Stream.outputBufferBytesAvailable + if outputBufferBytesAvailable > 0 + then do (outFPtr, offset, length) <- Stream.popOutputBuffer + Stream.finalise + return [S.PS outFPtr offset length] + else do Stream.finalise + return [] + + Stream.Error code msg -> case code of + Stream.BufferError -> fail "BufferError should be impossible!" + Stream.NeedDict -> fail "NeedDict is impossible!" + _ -> fail msg + + +-- | Decompress a data stream. +-- +-- It will throw an exception if any error is encountered in the input data. If +-- you need more control over error handling then use 'decompressWithErrors'. +-- +decompress + :: Stream.Format + -> DecompressParams + -> L.ByteString + -> L.ByteString +decompress format params = fromDecompressStream + . decompressWithErrors format params + +-- | Like 'decompress' but returns a 'DecompressStream' data structure that +-- contains an explicit representation of the error conditions that one may +-- encounter when decompressing. +-- +-- Note that in addition to errors in the input data, it is possible for other +-- unexpected errors to occur, such as out of memory, or finding the wrong +-- version of the zlib C library, these are still thrown as exceptions (because +-- representing them as data would make this function impure). +-- +decompressWithErrors + :: Stream.Format + -> DecompressParams + -> L.ByteString + -> DecompressStream +decompressWithErrors format (DecompressParams bits initChunkSize) input = + Stream.run $ do + Stream.inflateInit format bits + case L.toChunks input of + [] -> fillBuffers 4 [] --always an error anyway + S.PS inFPtr offset length : chunks -> do + Stream.pushInputBuffer inFPtr offset length + fillBuffers initChunkSize chunks + + where + -- we flick between two states: + -- * where one or other buffer is empty + -- - in which case we refill one or both + -- * where both buffers are non-empty + -- - in which case we compress until a buffer is empty + + fillBuffers :: Int + -> [S.ByteString] + -> Stream DecompressStream + fillBuffers outChunkSize inChunks = do +#ifdef DEBUG + Stream.consistencyCheck +#endif + + -- in this state there are two possabilities: + -- * no outbut buffer space is available + -- - in which case we must make more available + -- * no input buffer is available + -- - in which case we must supply more + inputBufferEmpty <- Stream.inputBufferEmpty + outputBufferFull <- Stream.outputBufferFull + + assert (inputBufferEmpty || outputBufferFull) $ return () + + when outputBufferFull $ do + outFPtr <- Stream.unsafeLiftIO (S.mallocByteString outChunkSize) + Stream.pushOutputBuffer outFPtr 0 outChunkSize + + if inputBufferEmpty + then case inChunks of + [] -> drainBuffers [] + S.PS inFPtr offset length : inChunks' -> do + Stream.pushInputBuffer inFPtr offset length + drainBuffers inChunks' + else drainBuffers inChunks + + + drainBuffers :: + [S.ByteString] + -> Stream DecompressStream + drainBuffers inChunks = do + + inputBufferEmpty' <- Stream.inputBufferEmpty + outputBufferFull' <- Stream.outputBufferFull + assert(not outputBufferFull' + && (null inChunks || not inputBufferEmpty')) $ return () + -- this invariant guarantees we can always make forward progress or at + -- least if a BufferError does occur that it must be due to a premature EOF + + status <- Stream.inflate Stream.NoFlush + + case status of + Stream.Ok -> do + outputBufferFull <- Stream.outputBufferFull + if outputBufferFull + then do (outFPtr, offset, length) <- Stream.popOutputBuffer + outChunks <- Stream.unsafeInterleave + (fillBuffers defaultDecompressBufferSize inChunks) + return $ StreamChunk (S.PS outFPtr offset length) outChunks + else do fillBuffers defaultDecompressBufferSize inChunks + + Stream.StreamEnd -> finish StreamEnd + Stream.Error code msg -> case code of + Stream.BufferError -> finish (StreamError TruncatedInput msg') + where msg' = "premature end of compressed stream" + Stream.NeedDict -> finish (StreamError DictionaryRequired msg) + Stream.DataError -> finish (StreamError DataError msg) + _ -> fail msg + + -- Note even if we end with an error we still try to flush the last chunk if + -- there is one. The user just has to decide what they want to trust. + finish end = do + -- Note that there may be input bytes still available if the stream + -- is embeded in some other data stream. Here we just silently discard + -- any trailing data. + outputBufferBytesAvailable <- Stream.outputBufferBytesAvailable + if outputBufferBytesAvailable > 0 + then do (outFPtr, offset, length) <- Stream.popOutputBuffer + Stream.finalise + return (StreamChunk (S.PS outFPtr offset length) end) + else do Stream.finalise + return end diff --git a/Codec/Compression/Zlib/Raw.hs b/Codec/Compression/Zlib/Raw.hs new file mode 100644 --- /dev/null +++ b/Codec/Compression/Zlib/Raw.hs @@ -0,0 +1,70 @@ +----------------------------------------------------------------------------- +-- | +-- Copyright : (c) 2006-2008 Duncan Coutts +-- License : BSD-style +-- +-- Maintainer : duncan@haskell.org +-- Stability : provisional +-- Portability : portable (H98 + FFI) +-- +-- Compression and decompression of data streams in the raw deflate format. +-- +-- The format is described in detail in RFC #1951: +-- +-- +-- See also the zlib home page: +-- +----------------------------------------------------------------------------- +module Codec.Compression.Zlib.Raw ( + + -- * Simple compression and decompression + compress, + decompress, + + -- * Extended api with control over compression parameters + compressWith, + decompressWith, + + CompressParams(..), defaultCompressParams, + DecompressParams(..), defaultDecompressParams, + + -- ** The compression parameter types + CompressionLevel(..), + defaultCompression, + noCompression, + bestSpeed, + bestCompression, + compressionLevel, + Method(..), + deflateMethod, + WindowBits(..), + defaultWindowBits, + windowBits, + MemoryLevel(..), + defaultMemoryLevel, + minMemoryLevel, + maxMemoryLevel, + memoryLevel, + CompressionStrategy(..), + defaultStrategy, + filteredStrategy, + huffmanOnlyStrategy, + + ) where + +import Data.ByteString.Lazy (ByteString) + +import qualified Codec.Compression.Zlib.Internal as Internal +import Codec.Compression.Zlib.Internal hiding (compress, decompress) + +decompress :: ByteString -> ByteString +decompress = decompressWith defaultDecompressParams + +decompressWith :: DecompressParams -> ByteString -> ByteString +decompressWith = Internal.decompress rawFormat + +compress :: ByteString -> ByteString +compress = compressWith defaultCompressParams + +compressWith :: CompressParams -> ByteString -> ByteString +compressWith = Internal.compress rawFormat diff --git a/Codec/Compression/Zlib/Stream.hsc b/Codec/Compression/Zlib/Stream.hsc new file mode 100644 --- /dev/null +++ b/Codec/Compression/Zlib/Stream.hsc @@ -0,0 +1,895 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +----------------------------------------------------------------------------- +-- | +-- Copyright : (c) 2006-2008 Duncan Coutts +-- License : BSD-style +-- +-- Maintainer : duncan@haskell.org +-- Stability : provisional +-- Portability : portable (H98 + FFI) +-- +-- Zlib wrapper layer +-- +----------------------------------------------------------------------------- +module Codec.Compression.Zlib.Stream ( + + -- * The Zlib state monad + Stream, + run, + unsafeInterleave, + unsafeLiftIO, + finalise, + + -- * Initialisation + deflateInit, + inflateInit, + + -- ** Initialisation parameters + Format(..), + gzipFormat, + zlibFormat, + rawFormat, + gzipOrZlibFormat, + CompressionLevel(..), + defaultCompression, + noCompression, + bestSpeed, + bestCompression, + compressionLevel, + Method(..), + deflateMethod, + WindowBits(..), + defaultWindowBits, + windowBits, + MemoryLevel(..), + defaultMemoryLevel, + minMemoryLevel, + maxMemoryLevel, + memoryLevel, + CompressionStrategy(..), + defaultStrategy, + filteredStrategy, + huffmanOnlyStrategy, + + -- * The buisness + deflate, + inflate, + Status(..), + Flush(..), + ErrorCode(..), + + -- * Buffer management + -- ** Input buffer + pushInputBuffer, + inputBufferEmpty, + + -- ** Output buffer + pushOutputBuffer, + popOutputBuffer, + outputBufferBytesAvailable, + outputBufferSpaceRemaining, + outputBufferFull, + +#ifdef DEBUG + -- * Debugging + consistencyCheck, + dump, + trace, +#endif + + ) where + +import Foreign + ( Word8, Ptr, nullPtr, plusPtr, peekByteOff, pokeByteOff, mallocBytes + , ForeignPtr, FinalizerPtr, newForeignPtr_, addForeignPtrFinalizer + , withForeignPtr, touchForeignPtr ) +#if __GLASGOW_HASKELL__ >= 702 +import Foreign.ForeignPtr.Unsafe ( unsafeForeignPtrToPtr ) +import System.IO.Unsafe ( unsafePerformIO ) +#else +import Foreign ( unsafeForeignPtrToPtr, unsafePerformIO ) +#endif +#ifdef __GLASGOW_HASKELL__ +import Foreign + ( finalizeForeignPtr ) +#endif +import Foreign.C +import Data.ByteString.Internal (nullForeignPtr) +import System.IO.Unsafe (unsafeInterleaveIO) +import Control.Monad (liftM) +import Control.Exception (assert) +#ifdef DEBUG +import System.IO (hPutStrLn, stderr) +#endif + +import Prelude hiding (length) + +#include "zlib.h" + + +pushInputBuffer :: ForeignPtr Word8 -> Int -> Int -> Stream () +pushInputBuffer inBuf' offset length = do + + -- must not push a new input buffer if the last one is not used up + inAvail <- getInAvail + assert (inAvail == 0) $ return () + + -- Now that we're setting a new input buffer, we can be sure that zlib no + -- longer has a reference to the old one. Therefore this is the last point + -- at which the old buffer had to be retained. It's safe to release now. + inBuf <- getInBuf + unsafeLiftIO $ touchForeignPtr inBuf + + -- now set the available input buffer ptr and length + setInBuf inBuf' + setInAvail length + setInNext (unsafeForeignPtrToPtr inBuf' `plusPtr` offset) + -- Note the 'unsafe'. We are passing the raw ptr inside inBuf' to zlib. + -- To make this safe we need to hold on to the ForeignPtr for at least as + -- long as zlib is using the underlying raw ptr. + + +inputBufferEmpty :: Stream Bool +inputBufferEmpty = getInAvail >>= return . (==0) + + +pushOutputBuffer :: ForeignPtr Word8 -> Int -> Int -> Stream () +pushOutputBuffer outBuf' offset length = do + + --must not push a new buffer if there is still data in the old one + outAvail <- getOutAvail + assert (outAvail == 0) $ return () + -- Note that there may still be free space in the output buffer, that's ok, + -- you might not want to bother completely filling the output buffer say if + -- there's only a few free bytes left. + + outBuf <- getOutBuf + unsafeLiftIO $ touchForeignPtr outBuf + + -- now set the available input buffer ptr and length + setOutBuf outBuf' + setOutFree length + setOutNext (unsafeForeignPtrToPtr outBuf' `plusPtr` offset) + + setOutOffset offset + setOutAvail 0 + + +-- get that part of the output buffer that is currently full +-- (might be 0, use outputBufferBytesAvailable to check) +-- this may leave some space remaining in the buffer, use +-- outputBufferSpaceRemaining to check. +popOutputBuffer :: Stream (ForeignPtr Word8, Int, Int) +popOutputBuffer = do + + outBuf <- getOutBuf + outOffset <- getOutOffset + outAvail <- getOutAvail + + -- there really should be something to pop, otherwise it's silly + assert (outAvail > 0) $ return () + + setOutOffset (outOffset + outAvail) + setOutAvail 0 + + return (outBuf, outOffset, outAvail) + + +-- this is the number of bytes available in the output buffer +outputBufferBytesAvailable :: Stream Int +outputBufferBytesAvailable = getOutAvail + + +-- you needen't get all the output immediately, you can continue until +-- there is no more output space available, this tells you that amount +outputBufferSpaceRemaining :: Stream Int +outputBufferSpaceRemaining = getOutFree + + +-- you only need to supply a new buffer when there is no more output buffer +-- space remaining +outputBufferFull :: Stream Bool +outputBufferFull = liftM (==0) outputBufferSpaceRemaining + + +-- you can only run this when the output buffer is not empty +-- you can run it when the input buffer is empty but it doesn't do anything +-- after running deflate either the output buffer will be full +-- or the input buffer will be empty (or both) +deflate :: Flush -> Stream Status +deflate flush = do + + outFree <- getOutFree + + -- deflate needs free space in the output buffer + assert (outFree > 0) $ return () + + result <- deflate_ flush + outFree' <- getOutFree + + -- number of bytes of extra output there is available as a result of + -- the call to deflate: + let outExtra = outFree - outFree' + + outAvail <- getOutAvail + setOutAvail (outAvail + outExtra) + return result + + +inflate :: Flush -> Stream Status +inflate flush = do + + outFree <- getOutFree + + -- inflate needs free space in the output buffer + assert (outFree > 0) $ return () + + result <- inflate_ flush + outFree' <- getOutFree + + -- number of bytes of extra output there is available as a result of + -- the call to inflate: + let outExtra = outFree - outFree' + + outAvail <- getOutAvail + setOutAvail (outAvail + outExtra) + return result + + +---------------------------- +-- Stream monad +-- + +newtype Stream a = Z { + unZ :: ForeignPtr StreamState + -> ForeignPtr Word8 + -> ForeignPtr Word8 + -> Int -> Int + -> IO (ForeignPtr Word8 + ,ForeignPtr Word8 + ,Int, Int, a) + } + +instance Monad Stream where + (>>=) = thenZ +-- m >>= f = (m `thenZ` \a -> consistencyCheck `thenZ_` returnZ a) `thenZ` f + (>>) = thenZ_ + return = returnZ + fail = (finalise >>) . failZ + +returnZ :: a -> Stream a +returnZ a = Z $ \_ inBuf outBuf outOffset outLength -> + return (inBuf, outBuf, outOffset, outLength, a) +{-# INLINE returnZ #-} + +thenZ :: Stream a -> (a -> Stream b) -> Stream b +thenZ (Z m) f = + Z $ \stream inBuf outBuf outOffset outLength -> + m stream inBuf outBuf outOffset outLength >>= + \(inBuf', outBuf', outOffset', outLength', a) -> + unZ (f a) stream inBuf' outBuf' outOffset' outLength' +{-# INLINE thenZ #-} + +thenZ_ :: Stream a -> Stream b -> Stream b +thenZ_ (Z m) f = + Z $ \stream inBuf outBuf outOffset outLength -> + m stream inBuf outBuf outOffset outLength >>= + \(inBuf', outBuf', outOffset', outLength', _) -> + unZ f stream inBuf' outBuf' outOffset' outLength' +{-# INLINE thenZ_ #-} + +failZ :: String -> Stream a +failZ msg = Z (\_ _ _ _ _ -> fail ("Codec.Compression.Zlib: " ++ msg)) + +{-# NOINLINE run #-} +run :: Stream a -> a +run (Z m) = unsafePerformIO $ do + ptr <- mallocBytes (#{const sizeof(z_stream)}) + #{poke z_stream, msg} ptr nullPtr + #{poke z_stream, zalloc} ptr nullPtr + #{poke z_stream, zfree} ptr nullPtr + #{poke z_stream, opaque} ptr nullPtr + #{poke z_stream, next_in} ptr nullPtr + #{poke z_stream, next_out} ptr nullPtr + #{poke z_stream, avail_in} ptr (0 :: CUInt) + #{poke z_stream, avail_out} ptr (0 :: CUInt) + stream <- newForeignPtr_ ptr + (_,_,_,_,a) <- m stream nullForeignPtr nullForeignPtr 0 0 + return a + +-- This is marked as unsafe because run uses unsafePerformIO so anything +-- lifted here will end up being unsafePerformIO'd. +unsafeLiftIO :: IO a -> Stream a +unsafeLiftIO m = Z $ \_stream inBuf outBuf outOffset outLength -> do + a <- m + return (inBuf, outBuf, outOffset, outLength, a) + +-- It's unsafe because we discard the values here, so if you mutate anything +-- between running this and forcing the result then you'll get an inconsistent +-- stream state. +unsafeInterleave :: Stream a -> Stream a +unsafeInterleave (Z m) = Z $ \stream inBuf outBuf outOffset outLength -> do + res <- unsafeInterleaveIO (m stream inBuf outBuf outOffset outLength) + let select (_,_,_,_,a) = a + return (inBuf, outBuf, outOffset, outLength, select res) + +getStreamState :: Stream (ForeignPtr StreamState) +getStreamState = Z $ \stream inBuf outBuf outOffset outLength -> do + return (inBuf, outBuf, outOffset, outLength, stream) + +getInBuf :: Stream (ForeignPtr Word8) +getInBuf = Z $ \_stream inBuf outBuf outOffset outLength -> do + return (inBuf, outBuf, outOffset, outLength, inBuf) + +getOutBuf :: Stream (ForeignPtr Word8) +getOutBuf = Z $ \_stream inBuf outBuf outOffset outLength -> do + return (inBuf, outBuf, outOffset, outLength, outBuf) + +getOutOffset :: Stream Int +getOutOffset = Z $ \_stream inBuf outBuf outOffset outLength -> do + return (inBuf, outBuf, outOffset, outLength, outOffset) + +getOutAvail :: Stream Int +getOutAvail = Z $ \_stream inBuf outBuf outOffset outLength -> do + return (inBuf, outBuf, outOffset, outLength, outLength) + +setInBuf :: ForeignPtr Word8 -> Stream () +setInBuf inBuf = Z $ \_stream _ outBuf outOffset outLength -> do + return (inBuf, outBuf, outOffset, outLength, ()) + +setOutBuf :: ForeignPtr Word8 -> Stream () +setOutBuf outBuf = Z $ \_stream inBuf _ outOffset outLength -> do + return (inBuf, outBuf, outOffset, outLength, ()) + +setOutOffset :: Int -> Stream () +setOutOffset outOffset = Z $ \_stream inBuf outBuf _ outLength -> do + return (inBuf, outBuf, outOffset, outLength, ()) + +setOutAvail :: Int -> Stream () +setOutAvail outLength = Z $ \_stream inBuf outBuf outOffset _ -> do + return (inBuf, outBuf, outOffset, outLength, ()) + +---------------------------- +-- Debug stuff +-- + +#ifdef DEBUG +trace :: String -> Stream () +trace = unsafeLiftIO . hPutStrLn stderr + +dump :: Stream () +dump = do + inNext <- getInNext + inAvail <- getInAvail + + outNext <- getOutNext + outFree <- getOutFree + outAvail <- getOutAvail + outOffset <- getOutOffset + + unsafeLiftIO $ hPutStrLn stderr $ + "Stream {\n" ++ + " inNext = " ++ show inNext ++ ",\n" ++ + " inAvail = " ++ show inAvail ++ ",\n" ++ + "\n" ++ + " outNext = " ++ show outNext ++ ",\n" ++ + " outFree = " ++ show outFree ++ ",\n" ++ + " outAvail = " ++ show outAvail ++ ",\n" ++ + " outOffset = " ++ show outOffset ++ "\n" ++ + "}" + + consistencyCheck + +consistencyCheck :: Stream () +consistencyCheck = do + + outBuf <- getOutBuf + outOffset <- getOutOffset + outAvail <- getOutAvail + outNext <- getOutNext + + let outBufPtr = unsafeForeignPtrToPtr outBuf + + assert (outBufPtr `plusPtr` (outOffset + outAvail) == outNext) $ return () +#endif + + +---------------------------- +-- zlib wrapper layer +-- + +data Status = + Ok + | StreamEnd + | Error ErrorCode String + +data ErrorCode = + NeedDict + | FileError + | StreamError + | DataError + | MemoryError + | BufferError -- ^ No progress was possible or there was not enough room in + -- the output buffer when 'Finish' is used. Note that + -- 'BuferError' is not fatal, and 'inflate' can be called + -- again with more input and more output space to continue. + | VersionError + | Unexpected + +toStatus :: CInt -> Stream Status +toStatus errno = case errno of + (#{const Z_OK}) -> return Ok + (#{const Z_STREAM_END}) -> return StreamEnd + (#{const Z_NEED_DICT}) -> err NeedDict "custom dictionary needed" + (#{const Z_BUF_ERROR}) -> err BufferError "buffer error" + (#{const Z_ERRNO}) -> err FileError "file error" + (#{const Z_STREAM_ERROR}) -> err StreamError "stream error" + (#{const Z_DATA_ERROR}) -> err DataError "data error" + (#{const Z_MEM_ERROR}) -> err MemoryError "insufficient memory" + (#{const Z_VERSION_ERROR}) -> err VersionError "incompatible zlib version" + other -> return $ Error Unexpected + ("unexpected zlib status: " ++ show other) + where + err errCode altMsg = liftM (Error errCode) $ do + msgPtr <- withStreamPtr (#{peek z_stream, msg}) + if msgPtr /= nullPtr + then unsafeLiftIO (peekCAString msgPtr) + else return altMsg + +failIfError :: CInt -> Stream () +failIfError errno = toStatus errno >>= \status -> case status of + (Error _ msg) -> fail msg + _ -> return () + + +data Flush = + NoFlush + | SyncFlush + | FullFlush + | Finish +-- | Block -- only available in zlib 1.2 and later, uncomment if you need it. + +fromFlush :: Flush -> CInt +fromFlush NoFlush = #{const Z_NO_FLUSH} +fromFlush SyncFlush = #{const Z_SYNC_FLUSH} +fromFlush FullFlush = #{const Z_FULL_FLUSH} +fromFlush Finish = #{const Z_FINISH} +-- fromFlush Block = #{const Z_BLOCK} + + +-- | The format used for compression or decompression. There are three +-- variations. +-- +data Format = GZip | Zlib | Raw | GZipOrZlib + deriving Eq + +{-# DEPRECATED GZip "Use gzipFormat. Format constructors will be hidden in version 0.7" #-} +{-# DEPRECATED Zlib "Use zlibFormat. Format constructors will be hidden in version 0.7" #-} +{-# DEPRECATED Raw "Use rawFormat. Format constructors will be hidden in version 0.7" #-} +{-# DEPRECATED GZipOrZlib "Use gzipOrZlibFormat. Format constructors will be hidden in version 0.7" #-} + +-- | The gzip format uses a header with a checksum and some optional meta-data +-- about the compressed file. It is intended primarily for compressing +-- individual files but is also sometimes used for network protocols such as +-- HTTP. The format is described in detail in RFC #1952 +-- +-- +gzipFormat :: Format +gzipFormat = GZip + +-- | The zlib format uses a minimal header with a checksum but no other +-- meta-data. It is especially designed for use in network protocols. The +-- format is described in detail in RFC #1950 +-- +-- +zlibFormat :: Format +zlibFormat = Zlib + +-- | The \'raw\' format is just the compressed data stream without any +-- additional header, meta-data or data-integrity checksum. The format is +-- described in detail in RFC #1951 +-- +rawFormat :: Format +rawFormat = Raw + +-- | This is not a format as such. It enabled zlib or gzip decoding with +-- automatic header detection. This only makes sense for decompression. +-- +gzipOrZlibFormat :: Format +gzipOrZlibFormat = GZipOrZlib + + +-- | The compression method +-- +data Method = Deflated + +{-# DEPRECATED Deflated "Use deflateMethod. Method constructors will be hidden in version 0.7" #-} + +-- | \'Deflate\' is the only method supported in this version of zlib. +-- Indeed it is likely to be the only method that ever will be supported. +-- +deflateMethod :: Method +deflateMethod = Deflated + +fromMethod :: Method -> CInt +fromMethod Deflated = #{const Z_DEFLATED} + + +-- | The compression level parameter controls the amount of compression. This +-- is a trade-off between the amount of compression and the time required to do +-- the compression. +-- +data CompressionLevel = + DefaultCompression + | NoCompression + | BestSpeed + | BestCompression + | CompressionLevel Int + +{-# DEPRECATED DefaultCompression "Use defaultCompression. CompressionLevel constructors will be hidden in version 0.7" #-} +{-# DEPRECATED NoCompression "Use noCompression. CompressionLevel constructors will be hidden in version 0.7" #-} +{-# DEPRECATED BestSpeed "Use bestSpeed. CompressionLevel constructors will be hidden in version 0.7" #-} +{-# DEPRECATED BestCompression "Use bestCompression. CompressionLevel constructors will be hidden in version 0.7" #-} +--FIXME: cannot deprecate constructor named the same as the type +{- DEPRECATED CompressionLevel "Use compressionLevel. CompressionLevel constructors will be hidden in version 0.7" -} + +-- | The default compression level is 6 (that is, biased towards higher +-- compression at expense of speed). +defaultCompression :: CompressionLevel +defaultCompression = DefaultCompression + +-- | No compression, just a block copy. +noCompression :: CompressionLevel +noCompression = CompressionLevel 0 + +-- | The fastest compression method (less compression) +bestSpeed :: CompressionLevel +bestSpeed = CompressionLevel 1 + +-- | The slowest compression method (best compression). +bestCompression :: CompressionLevel +bestCompression = CompressionLevel 9 + +-- | A specific compression level between 0 and 9. +compressionLevel :: Int -> CompressionLevel +compressionLevel n + | n >= 0 && n <= 9 = CompressionLevel n + | otherwise = error "CompressionLevel must be in the range 0..9" + +fromCompressionLevel :: CompressionLevel -> CInt +fromCompressionLevel DefaultCompression = -1 +fromCompressionLevel NoCompression = 0 +fromCompressionLevel BestSpeed = 1 +fromCompressionLevel BestCompression = 9 +fromCompressionLevel (CompressionLevel n) + | n >= 0 && n <= 9 = fromIntegral n + | otherwise = error "CompressLevel must be in the range 1..9" + + +-- | This specifies the size of the compression window. Larger values of this +-- parameter result in better compression at the expense of higher memory +-- usage. +-- +-- The compression window size is the value of the the window bits raised to +-- the power 2. The window bits must be in the range @8..15@ which corresponds +-- to compression window sizes of 256b to 32Kb. The default is 15 which is also +-- the maximum size. +-- +-- The total amount of memory used depends on the window bits and the +-- 'MemoryLevel'. See the 'MemoryLevel' for the details. +-- +data WindowBits = WindowBits Int + | DefaultWindowBits -- This constructor must be last to make + -- the Ord instance work. The Ord instance + -- is defined with and used by the tests. + -- It makse sense because the default value + -- is is also the max value at 15. + +{-# DEPRECATED DefaultWindowBits "Use defaultWindowBits. WindowBits constructors will be hidden in version 0.7" #-} +--FIXME: cannot deprecate constructor named the same as the type +{- DEPRECATED WindowBits "Use windowBits. WindowBits constructors will be hidden in version 0.7" -} + +-- | The default 'WindowBits' is 15 which is also the maximum size. +-- +defaultWindowBits :: WindowBits +defaultWindowBits = WindowBits 15 + +-- | A specific compression window size, specified in bits in the range @8..15@ +-- +windowBits :: Int -> WindowBits +windowBits n + | n >= 8 && n <= 15 = WindowBits n + | otherwise = error "WindowBits must be in the range 8..15" + +fromWindowBits :: Format -> WindowBits-> CInt +fromWindowBits format bits = (formatModifier format) (checkWindowBits bits) + where checkWindowBits DefaultWindowBits = 15 + checkWindowBits (WindowBits n) + | n >= 8 && n <= 15 = fromIntegral n + | otherwise = error "WindowBits must be in the range 8..15" + formatModifier Zlib = id + formatModifier GZip = (+16) + formatModifier GZipOrZlib = (+32) + formatModifier Raw = negate + + +-- | The 'MemoryLevel' parameter specifies how much memory should be allocated +-- for the internal compression state. It is a tradoff between memory usage, +-- compression ratio and compression speed. Using more memory allows faster +-- compression and a better compression ratio. +-- +-- The total amount of memory used for compression depends on the 'WindowBits' +-- and the 'MemoryLevel'. For decompression it depends only on the +-- 'WindowBits'. The totals are given by the functions: +-- +-- > compressTotal windowBits memLevel = 4 * 2^windowBits + 512 * 2^memLevel +-- > decompressTotal windowBits = 2^windowBits +-- +-- For example, for compression with the default @windowBits = 15@ and +-- @memLevel = 8@ uses @256Kb@. So for example a network server with 100 +-- concurrent compressed streams would use @25Mb@. The memory per stream can be +-- halved (at the cost of somewhat degraded and slower compressionby) by +-- reducing the @windowBits@ and @memLevel@ by one. +-- +-- Decompression takes less memory, the default @windowBits = 15@ corresponds +-- to just @32Kb@. +-- +data MemoryLevel = + DefaultMemoryLevel + | MinMemoryLevel + | MaxMemoryLevel + | MemoryLevel Int + +{-# DEPRECATED DefaultMemoryLevel "Use defaultMemoryLevel. MemoryLevel constructors will be hidden in version 0.7" #-} +{-# DEPRECATED MinMemoryLevel "Use minMemoryLevel. MemoryLevel constructors will be hidden in version 0.7" #-} +{-# DEPRECATED MaxMemoryLevel "Use maxMemoryLevel. MemoryLevel constructors will be hidden in version 0.7" #-} +--FIXME: cannot deprecate constructor named the same as the type +{- DEPRECATED MemoryLevel "Use memoryLevel. MemoryLevel constructors will be hidden in version 0.7" -} + +-- | The default memory level. (Equivalent to @'memoryLevel' 8@) +-- +defaultMemoryLevel :: MemoryLevel +defaultMemoryLevel = MemoryLevel 8 + +-- | Use minimum memory. This is slow and reduces the compression ratio. +-- (Equivalent to @'memoryLevel' 1@) +-- +minMemoryLevel :: MemoryLevel +minMemoryLevel = MemoryLevel 1 + +-- | Use maximum memory for optimal compression speed. +-- (Equivalent to @'memoryLevel' 9@) +-- +maxMemoryLevel :: MemoryLevel +maxMemoryLevel = MemoryLevel 9 + +-- | A specific level in the range @1..9@ +-- +memoryLevel :: Int -> MemoryLevel +memoryLevel n + | n >= 1 && n <= 9 = MemoryLevel n + | otherwise = error "MemoryLevel must be in the range 1..9" + +fromMemoryLevel :: MemoryLevel -> CInt +fromMemoryLevel DefaultMemoryLevel = 8 +fromMemoryLevel MinMemoryLevel = 1 +fromMemoryLevel MaxMemoryLevel = 9 +fromMemoryLevel (MemoryLevel n) + | n >= 1 && n <= 9 = fromIntegral n + | otherwise = error "MemoryLevel must be in the range 1..9" + + +-- | The strategy parameter is used to tune the compression algorithm. +-- +-- The strategy parameter only affects the compression ratio but not the +-- correctness of the compressed output even if it is not set appropriately. +-- +data CompressionStrategy = + DefaultStrategy + | Filtered + | HuffmanOnly + +{- +-- -- only available in zlib 1.2 and later, uncomment if you need it. + | RLE -- ^ Use 'RLE' to limit match distances to one (run-length + -- encoding). 'RLE' is designed to be almost as fast as + -- 'HuffmanOnly', but give better compression for PNG + -- image data. + | Fixed -- ^ 'Fixed' prevents the use of dynamic Huffman codes, + -- allowing for a simpler decoder for special applications. +-} + +{-# DEPRECATED DefaultStrategy "Use defaultStrategy. CompressionStrategy constructors will be hidden in version 0.7" #-} +{-# DEPRECATED Filtered "Use filteredStrategy. CompressionStrategy constructors will be hidden in version 0.7" #-} +{-# DEPRECATED HuffmanOnly "Use huffmanOnlyStrategy. CompressionStrategy constructors will be hidden in version 0.7" #-} + +-- | Use this default compression strategy for normal data. +-- +defaultStrategy :: CompressionStrategy +defaultStrategy = DefaultStrategy + +-- | Use the filtered compression strategy for data produced by a filter (or +-- predictor). Filtered data consists mostly of small values with a somewhat +-- random distribution. In this case, the compression algorithm is tuned to +-- compress them better. The effect of this strategy is to force more Huffman +-- coding and less string matching; it is somewhat intermediate between +-- 'defaultCompressionStrategy' and 'huffmanOnlyCompressionStrategy'. +-- +filteredStrategy :: CompressionStrategy +filteredStrategy = Filtered + +-- | Use the Huffman-only compression strategy to force Huffman encoding only +-- (no string match). +-- +huffmanOnlyStrategy :: CompressionStrategy +huffmanOnlyStrategy = HuffmanOnly + + +fromCompressionStrategy :: CompressionStrategy -> CInt +fromCompressionStrategy DefaultStrategy = #{const Z_DEFAULT_STRATEGY} +fromCompressionStrategy Filtered = #{const Z_FILTERED} +fromCompressionStrategy HuffmanOnly = #{const Z_HUFFMAN_ONLY} +--fromCompressionStrategy RLE = #{const Z_RLE} +--fromCompressionStrategy Fixed = #{const Z_FIXED} + + +withStreamPtr :: (Ptr StreamState -> IO a) -> Stream a +withStreamPtr f = do + stream <- getStreamState + unsafeLiftIO (withForeignPtr stream f) + +withStreamState :: (StreamState -> IO a) -> Stream a +withStreamState f = do + stream <- getStreamState + unsafeLiftIO (withForeignPtr stream (f . StreamState)) + +setInAvail :: Int -> Stream () +setInAvail val = withStreamPtr $ \ptr -> + #{poke z_stream, avail_in} ptr (fromIntegral val :: CUInt) + +getInAvail :: Stream Int +getInAvail = liftM (fromIntegral :: CUInt -> Int) $ + withStreamPtr (#{peek z_stream, avail_in}) + +setInNext :: Ptr Word8 -> Stream () +setInNext val = withStreamPtr (\ptr -> #{poke z_stream, next_in} ptr val) + +#ifdef DEBUG +getInNext :: Stream (Ptr Word8) +getInNext = withStreamPtr (#{peek z_stream, next_in}) +#endif + +setOutFree :: Int -> Stream () +setOutFree val = withStreamPtr $ \ptr -> + #{poke z_stream, avail_out} ptr (fromIntegral val :: CUInt) + +getOutFree :: Stream Int +getOutFree = liftM (fromIntegral :: CUInt -> Int) $ + withStreamPtr (#{peek z_stream, avail_out}) + +setOutNext :: Ptr Word8 -> Stream () +setOutNext val = withStreamPtr (\ptr -> #{poke z_stream, next_out} ptr val) + +#ifdef DEBUG +getOutNext :: Stream (Ptr Word8) +getOutNext = withStreamPtr (#{peek z_stream, next_out}) +#endif + +inflateInit :: Format -> WindowBits -> Stream () +inflateInit format bits = do + checkFormatSupported format + err <- withStreamState $ \zstream -> + c_inflateInit2 zstream (fromIntegral (fromWindowBits format bits)) + failIfError err + getStreamState >>= unsafeLiftIO . addForeignPtrFinalizer c_inflateEnd + +deflateInit :: Format + -> CompressionLevel + -> Method + -> WindowBits + -> MemoryLevel + -> CompressionStrategy + -> Stream () +deflateInit format compLevel method bits memLevel strategy = do + checkFormatSupported format + err <- withStreamState $ \zstream -> + c_deflateInit2 zstream + (fromCompressionLevel compLevel) + (fromMethod method) + (fromWindowBits format bits) + (fromMemoryLevel memLevel) + (fromCompressionStrategy strategy) + failIfError err + getStreamState >>= unsafeLiftIO . addForeignPtrFinalizer c_deflateEnd + +inflate_ :: Flush -> Stream Status +inflate_ flush = do + err <- withStreamState $ \zstream -> + c_inflate zstream (fromFlush flush) + toStatus err + +deflate_ :: Flush -> Stream Status +deflate_ flush = do + err <- withStreamState $ \zstream -> + c_deflate zstream (fromFlush flush) + toStatus err + +-- | This never needs to be used as the stream's resources will be released +-- automatically when no longer needed, however this can be used to release +-- them early. Only use this when you can guarantee that the stream will no +-- longer be needed, for example if an error occurs or if the stream ends. +-- +finalise :: Stream () +#ifdef __GLASGOW_HASKELL__ +--TODO: finalizeForeignPtr is ghc-only +finalise = getStreamState >>= unsafeLiftIO . finalizeForeignPtr +#else +finalise = return () +#endif + +checkFormatSupported :: Format -> Stream () +checkFormatSupported format = do + version <- unsafeLiftIO (peekCAString =<< c_zlibVersion) + case version of + ('1':'.':'1':'.':_) + | format == GZip + || format == GZipOrZlib + -> fail $ "version 1.1.x of the zlib C library does not support the" + ++ " 'gzip' format via the in-memory api, only the 'raw' and " + ++ " 'zlib' formats." + _ -> return () + +---------------------- +-- The foreign imports + +newtype StreamState = StreamState (Ptr StreamState) + +-- inflateInit2 and deflateInit2 are actually defined as macros in zlib.h +-- They are defined in terms of inflateInit2_ and deflateInit2_ passing two +-- additional arguments used to detect compatability problems. They pass the +-- version of zlib as a char * and the size of the z_stream struct. +-- If we compile via C then we can avoid this hassle however thats not really +-- kosher since the Haskell FFI is defined at the C ABI level, not the C +-- language level. There is no requirement to compile via C and pick up C +-- headers. So it's much better if we can make it work properly and that'd +-- also allow compiling via ghc's ncg which is a good thing since the C +-- backend is not going to be around forever. +-- +-- So we define c_inflateInit2 and c_deflateInit2 here as wrappers around +-- their _ counterparts and pass the extra args. + +foreign import ccall unsafe "zlib.h inflateInit2_" + c_inflateInit2_ :: StreamState -> CInt -> Ptr CChar -> CInt -> IO CInt + +c_inflateInit2 :: StreamState -> CInt -> IO CInt +c_inflateInit2 z n = + withCAString #{const_str ZLIB_VERSION} $ \versionStr -> + c_inflateInit2_ z n versionStr (#{const sizeof(z_stream)} :: CInt) + +foreign import ccall unsafe "zlib.h inflate" + c_inflate :: StreamState -> CInt -> IO CInt + +foreign import ccall unsafe "zlib.h &inflateEnd" + c_inflateEnd :: FinalizerPtr StreamState + + +foreign import ccall unsafe "zlib.h deflateInit2_" + c_deflateInit2_ :: StreamState + -> CInt -> CInt -> CInt -> CInt -> CInt + -> Ptr CChar -> CInt + -> IO CInt + +c_deflateInit2 :: StreamState + -> CInt -> CInt -> CInt -> CInt -> CInt -> IO CInt +c_deflateInit2 z a b c d e = + withCAString #{const_str ZLIB_VERSION} $ \versionStr -> + c_deflateInit2_ z a b c d e versionStr (#{const sizeof(z_stream)} :: CInt) + +foreign import ccall unsafe "zlib.h deflate" + c_deflate :: StreamState -> CInt -> IO CInt + +foreign import ccall unsafe "zlib.h &deflateEnd" + c_deflateEnd :: FinalizerPtr StreamState + +foreign import ccall unsafe "zlib.h zlibVersion" + c_zlibVersion :: IO CString diff --git a/Control/Applicative/Backwards.hs b/Control/Applicative/Backwards.hs new file mode 100644 --- /dev/null +++ b/Control/Applicative/Backwards.hs @@ -0,0 +1,49 @@ +-- | +-- Module : Control.Applicative.Backwards +-- Copyright : (c) Russell O'Connor 2009 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Making functors with an 'Applicative' instance that performs actions +-- in the reverse order. + +module Control.Applicative.Backwards where + +import Prelude hiding (foldr, foldr1, foldl, foldl1) +import Control.Applicative +import Data.Foldable +import Data.Traversable + +-- | The same functor, but with an 'Applicative' instance that performs +-- actions in the reverse order. +newtype Backwards f a = Backwards { forwards :: f a } + +-- | Derived instance. +instance (Functor f) => Functor (Backwards f) where + fmap f (Backwards a) = Backwards (fmap f a) + +-- | Apply @f@-actions in the reverse order. +instance (Applicative f) => Applicative (Backwards f) where + pure a = Backwards (pure a) + Backwards f <*> Backwards a = Backwards (a <**> f) + +-- | Try alternatives in the same order as @f@. +instance (Alternative f) => Alternative (Backwards f) where + empty = Backwards empty + Backwards x <|> Backwards y = Backwards (x <|> y) + +-- | Derived instance. +instance (Foldable f) => Foldable (Backwards f) where + foldMap f (Backwards t) = foldMap f t + foldr f z (Backwards t) = foldr f z t + foldl f z (Backwards t) = foldl f z t + foldr1 f (Backwards t) = foldl1 f t + foldl1 f (Backwards t) = foldr1 f t + +-- | Derived instance. +instance (Traversable f) => Traversable (Backwards f) where + traverse f (Backwards t) = fmap Backwards (traverse f t) + sequenceA (Backwards t) = fmap Backwards (sequenceA t) diff --git a/Control/Applicative/Lift.hs b/Control/Applicative/Lift.hs new file mode 100644 --- /dev/null +++ b/Control/Applicative/Lift.hs @@ -0,0 +1,68 @@ +-- | +-- Module : Control.Applicative.Lift +-- Copyright : (c) Ross Paterson 2010 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : ross@soi.city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- Adding a new kind of pure computation to an applicative functor. + +module Control.Applicative.Lift ( + Lift(..), unLift, + -- * Collecting errors + Errors, failure + ) where + +import Control.Applicative +import Data.Foldable (Foldable(foldMap)) +import Data.Functor.Constant +import Data.Monoid (Monoid(mappend)) +import Data.Traversable (Traversable(traverse)) + +-- | Applicative functor formed by adding pure computations to a given +-- applicative functor. +data Lift f a = Pure a | Other (f a) + +instance (Functor f) => Functor (Lift f) where + fmap f (Pure x) = Pure (f x) + fmap f (Other y) = Other (fmap f y) + +instance (Foldable f) => Foldable (Lift f) where + foldMap f (Pure x) = f x + foldMap f (Other y) = foldMap f y + +instance (Traversable f) => Traversable (Lift f) where + traverse f (Pure x) = Pure <$> f x + traverse f (Other y) = Other <$> traverse f y + +-- | A combination is 'Pure' only if both parts are. +instance (Applicative f) => Applicative (Lift f) where + pure = Pure + Pure f <*> Pure x = Pure (f x) + Pure f <*> Other y = Other (f <$> y) + Other f <*> Pure x = Other (($ x) <$> f) + Other f <*> Other y = Other (f <*> y) + +-- | A combination is 'Pure' only either part is. +instance Alternative f => Alternative (Lift f) where + empty = Other empty + Pure x <|> _ = Pure x + Other _ <|> Pure y = Pure y + Other x <|> Other y = Other (x <|> y) + +-- | Projection to the other functor. +unLift :: Applicative f => Lift f a -> f a +unLift (Pure x) = pure x +unLift (Other e) = e + +-- | An applicative functor that collects a monoid (e.g. lists) of errors. +-- A sequence of computations fails if any of its components do, but +-- unlike monads made with 'ErrorT' from "Control.Monad.Trans.Error", +-- these computations continue after an error, collecting all the errors. +type Errors e = Lift (Constant e) + +-- | Report an error. +failure :: Monoid e => e -> Errors e a +failure e = Other (Constant e) diff --git a/Control/Monad/Cont.hs b/Control/Monad/Cont.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Cont.hs @@ -0,0 +1,168 @@ +{- | +Module : Control.Monad.Cont +Copyright : (c) The University of Glasgow 2001, + (c) Jeff Newbern 2003-2007, + (c) Andriy Palamarchuk 2007 +License : BSD-style (see the file LICENSE) + +Maintainer : libraries@haskell.org +Stability : experimental +Portability : portable + +[Computation type:] Computations which can be interrupted and resumed. + +[Binding strategy:] Binding a function to a monadic value creates +a new continuation which uses the function as the continuation of the monadic +computation. + +[Useful for:] Complex control structures, error handling, +and creating co-routines. + +[Zero and plus:] None. + +[Example type:] @'Cont' r a@ + +The Continuation monad represents computations in continuation-passing style +(CPS). +In continuation-passing style function result is not returned, +but instead is passed to another function, +received as a parameter (continuation). +Computations are built up from sequences +of nested continuations, terminated by a final continuation (often @id@) +which produces the final result. +Since continuations are functions which represent the future of a computation, +manipulation of the continuation functions can achieve complex manipulations +of the future of the computation, +such as interrupting a computation in the middle, aborting a portion +of a computation, restarting a computation, and interleaving execution of +computations. +The Continuation monad adapts CPS to the structure of a monad. + +Before using the Continuation monad, be sure that you have +a firm understanding of continuation-passing style +and that continuations represent the best solution to your particular +design problem. +Many algorithms which require continuations in other languages do not require +them in Haskell, due to Haskell's lazy semantics. +Abuse of the Continuation monad can produce code that is impossible +to understand and maintain. +-} + +module Control.Monad.Cont ( + -- * MonadCont class + MonadCont(..), + -- * The Cont monad + Cont, + cont, + runCont, + mapCont, + withCont, + -- * The ContT monad transformer + ContT(..), + mapContT, + withContT, + module Control.Monad, + module Control.Monad.Trans, + -- * Example 1: Simple Continuation Usage + -- $simpleContExample + + -- * Example 2: Using @callCC@ + -- $callCCExample + + -- * Example 3: Using @ContT@ Monad Transformer + -- $ContTExample + ) where + +import Control.Monad.Cont.Class + +import Control.Monad.Trans +import Control.Monad.Trans.Cont + +import Control.Monad + +{- $simpleContExample +Calculating length of a list continuation-style: + +>calculateLength :: [a] -> Cont r Int +>calculateLength l = return (length l) + +Here we use @calculateLength@ by making it to pass its result to @print@: + +>main = do +> runCont (calculateLength "123") print +> -- result: 3 + +It is possible to chain 'Cont' blocks with @>>=@. + +>double :: Int -> Cont r Int +>double n = return (n * 2) +> +>main = do +> runCont (calculateLength "123" >>= double) print +> -- result: 6 +-} + +{- $callCCExample +This example gives a taste of how escape continuations work, shows a typical +pattern for their usage. + +>-- Returns a string depending on the length of the name parameter. +>-- If the provided string is empty, returns an error. +>-- Otherwise, returns a welcome message. +>whatsYourName :: String -> String +>whatsYourName name = +> (`runCont` id) $ do -- 1 +> response <- callCC $ \exit -> do -- 2 +> validateName name exit -- 3 +> return $ "Welcome, " ++ name ++ "!" -- 4 +> return response -- 5 +> +>validateName name exit = do +> when (null name) (exit "You forgot to tell me your name!") + +Here is what this example does: + +(1) Runs an anonymous 'Cont' block and extracts value from it with +@(\`runCont\` id)@. Here @id@ is the continuation, passed to the @Cont@ block. + +(1) Binds @response@ to the result of the following 'Control.Monad.Cont.Class.callCC' block, +binds @exit@ to the continuation. + +(1) Validates @name@. +This approach illustrates advantage of using 'Control.Monad.Cont.Class.callCC' over @return@. +We pass the continuation to @validateName@, +and interrupt execution of the @Cont@ block from /inside/ of @validateName@. + +(1) Returns the welcome message from the 'Control.Monad.Cont.Class.callCC' block. +This line is not executed if @validateName@ fails. + +(1) Returns from the @Cont@ block. +-} + +{-$ContTExample +'ContT' can be used to add continuation handling to other monads. +Here is an example how to combine it with @IO@ monad: + +>import Control.Monad.Cont +>import System.IO +> +>main = do +> hSetBuffering stdout NoBuffering +> runContT (callCC askString) reportResult +> +>askString :: (String -> ContT () IO String) -> ContT () IO String +>askString next = do +> liftIO $ putStrLn "Please enter a string" +> s <- liftIO $ getLine +> next s +> +>reportResult :: String -> IO () +>reportResult s = do +> putStrLn ("You entered: " ++ s) + +Action @askString@ requests user to enter a string, +and passes it to the continuation. +@askString@ takes as a parameter a continuation taking a string parameter, +and returning @IO ()@. +Compare its signature to 'runContT' definition. +-} diff --git a/Control/Monad/Cont/Class.hs b/Control/Monad/Cont/Class.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Cont/Class.hs @@ -0,0 +1,130 @@ +{- | +Module : Control.Monad.Cont.Class +Copyright : (c) The University of Glasgow 2001, + (c) Jeff Newbern 2003-2007, + (c) Andriy Palamarchuk 2007 +License : BSD-style (see the file LICENSE) + +Maintainer : libraries@haskell.org +Stability : experimental +Portability : portable + +[Computation type:] Computations which can be interrupted and resumed. + +[Binding strategy:] Binding a function to a monadic value creates +a new continuation which uses the function as the continuation of the monadic +computation. + +[Useful for:] Complex control structures, error handling, +and creating co-routines. + +[Zero and plus:] None. + +[Example type:] @'Cont' r a@ + +The Continuation monad represents computations in continuation-passing style +(CPS). +In continuation-passing style function result is not returned, +but instead is passed to another function, +received as a parameter (continuation). +Computations are built up from sequences +of nested continuations, terminated by a final continuation (often @id@) +which produces the final result. +Since continuations are functions which represent the future of a computation, +manipulation of the continuation functions can achieve complex manipulations +of the future of the computation, +such as interrupting a computation in the middle, aborting a portion +of a computation, restarting a computation, and interleaving execution of +computations. +The Continuation monad adapts CPS to the structure of a monad. + +Before using the Continuation monad, be sure that you have +a firm understanding of continuation-passing style +and that continuations represent the best solution to your particular +design problem. +Many algorithms which require continuations in other languages do not require +them in Haskell, due to Haskell's lazy semantics. +Abuse of the Continuation monad can produce code that is impossible +to understand and maintain. +-} + +module Control.Monad.Cont.Class ( + MonadCont(..), + ) where + +import Control.Monad.Trans.Cont (ContT) +import qualified Control.Monad.Trans.Cont as ContT +import Control.Monad.Trans.Error as Error +import Control.Monad.Trans.Identity as Identity +import Control.Monad.Trans.List as List +import Control.Monad.Trans.Maybe as Maybe +import Control.Monad.Trans.Reader as Reader +import Control.Monad.Trans.RWS.Lazy as LazyRWS +import Control.Monad.Trans.RWS.Strict as StrictRWS +import Control.Monad.Trans.State.Lazy as LazyState +import Control.Monad.Trans.State.Strict as StrictState +import Control.Monad.Trans.Writer.Lazy as LazyWriter +import Control.Monad.Trans.Writer.Strict as StrictWriter + +import Control.Monad +import Data.Monoid + +class Monad m => MonadCont m where + {- | @callCC@ (call-with-current-continuation) + calls a function with the current continuation as its argument. + Provides an escape continuation mechanism for use with Continuation monads. + Escape continuations allow to abort the current computation and return + a value immediately. + They achieve a similar effect to 'Control.Monad.Error.throwError' + and 'Control.Monad.Error.catchError' + within an 'Control.Monad.Error.Error' monad. + Advantage of this function over calling @return@ is that it makes + the continuation explicit, + allowing more flexibility and better control + (see examples in "Control.Monad.Cont"). + + The standard idiom used with @callCC@ is to provide a lambda-expression + to name the continuation. Then calling the named continuation anywhere + within its scope will escape from the computation, + even if it is many layers deep within nested computations. + -} + callCC :: ((a -> m b) -> m a) -> m a + +instance MonadCont (ContT r m) where + callCC = ContT.callCC + +-- --------------------------------------------------------------------------- +-- Instances for other mtl transformers + +instance (Error e, MonadCont m) => MonadCont (ErrorT e m) where + callCC = Error.liftCallCC callCC + +instance MonadCont m => MonadCont (IdentityT m) where + callCC = Identity.liftCallCC callCC + +instance MonadCont m => MonadCont (ListT m) where + callCC = List.liftCallCC callCC + +instance MonadCont m => MonadCont (MaybeT m) where + callCC = Maybe.liftCallCC callCC + +instance MonadCont m => MonadCont (ReaderT r m) where + callCC = Reader.liftCallCC callCC + +instance (Monoid w, MonadCont m) => MonadCont (LazyRWS.RWST r w s m) where + callCC = LazyRWS.liftCallCC' callCC + +instance (Monoid w, MonadCont m) => MonadCont (StrictRWS.RWST r w s m) where + callCC = StrictRWS.liftCallCC' callCC + +instance MonadCont m => MonadCont (LazyState.StateT s m) where + callCC = LazyState.liftCallCC' callCC + +instance MonadCont m => MonadCont (StrictState.StateT s m) where + callCC = StrictState.liftCallCC' callCC + +instance (Monoid w, MonadCont m) => MonadCont (LazyWriter.WriterT w m) where + callCC = LazyWriter.liftCallCC callCC + +instance (Monoid w, MonadCont m) => MonadCont (StrictWriter.WriterT w m) where + callCC = StrictWriter.liftCallCC callCC diff --git a/Control/Monad/Error.hs b/Control/Monad/Error.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Error.hs @@ -0,0 +1,145 @@ +{- | +Module : Control.Monad.Error +Copyright : (c) Michael Weber 2001, + (c) Jeff Newbern 2003-2006, + (c) Andriy Palamarchuk 2006 +License : BSD-style (see the file LICENSE) + +Maintainer : libraries@haskell.org +Stability : experimental +Portability : non-portable (multi-parameter type classes) + +[Computation type:] Computations which may fail or throw exceptions. + +[Binding strategy:] Failure records information about the cause\/location +of the failure. Failure values bypass the bound function, +other values are used as inputs to the bound function. + +[Useful for:] Building computations from sequences of functions that may fail +or using exception handling to structure error handling. + +[Zero and plus:] Zero is represented by an empty error and the plus operation +executes its second argument if the first fails. + +[Example type:] @'Data.Either' String a@ + +The Error monad (also called the Exception monad). +-} + +{- + Rendered by Michael Weber , + inspired by the Haskell Monad Template Library from + Andy Gill () +-} +module Control.Monad.Error ( + -- * Monads with error handling + MonadError(..), + Error(..), + -- * The ErrorT monad transformer + ErrorT(..), + mapErrorT, + module Control.Monad, + module Control.Monad.Fix, + module Control.Monad.Trans, + -- * Example 1: Custom Error Data Type + -- $customErrorExample + + -- * Example 2: Using ErrorT Monad Transformer + -- $ErrorTExample + ) where + +import Control.Monad.Error.Class +import Control.Monad.Trans +import Control.Monad.Trans.Error (ErrorT(..), mapErrorT) + +import Control.Monad +import Control.Monad.Fix +import Control.Monad.Instances () + +{- $customErrorExample +Here is an example that demonstrates the use of a custom 'Error' data type with +the 'throwError' and 'catchError' exception mechanism from 'MonadError'. +The example throws an exception if the user enters an empty string +or a string longer than 5 characters. Otherwise it prints length of the string. + +>-- This is the type to represent length calculation error. +>data LengthError = EmptyString -- Entered string was empty. +> | StringTooLong Int -- A string is longer than 5 characters. +> -- Records a length of the string. +> | OtherError String -- Other error, stores the problem description. +> +>-- We make LengthError an instance of the Error class +>-- to be able to throw it as an exception. +>instance Error LengthError where +> noMsg = OtherError "A String Error!" +> strMsg s = OtherError s +> +>-- Converts LengthError to a readable message. +>instance Show LengthError where +> show EmptyString = "The string was empty!" +> show (StringTooLong len) = +> "The length of the string (" ++ (show len) ++ ") is bigger than 5!" +> show (OtherError msg) = msg +> +>-- For our monad type constructor, we use Either LengthError +>-- which represents failure using Left LengthError +>-- or a successful result of type a using Right a. +>type LengthMonad = Either LengthError +> +>main = do +> putStrLn "Please enter a string:" +> s <- getLine +> reportResult (calculateLength s) +> +>-- Wraps length calculation to catch the errors. +>-- Returns either length of the string or an error. +>calculateLength :: String -> LengthMonad Int +>calculateLength s = (calculateLengthOrFail s) `catchError` Left +> +>-- Attempts to calculate length and throws an error if the provided string is +>-- empty or longer than 5 characters. +>-- The processing is done in Either monad. +>calculateLengthOrFail :: String -> LengthMonad Int +>calculateLengthOrFail [] = throwError EmptyString +>calculateLengthOrFail s | len > 5 = throwError (StringTooLong len) +> | otherwise = return len +> where len = length s +> +>-- Prints result of the string length calculation. +>reportResult :: LengthMonad Int -> IO () +>reportResult (Right len) = putStrLn ("The length of the string is " ++ (show len)) +>reportResult (Left e) = putStrLn ("Length calculation failed with error: " ++ (show e)) +-} + +{- $ErrorTExample +@'ErrorT'@ monad transformer can be used to add error handling to another monad. +Here is an example how to combine it with an @IO@ monad: + +>import Control.Monad.Error +> +>-- An IO monad which can return String failure. +>-- It is convenient to define the monad type of the combined monad, +>-- especially if we combine more monad transformers. +>type LengthMonad = ErrorT String IO +> +>main = do +> -- runErrorT removes the ErrorT wrapper +> r <- runErrorT calculateLength +> reportResult r +> +>-- Asks user for a non-empty string and returns its length. +>-- Throws an error if user enters an empty string. +>calculateLength :: LengthMonad Int +>calculateLength = do +> -- all the IO operations have to be lifted to the IO monad in the monad stack +> liftIO $ putStrLn "Please enter a non-empty string: " +> s <- liftIO getLine +> if null s +> then throwError "The string was empty!" +> else return $ length s +> +>-- Prints result of the string length calculation. +>reportResult :: Either String Int -> IO () +>reportResult (Right len) = putStrLn ("The length of the string is " ++ (show len)) +>reportResult (Left e) = putStrLn ("Length calculation failed with error: " ++ (show e)) +-} diff --git a/Control/Monad/Error/Class.hs b/Control/Monad/Error/Class.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Error/Class.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE UndecidableInstances #-} + +{- | +Module : Control.Monad.Error.Class +Copyright : (c) Michael Weber 2001, + (c) Jeff Newbern 2003-2006, + (c) Andriy Palamarchuk 2006 +License : BSD-style (see the file LICENSE) + +Maintainer : libraries@haskell.org +Stability : experimental +Portability : non-portable (multi-parameter type classes) + +[Computation type:] Computations which may fail or throw exceptions. + +[Binding strategy:] Failure records information about the cause\/location +of the failure. Failure values bypass the bound function, +other values are used as inputs to the bound function. + +[Useful for:] Building computations from sequences of functions that may fail +or using exception handling to structure error handling. + +[Zero and plus:] Zero is represented by an empty error and the plus operation +executes its second argument if the first fails. + +[Example type:] @'Either' 'String' a@ + +The Error monad (also called the Exception monad). +-} + +{- + Rendered by Michael Weber , + inspired by the Haskell Monad Template Library from + Andy Gill () +-} +module Control.Monad.Error.Class ( + Error(..), + MonadError(..), + ) where + +import Control.Monad.Trans.Error (Error(..), ErrorT) +import qualified Control.Monad.Trans.Error as ErrorT (throwError, catchError) +import Control.Monad.Trans.Identity as Identity +import Control.Monad.Trans.List as List +import Control.Monad.Trans.Maybe as Maybe +import Control.Monad.Trans.Reader as Reader +import Control.Monad.Trans.RWS.Lazy as LazyRWS +import Control.Monad.Trans.RWS.Strict as StrictRWS +import Control.Monad.Trans.State.Lazy as LazyState +import Control.Monad.Trans.State.Strict as StrictState +import Control.Monad.Trans.Writer.Lazy as LazyWriter +import Control.Monad.Trans.Writer.Strict as StrictWriter + +import Control.Monad.Trans.Class (lift) +import Control.Exception (IOException) +import Control.Monad +import Control.Monad.Instances () +import Data.Monoid + +{- | +The strategy of combining computations that can throw exceptions +by bypassing bound functions +from the point an exception is thrown to the point that it is handled. + +Is parameterized over the type of error information and +the monad type constructor. +It is common to use @'Data.Either' String@ as the monad type constructor +for an error monad in which error descriptions take the form of strings. +In that case and many other common cases the resulting monad is already defined +as an instance of the 'MonadError' class. +You can also define your own error type and\/or use a monad type constructor +other than @'Either' 'String'@ or @'Either' 'IOError'@. +In these cases you will have to explicitly define instances of the 'Error' +and\/or 'MonadError' classes. +-} +class (Monad m) => MonadError e m | m -> e where + -- | Is used within a monadic computation to begin exception processing. + throwError :: e -> m a + + {- | + A handler function to handle previous errors and return to normal execution. + A common idiom is: + + > do { action1; action2; action3 } `catchError` handler + + where the @action@ functions can call 'throwError'. + Note that @handler@ and the do-block must have the same return type. + -} + catchError :: m a -> (e -> m a) -> m a + +instance MonadError IOException IO where + throwError = ioError + catchError = catch + +-- --------------------------------------------------------------------------- +-- Our parameterizable error monad + +instance Error e => MonadError e (Either e) where + throwError = Left + Left l `catchError` h = h l + Right r `catchError` _ = Right r + +instance (Monad m, Error e) => MonadError e (ErrorT e m) where + throwError = ErrorT.throwError + catchError = ErrorT.catchError + +-- --------------------------------------------------------------------------- +-- Instances for other mtl transformers +-- +-- All of these instances need UndecidableInstances, +-- because they do not satisfy the coverage condition. + +instance MonadError e m => MonadError e (IdentityT m) where + throwError = lift . throwError + catchError = Identity.liftCatch catchError + +instance MonadError e m => MonadError e (ListT m) where + throwError = lift . throwError + catchError = List.liftCatch catchError + +instance MonadError e m => MonadError e (MaybeT m) where + throwError = lift . throwError + catchError = Maybe.liftCatch catchError + +instance MonadError e m => MonadError e (ReaderT r m) where + throwError = lift . throwError + catchError = Reader.liftCatch catchError + +instance (Monoid w, MonadError e m) => MonadError e (LazyRWS.RWST r w s m) where + throwError = lift . throwError + catchError = LazyRWS.liftCatch catchError + +instance (Monoid w, MonadError e m) => MonadError e (StrictRWS.RWST r w s m) where + throwError = lift . throwError + catchError = StrictRWS.liftCatch catchError + +instance MonadError e m => MonadError e (LazyState.StateT s m) where + throwError = lift . throwError + catchError = LazyState.liftCatch catchError + +instance MonadError e m => MonadError e (StrictState.StateT s m) where + throwError = lift . throwError + catchError = StrictState.liftCatch catchError + +instance (Monoid w, MonadError e m) => MonadError e (LazyWriter.WriterT w m) where + throwError = lift . throwError + catchError = LazyWriter.liftCatch catchError + +instance (Monoid w, MonadError e m) => MonadError e (StrictWriter.WriterT w m) where + throwError = lift . throwError + catchError = StrictWriter.liftCatch catchError diff --git a/Control/Monad/IO/Class.hs b/Control/Monad/IO/Class.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/IO/Class.hs @@ -0,0 +1,37 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.IO.Class +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : ross@soi.city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- Class of monads based on @IO@. +----------------------------------------------------------------------------- + +module Control.Monad.IO.Class ( + MonadIO(..) + ) where + +import System.IO (IO) + +-- | Monads in which 'IO' computations may be embedded. +-- Any monad built by applying a sequence of monad transformers to the +-- 'IO' monad will be an instance of this class. +-- +-- Instances should satisfy the following laws, which state that 'liftIO' +-- is a transformer of monads: +-- +-- * @'liftIO' . 'return' = 'return'@ +-- +-- * @'liftIO' (m >>= f) = 'liftIO' m >>= ('liftIO' . f)@ + +class (Monad m) => MonadIO m where + -- | Lift a computation from the 'IO' monad. + liftIO :: IO a -> m a + +instance MonadIO IO where + liftIO = id diff --git a/Control/Monad/Identity.hs b/Control/Monad/Identity.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Identity.hs @@ -0,0 +1,44 @@ +{- | +Module : Control.Monad.Identity +Copyright : (c) Andy Gill 2001, + (c) Oregon Graduate Institute of Science and Technology 2001, + (c) Jeff Newbern 2003-2006, + (c) Andriy Palamarchuk 2006 +License : BSD-style (see the file LICENSE) + +Maintainer : libraries@haskell.org +Stability : experimental +Portability : portable + +[Computation type:] Simple function application. + +[Binding strategy:] The bound function is applied to the input value. +@'Identity' x >>= f == 'Identity' (f x)@ + +[Useful for:] Monads can be derived from monad transformers applied to the +'Identity' monad. + +[Zero and plus:] None. + +[Example type:] @'Identity' a@ + +The @Identity@ monad is a monad that does not embody any computational strategy. +It simply applies the bound function to its input without any modification. +Computationally, there is no reason to use the @Identity@ monad +instead of the much simpler act of simply applying functions to their arguments. +The purpose of the @Identity@ monad is its fundamental role in the theory +of monad transformers. +Any monad transformer applied to the @Identity@ monad yields a non-transformer +version of that monad. +-} + +module Control.Monad.Identity ( + module Data.Functor.Identity, + + module Control.Monad, + module Control.Monad.Fix, + ) where + +import Control.Monad +import Control.Monad.Fix +import Data.Functor.Identity diff --git a/Control/Monad/List.hs b/Control/Monad/List.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/List.hs @@ -0,0 +1,25 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.List +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- The List monad. +-- +----------------------------------------------------------------------------- + +module Control.Monad.List ( + ListT(..), + mapListT, + module Control.Monad, + module Control.Monad.Trans, + ) where + +import Control.Monad +import Control.Monad.Trans +import Control.Monad.Trans.List diff --git a/Control/Monad/RWS.hs b/Control/Monad/RWS.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/RWS.hs @@ -0,0 +1,24 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.RWS +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (multi-param classes, functional dependencies) +-- +-- Declaration of the MonadRWS class. +-- +-- Inspired by the paper +-- /Functional Programming with Overloading and Higher-Order Polymorphism/, +-- Mark P Jones () +-- Advanced School of Functional Programming, 1995. +----------------------------------------------------------------------------- + +module Control.Monad.RWS ( + module Control.Monad.RWS.Lazy + ) where + +import Control.Monad.RWS.Lazy diff --git a/Control/Monad/RWS/Class.hs b/Control/Monad/RWS/Class.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/RWS/Class.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE UndecidableInstances #-} +-- Search for UndecidableInstances to see why this is needed + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.RWS.Class +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (multi-param classes, functional dependencies) +-- +-- Declaration of the MonadRWS class. +-- +-- Inspired by the paper +-- /Functional Programming with Overloading and Higher-Order Polymorphism/, +-- Mark P Jones () +-- Advanced School of Functional Programming, 1995. +----------------------------------------------------------------------------- + +module Control.Monad.RWS.Class ( + MonadRWS, + module Control.Monad.Reader.Class, + module Control.Monad.State.Class, + module Control.Monad.Writer.Class, + ) where + +import Control.Monad.Reader.Class +import Control.Monad.State.Class +import Control.Monad.Writer.Class + +import Control.Monad.Trans.Class +import Control.Monad.Trans.Error(Error, ErrorT) +import Control.Monad.Trans.Maybe(MaybeT) +import Control.Monad.Trans.Identity(IdentityT) +import Control.Monad.Trans.RWS.Lazy as Lazy (RWST) +import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST) + +import Data.Monoid + +class (Monoid w, MonadReader r m, MonadWriter w m, MonadState s m) + => MonadRWS r w s m | m -> r, m -> w, m -> s + +instance (Monoid w, Monad m) => MonadRWS r w s (Lazy.RWST r w s m) + +instance (Monoid w, Monad m) => MonadRWS r w s (Strict.RWST r w s m) + +--------------------------------------------------------------------------- +-- Instances for other mtl transformers +-- +-- All of these instances need UndecidableInstances, +-- because they do not satisfy the coverage condition. + +instance (Error e, MonadRWS r w s m) => MonadRWS r w s (ErrorT e m) +instance MonadRWS r w s m => MonadRWS r w s (IdentityT m) +instance MonadRWS r w s m => MonadRWS r w s (MaybeT m) diff --git a/Control/Monad/RWS/Lazy.hs b/Control/Monad/RWS/Lazy.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/RWS/Lazy.hs @@ -0,0 +1,52 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.RWS.Lazy +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (multi-param classes, functional dependencies) +-- +-- Lazy RWS monad. +-- +-- Inspired by the paper +-- /Functional Programming with Overloading and Higher-Order Polymorphism/, +-- Mark P Jones () +-- Advanced School of Functional Programming, 1995. +----------------------------------------------------------------------------- + +module Control.Monad.RWS.Lazy ( + -- * The RWS monad + RWS, + rws, + runRWS, + evalRWS, + execRWS, + mapRWS, + withRWS, + -- * The RWST monad transformer + RWST(..), + evalRWST, + execRWST, + mapRWST, + withRWST, + -- * Lazy Reader-writer-state monads + module Control.Monad.RWS.Class, + module Control.Monad, + module Control.Monad.Fix, + module Control.Monad.Trans, + module Data.Monoid, + ) where + +import Control.Monad.RWS.Class + +import Control.Monad.Trans +import Control.Monad.Trans.RWS.Lazy ( + RWS, rws, runRWS, evalRWS, execRWS, mapRWS, withRWS, + RWST(..), evalRWST, execRWST, mapRWST, withRWST) + +import Control.Monad +import Control.Monad.Fix +import Data.Monoid diff --git a/Control/Monad/RWS/Strict.hs b/Control/Monad/RWS/Strict.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/RWS/Strict.hs @@ -0,0 +1,52 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.RWS.Strict +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (multi-param classes, functional dependencies) +-- +-- Strict RWS monad. +-- +-- Inspired by the paper +-- /Functional Programming with Overloading and Higher-Order Polymorphism/, +-- Mark P Jones () +-- Advanced School of Functional Programming, 1995. +----------------------------------------------------------------------------- + +module Control.Monad.RWS.Strict ( + -- * The RWS monad + RWS, + rws, + runRWS, + evalRWS, + execRWS, + mapRWS, + withRWS, + -- * The RWST monad transformer + RWST(..), + evalRWST, + execRWST, + mapRWST, + withRWST, + -- * Strict Reader-writer-state monads + module Control.Monad.RWS.Class, + module Control.Monad, + module Control.Monad.Fix, + module Control.Monad.Trans, + module Data.Monoid, + ) where + +import Control.Monad.RWS.Class + +import Control.Monad.Trans +import Control.Monad.Trans.RWS.Strict ( + RWS, rws, runRWS, evalRWS, execRWS, mapRWS, withRWS, + RWST(..), evalRWST, execRWST, mapRWST, withRWST) + +import Control.Monad +import Control.Monad.Fix +import Data.Monoid diff --git a/Control/Monad/Reader.hs b/Control/Monad/Reader.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Reader.hs @@ -0,0 +1,143 @@ +{- | +Module : Control.Monad.Reader +Copyright : (c) Andy Gill 2001, + (c) Oregon Graduate Institute of Science and Technology 2001, + (c) Jeff Newbern 2003-2007, + (c) Andriy Palamarchuk 2007 +License : BSD-style (see the file LICENSE) + +Maintainer : libraries@haskell.org +Stability : experimental +Portability : non-portable (multi-param classes, functional dependencies) + +[Computation type:] Computations which read values from a shared environment. + +[Binding strategy:] Monad values are functions from the environment to a value. +The bound function is applied to the bound value, and both have access +to the shared environment. + +[Useful for:] Maintaining variable bindings, or other shared environment. + +[Zero and plus:] None. + +[Example type:] @'Reader' [(String,Value)] a@ + +The 'Reader' monad (also called the Environment monad). +Represents a computation, which can read values from +a shared environment, pass values from function to function, +and execute sub-computations in a modified environment. +Using 'Reader' monad for such computations is often clearer and easier +than using the 'Control.Monad.State.State' monad. + + Inspired by the paper + /Functional Programming with Overloading and Higher-Order Polymorphism/, + Mark P Jones () + Advanced School of Functional Programming, 1995. +-} + +module Control.Monad.Reader ( + -- * MonadReader class + MonadReader(..), + asks, + -- * The Reader monad + Reader, + runReader, + mapReader, + withReader, + -- * The ReaderT monad transformer + ReaderT(..), + mapReaderT, + withReaderT, + module Control.Monad, + module Control.Monad.Fix, + module Control.Monad.Trans, + -- * Example 1: Simple Reader Usage + -- $simpleReaderExample + + -- * Example 2: Modifying Reader Content With @local@ + -- $localExample + + -- * Example 3: @ReaderT@ Monad Transformer + -- $ReaderTExample + ) where + +import Control.Monad.Reader.Class + +import Control.Monad.Trans.Reader ( + Reader, runReader, mapReader, withReader, + ReaderT(..), mapReaderT, withReaderT) +import Control.Monad.Trans + +import Control.Monad +import Control.Monad.Fix + +{- $simpleReaderExample + +In this example the @Reader@ monad provides access to variable bindings. +Bindings are a @Map@ of integer variables. +The variable @count@ contains number of variables in the bindings. +You can see how to run a Reader monad and retrieve data from it +with 'runReader', how to access the Reader data with 'ask' and 'asks'. + +> type Bindings = Map String Int; +> +>-- Returns True if the "count" variable contains correct bindings size. +>isCountCorrect :: Bindings -> Bool +>isCountCorrect bindings = runReader calc_isCountCorrect bindings +> +>-- The Reader monad, which implements this complicated check. +>calc_isCountCorrect :: Reader Bindings Bool +>calc_isCountCorrect = do +> count <- asks (lookupVar "count") +> bindings <- ask +> return (count == (Map.size bindings)) +> +>-- The selector function to use with 'asks'. +>-- Returns value of the variable with specified name. +>lookupVar :: String -> Bindings -> Int +>lookupVar name bindings = fromJust (Map.lookup name bindings) +> +>sampleBindings = Map.fromList [("count",3), ("1",1), ("b",2)] +> +>main = do +> putStr $ "Count is correct for bindings " ++ (show sampleBindings) ++ ": "; +> putStrLn $ show (isCountCorrect sampleBindings); +-} + +{- $localExample + +Shows how to modify Reader content with 'local'. + +>calculateContentLen :: Reader String Int +>calculateContentLen = do +> content <- ask +> return (length content); +> +>-- Calls calculateContentLen after adding a prefix to the Reader content. +>calculateModifiedContentLen :: Reader String Int +>calculateModifiedContentLen = local ("Prefix " ++) calculateContentLen +> +>main = do +> let s = "12345"; +> let modifiedLen = runReader calculateModifiedContentLen s +> let len = runReader calculateContentLen s +> putStrLn $ "Modified 's' length: " ++ (show modifiedLen) +> putStrLn $ "Original 's' length: " ++ (show len) +-} + +{- $ReaderTExample + +Now you are thinking: 'Wow, what a great monad! I wish I could use +Reader functionality in MyFavoriteComplexMonad!'. Don't worry. +This can be easy done with the 'ReaderT' monad transformer. +This example shows how to combine @ReaderT@ with the IO monad. + +>-- The Reader/IO combined monad, where Reader stores a string. +>printReaderContent :: ReaderT String IO () +>printReaderContent = do +> content <- ask +> liftIO $ putStrLn ("The Reader Content: " ++ content) +> +>main = do +> runReaderT printReaderContent "Some Content" +-} diff --git a/Control/Monad/Reader/Class.hs b/Control/Monad/Reader/Class.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Reader/Class.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE UndecidableInstances #-} +-- Search for UndecidableInstances to see why this is needed +{- | +Module : Control.Monad.Reader.Class +Copyright : (c) Andy Gill 2001, + (c) Oregon Graduate Institute of Science and Technology 2001, + (c) Jeff Newbern 2003-2007, + (c) Andriy Palamarchuk 2007 +License : BSD-style (see the file LICENSE) + +Maintainer : libraries@haskell.org +Stability : experimental +Portability : non-portable (multi-param classes, functional dependencies) + +[Computation type:] Computations which read values from a shared environment. + +[Binding strategy:] Monad values are functions from the environment to a value. +The bound function is applied to the bound value, and both have access +to the shared environment. + +[Useful for:] Maintaining variable bindings, or other shared environment. + +[Zero and plus:] None. + +[Example type:] @'Reader' [(String,Value)] a@ + +The 'Reader' monad (also called the Environment monad). +Represents a computation, which can read values from +a shared environment, pass values from function to function, +and execute sub-computations in a modified environment. +Using 'Reader' monad for such computations is often clearer and easier +than using the 'Control.Monad.State.State' monad. + + Inspired by the paper + /Functional Programming with Overloading and Higher-Order Polymorphism/, + Mark P Jones () + Advanced School of Functional Programming, 1995. +-} + +module Control.Monad.Reader.Class ( + MonadReader(..), + asks, + ) where + +import Control.Monad.Trans.Cont as Cont +import Control.Monad.Trans.Error +import Control.Monad.Trans.Identity +import Control.Monad.Trans.List +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Reader (ReaderT) +import qualified Control.Monad.Trans.Reader as ReaderT (ask, local, reader) +import qualified Control.Monad.Trans.RWS.Lazy as LazyRWS (RWST, ask, local, reader) +import qualified Control.Monad.Trans.RWS.Strict as StrictRWS (RWST, ask, local, reader) +import Control.Monad.Trans.State.Lazy as Lazy +import Control.Monad.Trans.State.Strict as Strict +import Control.Monad.Trans.Writer.Lazy as Lazy +import Control.Monad.Trans.Writer.Strict as Strict + +import Control.Monad.Trans.Class (lift) +import Control.Monad +import Data.Monoid + +-- ---------------------------------------------------------------------------- +-- class MonadReader +-- asks for the internal (non-mutable) state. + +-- | See examples in "Control.Monad.Reader". +-- Note, the partially applied function type @(->) r@ is a simple reader monad. +-- See the @instance@ declaration below. +class Monad m => MonadReader r m | m -> r where + -- | Retrieves the monad environment. + ask :: m r + + -- | Executes a computation in a modified environment. + local :: (r -> r) -- ^ The function to modify the environment. + -> m a -- ^ @Reader@ to run in the modified environment. + -> m a + + -- | Retrieves a function of the current environment. + reader :: (r -> a) -- ^ The selector function to apply to the environment. + -> m a + reader f = do + r <- ask + return (f r) + +-- | Retrieves a function of the current environment. +asks :: MonadReader r m + => (r -> a) -- ^ The selector function to apply to the environment. + -> m a +asks = reader + +-- ---------------------------------------------------------------------------- +-- The partially applied function type is a simple reader monad + +instance MonadReader r ((->) r) where + ask = id + local f m = m . f + reader = id + +instance Monad m => MonadReader r (ReaderT r m) where + ask = ReaderT.ask + local = ReaderT.local + reader = ReaderT.reader + +instance (Monad m, Monoid w) => MonadReader r (LazyRWS.RWST r w s m) where + ask = LazyRWS.ask + local = LazyRWS.local + reader = LazyRWS.reader + +instance (Monad m, Monoid w) => MonadReader r (StrictRWS.RWST r w s m) where + ask = StrictRWS.ask + local = StrictRWS.local + reader = StrictRWS.reader + +-- --------------------------------------------------------------------------- +-- Instances for other mtl transformers +-- +-- All of these instances need UndecidableInstances, +-- because they do not satisfy the coverage condition. + +instance MonadReader r' m => MonadReader r' (ContT r m) where + ask = lift ask + local = Cont.liftLocal ask local + reader = lift . reader + +instance (Error e, MonadReader r m) => MonadReader r (ErrorT e m) where + ask = lift ask + local = mapErrorT . local + reader = lift . reader + +instance MonadReader r m => MonadReader r (IdentityT m) where + ask = lift ask + local = mapIdentityT . local + reader = lift . reader + +instance MonadReader r m => MonadReader r (ListT m) where + ask = lift ask + local = mapListT . local + reader = lift . reader + +instance MonadReader r m => MonadReader r (MaybeT m) where + ask = lift ask + local = mapMaybeT . local + reader = lift . reader + +instance MonadReader r m => MonadReader r (Lazy.StateT s m) where + ask = lift ask + local = Lazy.mapStateT . local + reader = lift . reader + +instance MonadReader r m => MonadReader r (Strict.StateT s m) where + ask = lift ask + local = Strict.mapStateT . local + reader = lift . reader + +instance (Monoid w, MonadReader r m) => MonadReader r (Lazy.WriterT w m) where + ask = lift ask + local = Lazy.mapWriterT . local + reader = lift . reader + +instance (Monoid w, MonadReader r m) => MonadReader r (Strict.WriterT w m) where + ask = lift ask + local = Strict.mapWriterT . local + reader = lift . reader diff --git a/Control/Monad/State.hs b/Control/Monad/State.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/State.hs @@ -0,0 +1,25 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.State +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (multi-param classes, functional dependencies) +-- +-- State monads. +-- +-- This module is inspired by the paper +-- /Functional Programming with Overloading and Higher-Order Polymorphism/, +-- Mark P Jones () +-- Advanced School of Functional Programming, 1995. + +----------------------------------------------------------------------------- + +module Control.Monad.State ( + module Control.Monad.State.Lazy + ) where + +import Control.Monad.State.Lazy diff --git a/Control/Monad/State/Class.hs b/Control/Monad/State/Class.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/State/Class.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE UndecidableInstances #-} +-- Search for UndecidableInstances to see why this is needed + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.State.Class +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (multi-param classes, functional dependencies) +-- +-- MonadState class. +-- +-- This module is inspired by the paper +-- /Functional Programming with Overloading and Higher-Order Polymorphism/, +-- Mark P Jones () +-- Advanced School of Functional Programming, 1995. + +----------------------------------------------------------------------------- + +module Control.Monad.State.Class ( + MonadState(..), + modify, + gets, + ) where + +import Control.Monad.Trans.Cont +import Control.Monad.Trans.Error +import Control.Monad.Trans.Identity +import Control.Monad.Trans.List +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Reader +import qualified Control.Monad.Trans.RWS.Lazy as LazyRWS (RWST, get, put, state) +import qualified Control.Monad.Trans.RWS.Strict as StrictRWS (RWST, get, put, state) +import qualified Control.Monad.Trans.State.Lazy as Lazy (StateT, get, put, state) +import qualified Control.Monad.Trans.State.Strict as Strict (StateT, get, put, state) +import Control.Monad.Trans.Writer.Lazy as Lazy +import Control.Monad.Trans.Writer.Strict as Strict + +import Control.Monad.Trans.Class (lift) +import Control.Monad +import Data.Monoid + +-- --------------------------------------------------------------------------- + +-- | Minimal definition is either both of @get@ and @put@ or just @state@ +class Monad m => MonadState s m | m -> s where + -- | Return the state from the internals of the monad. + get :: m s + get = state (\s -> (s, s)) + + -- | Replace the state inside the monad. + put :: s -> m () + put s = state (\_ -> ((), s)) + + -- | Embed a simple state action into the monad. + state :: (s -> (a, s)) -> m a + state f = do + s <- get + let ~(a, s') = f s + put s' + return a + +-- | Monadic state transformer. +-- +-- Maps an old state to a new state inside a state monad. +-- The old state is thrown away. +-- +-- > Main> :t modify ((+1) :: Int -> Int) +-- > modify (...) :: (MonadState Int a) => a () +-- +-- This says that @modify (+1)@ acts over any +-- Monad that is a member of the @MonadState@ class, +-- with an @Int@ state. +modify :: MonadState s m => (s -> s) -> m () +modify f = state (\s -> ((), f s)) + +-- | Gets specific component of the state, using a projection function +-- supplied. +gets :: MonadState s m => (s -> a) -> m a +gets f = do + s <- get + return (f s) + +instance Monad m => MonadState s (Lazy.StateT s m) where + get = Lazy.get + put = Lazy.put + state = Lazy.state + +instance Monad m => MonadState s (Strict.StateT s m) where + get = Strict.get + put = Strict.put + state = Strict.state + +instance (Monad m, Monoid w) => MonadState s (LazyRWS.RWST r w s m) where + get = LazyRWS.get + put = LazyRWS.put + state = LazyRWS.state + +instance (Monad m, Monoid w) => MonadState s (StrictRWS.RWST r w s m) where + get = StrictRWS.get + put = StrictRWS.put + state = StrictRWS.state + +-- --------------------------------------------------------------------------- +-- Instances for other mtl transformers +-- +-- All of these instances need UndecidableInstances, +-- because they do not satisfy the coverage condition. + +instance MonadState s m => MonadState s (ContT r m) where + get = lift get + put = lift . put + state = lift . state + +instance (Error e, MonadState s m) => MonadState s (ErrorT e m) where + get = lift get + put = lift . put + state = lift . state + +instance MonadState s m => MonadState s (IdentityT m) where + get = lift get + put = lift . put + state = lift . state + +instance MonadState s m => MonadState s (ListT m) where + get = lift get + put = lift . put + state = lift . state + +instance MonadState s m => MonadState s (MaybeT m) where + get = lift get + put = lift . put + state = lift . state + +instance MonadState s m => MonadState s (ReaderT r m) where + get = lift get + put = lift . put + state = lift . state + +instance (Monoid w, MonadState s m) => MonadState s (Lazy.WriterT w m) where + get = lift get + put = lift . put + state = lift . state + +instance (Monoid w, MonadState s m) => MonadState s (Strict.WriterT w m) where + get = lift get + put = lift . put + state = lift . state diff --git a/Control/Monad/State/Lazy.hs b/Control/Monad/State/Lazy.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/State/Lazy.hs @@ -0,0 +1,128 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.State.Lazy +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (multi-param classes, functional dependencies) +-- +-- Lazy state monads. +-- +-- This module is inspired by the paper +-- /Functional Programming with Overloading and Higher-Order Polymorphism/, +-- Mark P Jones () +-- Advanced School of Functional Programming, 1995. + +----------------------------------------------------------------------------- + +module Control.Monad.State.Lazy ( + -- * MonadState class + MonadState(..), + modify, + gets, + -- * The State monad + State, + runState, + evalState, + execState, + mapState, + withState, + -- * The StateT monad transformer + StateT(..), + evalStateT, + execStateT, + mapStateT, + withStateT, + module Control.Monad, + module Control.Monad.Fix, + module Control.Monad.Trans, + -- * Examples + -- $examples + ) where + +import Control.Monad.State.Class + +import Control.Monad.Trans +import Control.Monad.Trans.State.Lazy + (State, runState, evalState, execState, mapState, withState, + StateT(..), evalStateT, execStateT, mapStateT, withStateT) + +import Control.Monad +import Control.Monad.Fix + +-- --------------------------------------------------------------------------- +-- $examples +-- A function to increment a counter. Taken from the paper +-- /Generalising Monads to Arrows/, John +-- Hughes (), November 1998: +-- +-- > tick :: State Int Int +-- > tick = do n <- get +-- > put (n+1) +-- > return n +-- +-- Add one to the given number using the state monad: +-- +-- > plusOne :: Int -> Int +-- > plusOne n = execState tick n +-- +-- A contrived addition example. Works only with positive numbers: +-- +-- > plus :: Int -> Int -> Int +-- > plus n x = execState (sequence $ replicate n tick) x +-- +-- An example from /The Craft of Functional Programming/, Simon +-- Thompson (), +-- Addison-Wesley 1999: \"Given an arbitrary tree, transform it to a +-- tree of integers in which the original elements are replaced by +-- natural numbers, starting from 0. The same element has to be +-- replaced by the same number at every occurrence, and when we meet +-- an as-yet-unvisited element we have to find a \'new\' number to match +-- it with:\" +-- +-- > data Tree a = Nil | Node a (Tree a) (Tree a) deriving (Show, Eq) +-- > type Table a = [a] +-- +-- > numberTree :: Eq a => Tree a -> State (Table a) (Tree Int) +-- > numberTree Nil = return Nil +-- > numberTree (Node x t1 t2) +-- > = do num <- numberNode x +-- > nt1 <- numberTree t1 +-- > nt2 <- numberTree t2 +-- > return (Node num nt1 nt2) +-- > where +-- > numberNode :: Eq a => a -> State (Table a) Int +-- > numberNode x +-- > = do table <- get +-- > (newTable, newPos) <- return (nNode x table) +-- > put newTable +-- > return newPos +-- > nNode:: (Eq a) => a -> Table a -> (Table a, Int) +-- > nNode x table +-- > = case (findIndexInList (== x) table) of +-- > Nothing -> (table ++ [x], length table) +-- > Just i -> (table, i) +-- > findIndexInList :: (a -> Bool) -> [a] -> Maybe Int +-- > findIndexInList = findIndexInListHelp 0 +-- > findIndexInListHelp _ _ [] = Nothing +-- > findIndexInListHelp count f (h:t) +-- > = if (f h) +-- > then Just count +-- > else findIndexInListHelp (count+1) f t +-- +-- numTree applies numberTree with an initial state: +-- +-- > numTree :: (Eq a) => Tree a -> Tree Int +-- > numTree t = evalState (numberTree t) [] +-- +-- > testTree = Node "Zero" (Node "One" (Node "Two" Nil Nil) (Node "One" (Node "Zero" Nil Nil) Nil)) Nil +-- > numTree testTree => Node 0 (Node 1 (Node 2 Nil Nil) (Node 1 (Node 0 Nil Nil) Nil)) Nil +-- +-- sumTree is a little helper function that does not use the State monad: +-- +-- > sumTree :: (Num a) => Tree a -> a +-- > sumTree Nil = 0 +-- > sumTree (Node e t1 t2) = e + (sumTree t1) + (sumTree t2) diff --git a/Control/Monad/State/Strict.hs b/Control/Monad/State/Strict.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/State/Strict.hs @@ -0,0 +1,128 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.State.Strict +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (multi-param classes, functional dependencies) +-- +-- Strict state monads. +-- +-- This module is inspired by the paper +-- /Functional Programming with Overloading and Higher-Order Polymorphism/, +-- Mark P Jones () +-- Advanced School of Functional Programming, 1995. + +----------------------------------------------------------------------------- + +module Control.Monad.State.Strict ( + -- * MonadState class + MonadState(..), + modify, + gets, + -- * The State monad + State, + runState, + evalState, + execState, + mapState, + withState, + -- * The StateT monad transformer + StateT(..), + evalStateT, + execStateT, + mapStateT, + withStateT, + module Control.Monad, + module Control.Monad.Fix, + module Control.Monad.Trans, + -- * Examples + -- $examples + ) where + +import Control.Monad.State.Class + +import Control.Monad.Trans +import Control.Monad.Trans.State.Strict + (State, runState, evalState, execState, mapState, withState, + StateT(..), evalStateT, execStateT, mapStateT, withStateT) + +import Control.Monad +import Control.Monad.Fix + +-- --------------------------------------------------------------------------- +-- $examples +-- A function to increment a counter. Taken from the paper +-- /Generalising Monads to Arrows/, John +-- Hughes (), November 1998: +-- +-- > tick :: State Int Int +-- > tick = do n <- get +-- > put (n+1) +-- > return n +-- +-- Add one to the given number using the state monad: +-- +-- > plusOne :: Int -> Int +-- > plusOne n = execState tick n +-- +-- A contrived addition example. Works only with positive numbers: +-- +-- > plus :: Int -> Int -> Int +-- > plus n x = execState (sequence $ replicate n tick) x +-- +-- An example from /The Craft of Functional Programming/, Simon +-- Thompson (), +-- Addison-Wesley 1999: \"Given an arbitrary tree, transform it to a +-- tree of integers in which the original elements are replaced by +-- natural numbers, starting from 0. The same element has to be +-- replaced by the same number at every occurrence, and when we meet +-- an as-yet-unvisited element we have to find a \'new\' number to match +-- it with:\" +-- +-- > data Tree a = Nil | Node a (Tree a) (Tree a) deriving (Show, Eq) +-- > type Table a = [a] +-- +-- > numberTree :: Eq a => Tree a -> State (Table a) (Tree Int) +-- > numberTree Nil = return Nil +-- > numberTree (Node x t1 t2) +-- > = do num <- numberNode x +-- > nt1 <- numberTree t1 +-- > nt2 <- numberTree t2 +-- > return (Node num nt1 nt2) +-- > where +-- > numberNode :: Eq a => a -> State (Table a) Int +-- > numberNode x +-- > = do table <- get +-- > (newTable, newPos) <- return (nNode x table) +-- > put newTable +-- > return newPos +-- > nNode:: (Eq a) => a -> Table a -> (Table a, Int) +-- > nNode x table +-- > = case (findIndexInList (== x) table) of +-- > Nothing -> (table ++ [x], length table) +-- > Just i -> (table, i) +-- > findIndexInList :: (a -> Bool) -> [a] -> Maybe Int +-- > findIndexInList = findIndexInListHelp 0 +-- > findIndexInListHelp _ _ [] = Nothing +-- > findIndexInListHelp count f (h:t) +-- > = if (f h) +-- > then Just count +-- > else findIndexInListHelp (count+1) f t +-- +-- numTree applies numberTree with an initial state: +-- +-- > numTree :: (Eq a) => Tree a -> Tree Int +-- > numTree t = evalState (numberTree t) [] +-- +-- > testTree = Node "Zero" (Node "One" (Node "Two" Nil Nil) (Node "One" (Node "Zero" Nil Nil) Nil)) Nil +-- > numTree testTree => Node 0 (Node 1 (Node 2 Nil Nil) (Node 1 (Node 0 Nil Nil) Nil)) Nil +-- +-- sumTree is a little helper function that does not use the State monad: +-- +-- > sumTree :: (Num a) => Tree a -> a +-- > sumTree Nil = 0 +-- > sumTree (Node e t1 t2) = e + (sumTree t1) + (sumTree t2) diff --git a/Control/Monad/Trans.hs b/Control/Monad/Trans.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Trans.hs @@ -0,0 +1,34 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Classes for monad transformers. +-- +-- A monad transformer makes new monad out of an existing monad, such +-- that computations of the old monad may be embedded in the new one. +-- To construct a monad with a desired set of features, one typically +-- starts with a base monad, such as @Identity@, @[]@ or 'IO', and +-- applies a sequence of monad transformers. +-- +-- Most monad transformer modules include the special case of applying the +-- transformer to @Identity@. For example, @State s@ is an abbreviation +-- for @StateT s Identity@. +-- +-- Each monad transformer also comes with an operation @run@/XXX/ to +-- unwrap the transformer, exposing a computation of the inner monad. +----------------------------------------------------------------------------- + +module Control.Monad.Trans ( + module Control.Monad.Trans.Class, + module Control.Monad.IO.Class + ) where + +import Control.Monad.IO.Class +import Control.Monad.Trans.Class diff --git a/Control/Monad/Trans/Class.hs b/Control/Monad/Trans/Class.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Trans/Class.hs @@ -0,0 +1,123 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Class +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : ross@soi.city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- Classes for monad transformers. +-- +-- A monad transformer makes a new monad out of an existing monad, such +-- that computations of the old monad may be embedded in the new one. +-- To construct a monad with a desired set of features, one typically +-- starts with a base monad, such as @Identity@, @[]@ or 'IO', and +-- applies a sequence of monad transformers. +-- +-- Most monad transformer modules include the special case of applying the +-- transformer to @Identity@. For example, @State s@ is an abbreviation +-- for @StateT s Identity@. +-- +-- Each monad transformer also comes with an operation @run@/XXX/ to +-- unwrap the transformer, exposing a computation of the inner monad. +----------------------------------------------------------------------------- + +module Control.Monad.Trans.Class ( + -- * Transformer class + MonadTrans(..) + + -- * Examples + -- ** Parsing + -- $example1 + + -- ** Parsing and counting + -- $example2 + ) where + +-- | The class of monad transformers. Instances should satisfy the +-- following laws, which state that 'lift' is a transformer of monads: +-- +-- * @'lift' . 'return' = 'return'@ +-- +-- * @'lift' (m >>= f) = 'lift' m >>= ('lift' . f)@ + +class MonadTrans t where + -- | Lift a computation from the argument monad to the constructed monad. + lift :: Monad m => m a -> t m a + +{- $example1 + +One might define a parsing monad by adding a state (the 'String' remaining +to be parsed) to the @[]@ monad, which provides non-determinism: + +> import Control.Monad.Trans.State +> +> type Parser = StateT String [] + +Then @Parser@ is an instance of @MonadPlus@: monadic sequencing implements +concatenation of parsers, while @mplus@ provides choice. +To use parsers, we need a primitive to run a constructed parser on an +input string: + +> runParser :: Parser a -> String -> [a] +> runParser p s = [x | (x, "") <- runStateT p s] + +Finally, we need a primitive parser that matches a single character, +from which arbitrarily complex parsers may be constructed: + +> item :: Parser Char +> item = do +> c:cs <- get +> put cs +> return c + +In this example we use the operations @get@ and @put@ from +"Control.Monad.Trans.State", which are defined only for monads that are +applications of @StateT@. Alternatively one could use monad classes +from the @mtl@ package or similar, which contain methods @get@ and @put@ +with types generalized over all suitable monads. +-} + +{- $example2 + +We can define a parser that also counts by adding a @WriterT@ transformer: + +> import Control.Monad.Trans.Class +> import Control.Monad.Trans.State +> import Control.Monad.Trans.Writer +> import Data.Monoid +> +> type Parser = WriterT (Sum Int) (StateT String []) + +The function that applies a parser must now unwrap each of the monad +transformers in turn: + +> runParser :: Parser a -> String -> [(a, Int)] +> runParser p s = [(x, n) | ((x, Sum n), "") <- runStateT (runWriterT p) s] + +To define @item@ parser, we need to lift the @StateT@ operations through +the @WriterT@ transformers. + +> item :: Parser Char +> item = do +> c:cs <- lift get +> lift (put cs) +> return c + +In this case, we were able to do this with 'lift', but operations with +more complex types require special lifting functions, which are provided +by monad transformers for which they can be implemented. If you use the +monad classes of the @mtl@ package or similar, this lifting is handled +automatically by the instances of the classes, and you need only use +the generalized methods @get@ and @put@. + +We can also define a primitive using the Writer: + +> tick :: Parser () +> tick = tell (Sum 1) + +Then the parser will keep track of how many @tick@s it executes. +-} diff --git a/Control/Monad/Trans/Cont.hs b/Control/Monad/Trans/Cont.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Trans/Cont.hs @@ -0,0 +1,137 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Cont +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : ross@soi.city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- Continuation monads. +-- +----------------------------------------------------------------------------- + +module Control.Monad.Trans.Cont ( + -- * The Cont monad + Cont, + cont, + runCont, + mapCont, + withCont, + -- * The ContT monad transformer + ContT(..), + mapContT, + withContT, + callCC, + -- * Lifting other operations + liftLocal, + ) where + +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Data.Functor.Identity + +import Control.Applicative +import Control.Monad + +{- | +Continuation monad. +@Cont r a@ is a CPS computation that produces an intermediate result +of type @a@ within a CPS computation whose final result type is @r@. + +The @return@ function simply creates a continuation which passes the value on. + +The @>>=@ operator adds the bound function into the continuation chain. +-} +type Cont r = ContT r Identity + +-- | Construct a continuation-passing computation from a function. +-- (The inverse of 'runCont'.) +cont :: ((a -> r) -> r) -> Cont r a +cont f = ContT (\ k -> Identity (f (runIdentity . k))) + +-- | Runs a CPS computation, returns its result after applying the final +-- continuation to it. +-- (The inverse of 'cont'.) +runCont :: Cont r a -- ^ continuation computation (@Cont@). + -> (a -> r) -- ^ the final continuation, which produces + -- the final result (often 'id'). + -> r +runCont m k = runIdentity (runContT m (Identity . k)) + +-- | Apply a function to transform the result of a continuation-passing +-- computation. +-- +-- * @'runCont' ('mapCont' f m) = f . 'runCont' m@ +mapCont :: (r -> r) -> Cont r a -> Cont r a +mapCont f = mapContT (Identity . f . runIdentity) + +-- | Apply a function to transform the continuation passed to a CPS +-- computation. +-- +-- * @'runCont' ('withCont' f m) = 'runCont' m . f@ +withCont :: ((b -> r) -> (a -> r)) -> Cont r a -> Cont r b +withCont f = withContT ((Identity .) . f . (runIdentity .)) + +{- | +The continuation monad transformer. +Can be used to add continuation handling to other monads. +-} +newtype ContT r m a = ContT { runContT :: (a -> m r) -> m r } + +-- | Apply a function to transform the result of a continuation-passing +-- computation. +-- +-- * @'runContT' ('mapContT' f m) = f . 'runContT' m@ +mapContT :: (m r -> m r) -> ContT r m a -> ContT r m a +mapContT f m = ContT $ f . runContT m + +-- | Apply a function to transform the continuation passed to a CPS +-- computation. +-- +-- * @'runContT' ('withContT' f m) = 'runContT' m . f@ +withContT :: ((b -> m r) -> (a -> m r)) -> ContT r m a -> ContT r m b +withContT f m = ContT $ runContT m . f + +instance Functor (ContT r m) where + fmap f m = ContT $ \c -> runContT m (c . f) + +instance Applicative (ContT r m) where + pure a = ContT ($ a) + f <*> v = ContT $ \ k -> runContT f $ \ g -> runContT v (k . g) + +instance Monad (ContT r m) where + return a = ContT ($ a) + m >>= k = ContT $ \c -> runContT m (\a -> runContT (k a) c) + +instance MonadTrans (ContT r) where + lift m = ContT (m >>=) + +instance (MonadIO m) => MonadIO (ContT r m) where + liftIO = lift . liftIO + +-- | @callCC@ (call-with-current-continuation) calls its argument +-- function, passing it the current continuation. It provides +-- an escape continuation mechanism for use with continuation +-- monads. Escape continuations one allow to abort the current +-- computation and return a value immediately. They achieve a +-- similar effect to 'Control.Monad.Trans.Error.throwError' +-- and 'Control.Monad.Trans.Error.catchError' within an +-- 'Control.Monad.Trans.Error.ErrorT' monad. The advantage of this +-- function over calling 'return' is that it makes the continuation +-- explicit, allowing more flexibility and better control. +-- +-- The standard idiom used with @callCC@ is to provide a lambda-expression +-- to name the continuation. Then calling the named continuation anywhere +-- within its scope will escape from the computation, even if it is many +-- layers deep within nested computations. +callCC :: ((a -> ContT r m b) -> ContT r m a) -> ContT r m a +callCC f = ContT $ \c -> runContT (f (\a -> ContT $ \_ -> c a)) c + +-- | @'liftLocal' ask local@ yields a @local@ function for @'ContT' r m@. +liftLocal :: Monad m => m r' -> ((r' -> r') -> m r -> m r) -> + (r' -> r') -> ContT r m a -> ContT r m a +liftLocal ask local f m = ContT $ \c -> do + r <- ask + local f (runContT m (local (const r) . c)) diff --git a/Control/Monad/Trans/Error.hs b/Control/Monad/Trans/Error.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Trans/Error.hs @@ -0,0 +1,267 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Error +-- Copyright : (c) Michael Weber 2001, +-- (c) Jeff Newbern 2003-2006, +-- (c) Andriy Palamarchuk 2006 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : ross@soi.city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- This monad transformer adds the ability to fail or throw exceptions +-- to a monad. +-- +-- A sequence of actions succeeds, producing a value, only if all the +-- actions in the sequence are successful. If one fails with an error, +-- the rest of the sequence is skipped and the composite action fails +-- with that error. +-- +-- If the value of the error is not required, the variant in +-- "Control.Monad.Trans.Maybe" may be used instead. +----------------------------------------------------------------------------- + +module Control.Monad.Trans.Error ( + -- * The ErrorT monad transformer + Error(..), + ErrorList(..), + ErrorT(..), + mapErrorT, + -- * Error operations + throwError, + catchError, + -- * Lifting other operations + liftCallCC, + liftListen, + liftPass, + -- * Examples + -- $examples + ) where + +import Control.Monad.IO.Class +import Control.Monad.Trans.Class + +import Control.Applicative +import Control.Exception (IOException) +import Control.Monad +import Control.Monad.Fix +import Control.Monad.Instances () +import Data.Foldable (Foldable(foldMap)) +import Data.Monoid (mempty) +import Data.Traversable (Traversable(traverse)) +import System.IO.Error + +instance MonadPlus IO where + mzero = ioError (userError "mzero") + m `mplus` n = m `catchIOError` \_ -> n + +#if !(MIN_VERSION_base(4,4,0)) +-- exported by System.IO.Error from base-4.4 +catchIOError :: IO a -> (IOError -> IO a) -> IO a +catchIOError = catch +#endif + +-- | An exception to be thrown. +-- +-- Minimal complete definition: 'noMsg' or 'strMsg'. +class Error a where + -- | Creates an exception without a message. + -- The default implementation is @'strMsg' \"\"@. + noMsg :: a + -- | Creates an exception with a message. + -- The default implementation of @'strMsg' s@ is 'noMsg'. + strMsg :: String -> a + + noMsg = strMsg "" + strMsg _ = noMsg + +instance Error IOException where + strMsg = userError + +-- | A string can be thrown as an error. +instance ErrorList a => Error [a] where + strMsg = listMsg + +-- | Workaround so that we can have a Haskell 98 instance @'Error' 'String'@. +class ErrorList a where + listMsg :: String -> [a] + +instance ErrorList Char where + listMsg = id + +-- --------------------------------------------------------------------------- +-- Our parameterizable error monad + +#if !(MIN_VERSION_base(4,3,0)) + +-- These instances are in base-4.3 + +instance Applicative (Either e) where + pure = Right + Left e <*> _ = Left e + Right f <*> r = fmap f r + +instance Monad (Either e) where + return = Right + Left l >>= _ = Left l + Right r >>= k = k r + +instance MonadFix (Either e) where + mfix f = let + a = f $ case a of + Right r -> r + _ -> error "empty mfix argument" + in a + +#endif /* base to 4.2.0.x */ + +instance (Error e) => Alternative (Either e) where + empty = Left noMsg + Left _ <|> n = n + m <|> _ = m + +instance (Error e) => MonadPlus (Either e) where + mzero = Left noMsg + Left _ `mplus` n = n + m `mplus` _ = m + +-- | The error monad transformer. It can be used to add error handling +-- to other monads. +-- +-- The @ErrorT@ Monad structure is parameterized over two things: +-- +-- * e - The error type. +-- +-- * m - The inner monad. +-- +-- The 'return' function yields a successful computation, while @>>=@ +-- sequences two subcomputations, failing on the first error. +newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) } + +-- | Map the unwrapped computation using the given function. +-- +-- * @'runErrorT' ('mapErrorT' f m) = f ('runErrorT' m)@ +mapErrorT :: (m (Either e a) -> n (Either e' b)) + -> ErrorT e m a + -> ErrorT e' n b +mapErrorT f m = ErrorT $ f (runErrorT m) + +instance (Functor m) => Functor (ErrorT e m) where + fmap f = ErrorT . fmap (fmap f) . runErrorT + +instance (Foldable f) => Foldable (ErrorT e f) where + foldMap f (ErrorT a) = foldMap (either (const mempty) f) a + +instance (Traversable f) => Traversable (ErrorT e f) where + traverse f (ErrorT a) = + ErrorT <$> traverse (either (pure . Left) (fmap Right . f)) a + +instance (Functor m, Monad m) => Applicative (ErrorT e m) where + pure a = ErrorT $ return (Right a) + f <*> v = ErrorT $ do + mf <- runErrorT f + case mf of + Left e -> return (Left e) + Right k -> do + mv <- runErrorT v + case mv of + Left e -> return (Left e) + Right x -> return (Right (k x)) + +instance (Functor m, Monad m, Error e) => Alternative (ErrorT e m) where + empty = mzero + (<|>) = mplus + +instance (Monad m, Error e) => Monad (ErrorT e m) where + return a = ErrorT $ return (Right a) + m >>= k = ErrorT $ do + a <- runErrorT m + case a of + Left l -> return (Left l) + Right r -> runErrorT (k r) + fail msg = ErrorT $ return (Left (strMsg msg)) + +instance (Monad m, Error e) => MonadPlus (ErrorT e m) where + mzero = ErrorT $ return (Left noMsg) + m `mplus` n = ErrorT $ do + a <- runErrorT m + case a of + Left _ -> runErrorT n + Right r -> return (Right r) + +instance (MonadFix m, Error e) => MonadFix (ErrorT e m) where + mfix f = ErrorT $ mfix $ \a -> runErrorT $ f $ case a of + Right r -> r + _ -> error "empty mfix argument" + +instance (Error e) => MonadTrans (ErrorT e) where + lift m = ErrorT $ do + a <- m + return (Right a) + +instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where + liftIO = lift . liftIO + +-- | Signal an error value @e@. +-- +-- * @'runErrorT' ('throwError' e) = 'return' ('Left' e)@ +-- +-- * @'throwError' e >>= m = 'throwError' e@ +throwError :: (Monad m, Error e) => e -> ErrorT e m a +throwError l = ErrorT $ return (Left l) + +-- | Handle an error. +-- +-- * @'catchError' h ('lift' m) = 'lift' m@ +-- +-- * @'catchError' h ('throwError' e) = h e@ +catchError :: (Monad m, Error e) => + ErrorT e m a -- ^ the inner computation + -> (e -> ErrorT e m a) -- ^ a handler for errors in the inner + -- computation + -> ErrorT e m a +m `catchError` h = ErrorT $ do + a <- runErrorT m + case a of + Left l -> runErrorT (h l) + Right r -> return (Right r) + +-- | Lift a @callCC@ operation to the new monad. +liftCallCC :: (((Either e a -> m (Either e b)) -> m (Either e a)) -> + m (Either e a)) -> ((a -> ErrorT e m b) -> ErrorT e m a) -> ErrorT e m a +liftCallCC callCC f = ErrorT $ + callCC $ \c -> + runErrorT (f (\a -> ErrorT $ c (Right a))) + +-- | Lift a @listen@ operation to the new monad. +liftListen :: Monad m => + (m (Either e a) -> m (Either e a,w)) -> ErrorT e m a -> ErrorT e m (a,w) +liftListen listen = mapErrorT $ \ m -> do + (a, w) <- listen m + return $! fmap (\ r -> (r, w)) a + +-- | Lift a @pass@ operation to the new monad. +liftPass :: Monad m => (m (Either e a,w -> w) -> m (Either e a)) -> + ErrorT e m (a,w -> w) -> ErrorT e m a +liftPass pass = mapErrorT $ \ m -> pass $ do + a <- m + return $! case a of + Left l -> (Left l, id) + Right (r, f) -> (Right r, f) + +{- $examples + +Wrapping an IO action that can throw an error @e@: + +> type ErrorWithIO e a = ErrorT e IO a +> ==> ErrorT (IO (Either e a)) + +An IO monad wrapped in @StateT@ inside of @ErrorT@: + +> type ErrorAndStateWithIO e s a = ErrorT e (StateT s IO) a +> ==> ErrorT (StateT s IO (Either e a)) +> ==> ErrorT (StateT (s -> IO (Either e a,s))) + +-} diff --git a/Control/Monad/Trans/Identity.hs b/Control/Monad/Trans/Identity.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Trans/Identity.hs @@ -0,0 +1,89 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Identity +-- Copyright : (c) 2007 Magnus Therning +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : ross@soi.city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- The identity monad transformer. +-- +-- This is useful for functions parameterized by a monad transformer. +----------------------------------------------------------------------------- + +module Control.Monad.Trans.Identity ( + -- * The identity monad transformer + IdentityT(..), + mapIdentityT, + -- * Lifting other operations + liftCatch, + liftCallCC, + ) where + +import Control.Applicative +import Control.Monad (MonadPlus(mzero, mplus)) +import Control.Monad.Fix (MonadFix(mfix)) +import Control.Monad.IO.Class (MonadIO(liftIO)) +import Control.Monad.Trans.Class (MonadTrans(lift)) +import Data.Foldable (Foldable(foldMap)) +import Data.Traversable (Traversable(traverse)) + +-- | The trivial monad transformer, which maps a monad to an equivalent monad. +newtype IdentityT m a = IdentityT { runIdentityT :: m a } + +instance (Functor m) => Functor (IdentityT m) where + fmap f = mapIdentityT (fmap f) + +instance (Foldable f) => Foldable (IdentityT f) where + foldMap f (IdentityT a) = foldMap f a + +instance (Traversable f) => Traversable (IdentityT f) where + traverse f (IdentityT a) = IdentityT <$> traverse f a + +instance (Applicative m) => Applicative (IdentityT m) where + pure x = IdentityT (pure x) + (<*>) = lift2IdentityT (<*>) + +instance (Alternative m) => Alternative (IdentityT m) where + empty = IdentityT empty + (<|>) = lift2IdentityT (<|>) + +instance (Monad m) => Monad (IdentityT m) where + return = IdentityT . return + m >>= k = IdentityT $ runIdentityT . k =<< runIdentityT m + fail msg = IdentityT $ fail msg + +instance (MonadPlus m) => MonadPlus (IdentityT m) where + mzero = IdentityT mzero + mplus = lift2IdentityT mplus + +instance (MonadFix m) => MonadFix (IdentityT m) where + mfix f = IdentityT (mfix (runIdentityT . f)) + +instance (MonadIO m) => MonadIO (IdentityT m) where + liftIO = IdentityT . liftIO + +instance MonadTrans IdentityT where + lift = IdentityT + +-- | Lift a unary operation to the new monad. +mapIdentityT :: (m a -> n b) -> IdentityT m a -> IdentityT n b +mapIdentityT f = IdentityT . f . runIdentityT + +-- | Lift a binary operation to the new monad. +lift2IdentityT :: + (m a -> n b -> p c) -> IdentityT m a -> IdentityT n b -> IdentityT p c +lift2IdentityT f a b = IdentityT (f (runIdentityT a) (runIdentityT b)) + +-- | Lift a @callCC@ operation to the new monad. +liftCallCC :: (((a -> m b) -> m a) -> + m a) -> ((a -> IdentityT m b) -> IdentityT m a) -> IdentityT m a +liftCallCC callCC f = + IdentityT $ callCC $ \ c -> runIdentityT (f (IdentityT . c)) + +-- | Lift a @catchError@ operation to the new monad. +liftCatch :: (m a -> (e -> m a) -> m a) -> + IdentityT m a -> (e -> IdentityT m a) -> IdentityT m a +liftCatch f m h = IdentityT $ f (runIdentityT m) (runIdentityT . h) diff --git a/Control/Monad/Trans/List.hs b/Control/Monad/Trans/List.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Trans/List.hs @@ -0,0 +1,95 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.List +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : ross@soi.city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- The ListT monad transformer, adding backtracking to a given monad, +-- which must be commutative. +----------------------------------------------------------------------------- + +module Control.Monad.Trans.List ( + -- * The ListT monad transformer + ListT(..), + mapListT, + -- * Lifting other operations + liftCallCC, + liftCatch, + ) where + +import Control.Monad.IO.Class +import Control.Monad.Trans.Class + +import Control.Applicative +import Control.Monad +import Data.Foldable (Foldable(foldMap)) +import Data.Traversable (Traversable(traverse)) + +-- | Parameterizable list monad, with an inner monad. +-- +-- /Note:/ this does not yield a monad unless the argument monad is commutative. +newtype ListT m a = ListT { runListT :: m [a] } + +-- | Map between 'ListT' computations. +-- +-- * @'runListT' ('mapListT' f m) = f ('runListT' m)@ +mapListT :: (m [a] -> n [b]) -> ListT m a -> ListT n b +mapListT f m = ListT $ f (runListT m) + +instance (Functor m) => Functor (ListT m) where + fmap f = mapListT $ fmap $ map f + +instance Foldable f => Foldable (ListT f) where + foldMap f (ListT a) = foldMap (foldMap f) a + +instance Traversable f => Traversable (ListT f) where + traverse f (ListT a) = ListT <$> traverse (traverse f) a + +instance (Applicative m) => Applicative (ListT m) where + pure a = ListT $ pure [a] + f <*> v = ListT $ (<*>) <$> runListT f <*> runListT v + +instance (Applicative m) => Alternative (ListT m) where + empty = ListT $ pure [] + m <|> n = ListT $ (++) <$> runListT m <*> runListT n + +instance (Monad m) => Monad (ListT m) where + return a = ListT $ return [a] + m >>= k = ListT $ do + a <- runListT m + b <- mapM (runListT . k) a + return (concat b) + fail _ = ListT $ return [] + +instance (Monad m) => MonadPlus (ListT m) where + mzero = ListT $ return [] + m `mplus` n = ListT $ do + a <- runListT m + b <- runListT n + return (a ++ b) + +instance MonadTrans ListT where + lift m = ListT $ do + a <- m + return [a] + +instance (MonadIO m) => MonadIO (ListT m) where + liftIO = lift . liftIO + +-- | Lift a @callCC@ operation to the new monad. +liftCallCC :: ((([a] -> m [b]) -> m [a]) -> m [a]) -> + ((a -> ListT m b) -> ListT m a) -> ListT m a +liftCallCC callCC f = ListT $ + callCC $ \c -> + runListT (f (\a -> ListT $ c [a])) + +-- | Lift a @catchError@ operation to the new monad. +liftCatch :: (m [a] -> (e -> m [a]) -> m [a]) -> + ListT m a -> (e -> ListT m a) -> ListT m a +liftCatch catchError m h = ListT $ runListT m + `catchError` \e -> runListT (h e) diff --git a/Control/Monad/Trans/Maybe.hs b/Control/Monad/Trans/Maybe.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Trans/Maybe.hs @@ -0,0 +1,126 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Maybe +-- Copyright : (c) 2007 Yitzak Gale, Eric Kidd +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : ross@soi.city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- The 'MaybeT' monad transformer adds the ability to fail to a monad. +-- +-- A sequence of actions succeeds, producing a value, only if all the +-- actions in the sequence are successful. If one fails, the rest of +-- the sequence is skipped and the composite action fails. +-- +-- For a variant allowing a range of error values, see +-- "Control.Monad.Trans.Error". +----------------------------------------------------------------------------- + +module Control.Monad.Trans.Maybe ( + -- * The MaybeT monad transformer + MaybeT(..), + mapMaybeT, + -- * Lifting other operations + liftCallCC, + liftCatch, + liftListen, + liftPass, + ) where + +import Control.Monad.IO.Class +import Control.Monad.Trans.Class + +import Control.Applicative +import Control.Monad (MonadPlus(mzero, mplus), liftM, ap) +import Control.Monad.Fix (MonadFix(mfix)) +import Data.Foldable (Foldable(foldMap)) +import Data.Maybe (fromMaybe) +import Data.Traversable (Traversable(traverse)) + +-- | The parameterizable maybe monad, obtained by composing an arbitrary +-- monad with the 'Maybe' monad. +-- +-- Computations are actions that may produce a value or fail. +-- +-- The 'return' function yields a successful computation, while @>>=@ +-- sequences two subcomputations, failing on the first error. +newtype MaybeT m a = MaybeT { runMaybeT :: m (Maybe a) } + +-- | Transform the computation inside a @MaybeT@. +-- +-- * @'runMaybeT' ('mapMaybeT' f m) = f ('runMaybeT' m)@ +mapMaybeT :: (m (Maybe a) -> n (Maybe b)) -> MaybeT m a -> MaybeT n b +mapMaybeT f = MaybeT . f . runMaybeT + +instance (Functor m) => Functor (MaybeT m) where + fmap f = mapMaybeT (fmap (fmap f)) + +instance (Foldable f) => Foldable (MaybeT f) where + foldMap f (MaybeT a) = foldMap (foldMap f) a + +instance (Traversable f) => Traversable (MaybeT f) where + traverse f (MaybeT a) = MaybeT <$> traverse (traverse f) a + +instance (Functor m, Monad m) => Applicative (MaybeT m) where + pure = return + (<*>) = ap + +instance (Functor m, Monad m) => Alternative (MaybeT m) where + empty = mzero + (<|>) = mplus + +instance (Monad m) => Monad (MaybeT m) where + fail _ = MaybeT (return Nothing) + return = lift . return + x >>= f = MaybeT $ do + v <- runMaybeT x + case v of + Nothing -> return Nothing + Just y -> runMaybeT (f y) + +instance (Monad m) => MonadPlus (MaybeT m) where + mzero = MaybeT (return Nothing) + mplus x y = MaybeT $ do + v <- runMaybeT x + case v of + Nothing -> runMaybeT y + Just _ -> return v + +instance (MonadFix m) => MonadFix (MaybeT m) where + mfix f = MaybeT (mfix (runMaybeT . f . unJust)) + where unJust = fromMaybe (error "mfix MaybeT: Nothing") + +instance MonadTrans MaybeT where + lift = MaybeT . liftM Just + +instance (MonadIO m) => MonadIO (MaybeT m) where + liftIO = lift . liftIO + +-- | Lift a @callCC@ operation to the new monad. +liftCallCC :: (((Maybe a -> m (Maybe b)) -> m (Maybe a)) -> + m (Maybe a)) -> ((a -> MaybeT m b) -> MaybeT m a) -> MaybeT m a +liftCallCC callCC f = + MaybeT $ callCC $ \ c -> runMaybeT (f (MaybeT . c . Just)) + +-- | Lift a @catchError@ operation to the new monad. +liftCatch :: (m (Maybe a) -> (e -> m (Maybe a)) -> m (Maybe a)) -> + MaybeT m a -> (e -> MaybeT m a) -> MaybeT m a +liftCatch f m h = MaybeT $ f (runMaybeT m) (runMaybeT . h) + +-- | Lift a @listen@ operation to the new monad. +liftListen :: Monad m => + (m (Maybe a) -> m (Maybe a,w)) -> MaybeT m a -> MaybeT m (a,w) +liftListen listen = mapMaybeT $ \ m -> do + (a, w) <- listen m + return $! fmap (\ r -> (r, w)) a + +-- | Lift a @pass@ operation to the new monad. +liftPass :: Monad m => (m (Maybe a,w -> w) -> m (Maybe a)) -> + MaybeT m (a,w -> w) -> MaybeT m a +liftPass pass = mapMaybeT $ \ m -> pass $ do + a <- m + return $! case a of + Nothing -> (Nothing, id) + Just (v, f) -> (Just v, f) diff --git a/Control/Monad/Trans/RWS.hs b/Control/Monad/Trans/RWS.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Trans/RWS.hs @@ -0,0 +1,21 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.RWS +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : ross@soi.city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- A monad transformer that combines 'ReaderT', 'WriterT' and 'StateT'. +-- This version is lazy; for a strict version, see +-- "Control.Monad.Trans.RWS.Strict", which has the same interface. +----------------------------------------------------------------------------- + +module Control.Monad.Trans.RWS ( + module Control.Monad.Trans.RWS.Lazy + ) where + +import Control.Monad.Trans.RWS.Lazy diff --git a/Control/Monad/Trans/RWS/Lazy.hs b/Control/Monad/Trans/RWS/Lazy.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Trans/RWS/Lazy.hs @@ -0,0 +1,317 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.RWS.Lazy +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : ross@soi.city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- A monad transformer that combines 'ReaderT', 'WriterT' and 'StateT'. +-- This version is lazy; for a strict version, see +-- "Control.Monad.Trans.RWS.Strict", which has the same interface. +----------------------------------------------------------------------------- + +module Control.Monad.Trans.RWS.Lazy ( + -- * The RWS monad + RWS, + rws, + runRWS, + evalRWS, + execRWS, + mapRWS, + withRWS, + -- * The RWST monad transformer + RWST(..), + evalRWST, + execRWST, + mapRWST, + withRWST, + -- * Reader operations + reader, + ask, + local, + asks, + -- * Writer operations + writer, + tell, + listen, + listens, + pass, + censor, + -- * State operations + state, + get, + put, + modify, + gets, + -- * Lifting other operations + liftCallCC, + liftCallCC', + liftCatch, + ) where + +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Data.Functor.Identity + +import Control.Applicative +import Control.Monad +import Control.Monad.Fix +import Data.Monoid + +-- | A monad containing an environment of type @r@, output of type @w@ +-- and an updatable state of type @s@. +type RWS r w s = RWST r w s Identity + +-- | Construct an RWS computation from a function. +-- (The inverse of 'runRWS'.) +rws :: (r -> s -> (a, s, w)) -> RWS r w s a +rws f = RWST (\ r s -> Identity (f r s)) + +-- | Unwrap an RWS computation as a function. +-- (The inverse of 'rws'.) +runRWS :: RWS r w s a -> r -> s -> (a, s, w) +runRWS m r s = runIdentity (runRWST m r s) + +-- | Evaluate a computation with the given initial state and environment, +-- returning the final value and output, discarding the final state. +evalRWS :: RWS r w s a -- ^RWS computation to execute + -> r -- ^initial environment + -> s -- ^initial value + -> (a, w) -- ^final value and output +evalRWS m r s = let + (a, _, w) = runRWS m r s + in (a, w) + +-- | Evaluate a computation with the given initial state and environment, +-- returning the final state and output, discarding the final value. +execRWS :: RWS r w s a -- ^RWS computation to execute + -> r -- ^initial environment + -> s -- ^initial value + -> (s, w) -- ^final state and output +execRWS m r s = let + (_, s', w) = runRWS m r s + in (s', w) + +-- | Map the return value, final state and output of a computation using +-- the given function. +-- +-- * @'runRWS' ('mapRWS' f m) r s = f ('runRWS' m r s)@ +mapRWS :: ((a, s, w) -> (b, s, w')) -> RWS r w s a -> RWS r w' s b +mapRWS f = mapRWST (Identity . f . runIdentity) + +-- | @'withRWS' f m@ executes action @m@ with an initial environment +-- and state modified by applying @f@. +-- +-- * @'runRWS' ('withRWS' f m) r s = 'uncurry' ('runRWS' m) (f r s)@ +withRWS :: (r' -> s -> (r, s)) -> RWS r w s a -> RWS r' w s a +withRWS = withRWST + +-- --------------------------------------------------------------------------- +-- | A monad transformer adding reading an environment of type @r@, +-- collecting an output of type @w@ and updating a state of type @s@ +-- to an inner monad @m@. +newtype RWST r w s m a = RWST { runRWST :: r -> s -> m (a, s, w) } + +-- | Evaluate a computation with the given initial state and environment, +-- returning the final value and output, discarding the final state. +evalRWST :: (Monad m) + => RWST r w s m a -- ^computation to execute + -> r -- ^initial environment + -> s -- ^initial value + -> m (a, w) -- ^computation yielding final value and output +evalRWST m r s = do + ~(a, _, w) <- runRWST m r s + return (a, w) + +-- | Evaluate a computation with the given initial state and environment, +-- returning the final state and output, discarding the final value. +execRWST :: (Monad m) + => RWST r w s m a -- ^computation to execute + -> r -- ^initial environment + -> s -- ^initial value + -> m (s, w) -- ^computation yielding final state and output +execRWST m r s = do + ~(_, s', w) <- runRWST m r s + return (s', w) + +-- | Map the inner computation using the given function. +-- +-- * @'runRWST' ('mapRWST' f m) r s = f ('runRWST' m r s)@ +mapRWST :: (m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b +mapRWST f m = RWST $ \r s -> f (runRWST m r s) + +-- | @'withRWST' f m@ executes action @m@ with an initial environment +-- and state modified by applying @f@. +-- +-- * @'runRWST' ('withRWST' f m) r s = 'uncurry' ('runRWST' m) (f r s)@ +withRWST :: (r' -> s -> (r, s)) -> RWST r w s m a -> RWST r' w s m a +withRWST f m = RWST $ \r s -> uncurry (runRWST m) (f r s) + +instance (Functor m) => Functor (RWST r w s m) where + fmap f m = RWST $ \r s -> + fmap (\ ~(a, s', w) -> (f a, s', w)) $ runRWST m r s + +instance (Monoid w, Functor m, Monad m) => Applicative (RWST r w s m) where + pure = return + (<*>) = ap + +instance (Monoid w, Functor m, MonadPlus m) => Alternative (RWST r w s m) where + empty = mzero + (<|>) = mplus + +instance (Monoid w, Monad m) => Monad (RWST r w s m) where + return a = RWST $ \_ s -> return (a, s, mempty) + m >>= k = RWST $ \r s -> do + ~(a, s', w) <- runRWST m r s + ~(b, s'',w') <- runRWST (k a) r s' + return (b, s'', w `mappend` w') + fail msg = RWST $ \_ _ -> fail msg + +instance (Monoid w, MonadPlus m) => MonadPlus (RWST r w s m) where + mzero = RWST $ \_ _ -> mzero + m `mplus` n = RWST $ \r s -> runRWST m r s `mplus` runRWST n r s + +instance (Monoid w, MonadFix m) => MonadFix (RWST r w s m) where + mfix f = RWST $ \r s -> mfix $ \ ~(a, _, _) -> runRWST (f a) r s + +instance (Monoid w) => MonadTrans (RWST r w s) where + lift m = RWST $ \_ s -> do + a <- m + return (a, s, mempty) + +instance (Monoid w, MonadIO m) => MonadIO (RWST r w s m) where + liftIO = lift . liftIO + +-- --------------------------------------------------------------------------- +-- Reader operations + +-- | Constructor for computations in the reader monad (equivalent to 'asks'). +reader :: (Monoid w, Monad m) => (r -> a) -> RWST r w s m a +reader = asks + +-- | Fetch the value of the environment. +ask :: (Monoid w, Monad m) => RWST r w s m r +ask = RWST $ \r s -> return (r, s, mempty) + +-- | Execute a computation in a modified environment +-- +-- * @'runRWST' ('local' f m) r s = 'runRWST' m (f r) s@ +local :: (Monoid w, Monad m) => (r -> r) -> RWST r w s m a -> RWST r w s m a +local f m = RWST $ \r s -> runRWST m (f r) s + +-- | Retrieve a function of the current environment. +-- +-- * @'asks' f = 'liftM' f 'ask'@ +asks :: (Monoid w, Monad m) => (r -> a) -> RWST r w s m a +asks f = RWST $ \r s -> return (f r, s, mempty) + +-- --------------------------------------------------------------------------- +-- Writer operations + +-- | Construct a writer computation from a (result, output) pair. +writer :: Monad m => (a, w) -> RWST r w s m a +writer (a, w) = RWST $ \_ s -> return (a, s, w) + +-- | @'tell' w@ is an action that produces the output @w@. +tell :: (Monoid w, Monad m) => w -> RWST r w s m () +tell w = RWST $ \_ s -> return ((),s,w) + +-- | @'listen' m@ is an action that executes the action @m@ and adds its +-- output to the value of the computation. +-- +-- * @'runRWST' ('listen' m) r s = 'liftM' (\\(a, w) -> ((a, w), w)) ('runRWST' m r s)@ +listen :: (Monoid w, Monad m) => RWST r w s m a -> RWST r w s m (a, w) +listen m = RWST $ \r s -> do + ~(a, s', w) <- runRWST m r s + return ((a, w), s', w) + +-- | @'listens' f m@ is an action that executes the action @m@ and adds +-- the result of applying @f@ to the output to the value of the computation. +-- +-- * @'listens' f m = 'liftM' (id *** f) ('listen' m)@ +-- +-- * @'runRWST' ('listens' f m) r s = 'liftM' (\\(a, w) -> ((a, f w), w)) ('runRWST' m r s)@ +listens :: (Monoid w, Monad m) => (w -> b) -> RWST r w s m a -> RWST r w s m (a, b) +listens f m = RWST $ \r s -> do + ~(a, s', w) <- runRWST m r s + return ((a, f w), s', w) + +-- | @'pass' m@ is an action that executes the action @m@, which returns +-- a value and a function, and returns the value, applying the function +-- to the output. +-- +-- * @'runRWST' ('pass' m) r s = 'liftM' (\\((a, f), w) -> (a, f w)) ('runRWST' m r s)@ +pass :: (Monoid w, Monad m) => RWST r w s m (a, w -> w) -> RWST r w s m a +pass m = RWST $ \r s -> do + ~((a, f), s', w) <- runRWST m r s + return (a, s', f w) + +-- | @'censor' f m@ is an action that executes the action @m@ and +-- applies the function @f@ to its output, leaving the return value +-- unchanged. +-- +-- * @'censor' f m = 'pass' ('liftM' (\\x -> (x,f)) m)@ +-- +-- * @'runRWST' ('censor' f m) r s = 'liftM' (\\(a, w) -> (a, f w)) ('runRWST' m r s)@ +censor :: (Monoid w, Monad m) => (w -> w) -> RWST r w s m a -> RWST r w s m a +censor f m = RWST $ \r s -> do + ~(a, s', w) <- runRWST m r s + return (a, s', f w) + +-- --------------------------------------------------------------------------- +-- State operations + +-- | Construct a state monad computation from a state transformer function. +state :: (Monoid w, Monad m) => (s -> (a,s)) -> RWST r w s m a +state f = RWST $ \_ s -> let (a,s') = f s in return (a, s', mempty) + +-- | Fetch the current value of the state within the monad. +get :: (Monoid w, Monad m) => RWST r w s m s +get = RWST $ \_ s -> return (s, s, mempty) + +-- | @'put' s@ sets the state within the monad to @s@. +put :: (Monoid w, Monad m) => s -> RWST r w s m () +put s = RWST $ \_ _ -> return ((), s, mempty) + +-- | @'modify' f@ is an action that updates the state to the result of +-- applying @f@ to the current state. +-- +-- * @'modify' f = 'get' >>= ('put' . f)@ +modify :: (Monoid w, Monad m) => (s -> s) -> RWST r w s m () +modify f = RWST $ \_ s -> return ((), f s, mempty) + +-- | Get a specific component of the state, using a projection function +-- supplied. +-- +-- * @'gets' f = 'liftM' f 'get'@ +gets :: (Monoid w, Monad m) => (s -> a) -> RWST r w s m a +gets f = RWST $ \_ s -> return (f s, s, mempty) + +-- | Uniform lifting of a @callCC@ operation to the new monad. +-- This version rolls back to the original state on entering the +-- continuation. +liftCallCC :: (Monoid w) => + ((((a,s,w) -> m (b,s,w)) -> m (a,s,w)) -> m (a,s,w)) -> + ((a -> RWST r w s m b) -> RWST r w s m a) -> RWST r w s m a +liftCallCC callCC f = RWST $ \r s -> + callCC $ \c -> + runRWST (f (\a -> RWST $ \_ _ -> c (a, s, mempty))) r s + +-- | In-situ lifting of a @callCC@ operation to the new monad. +-- This version uses the current state on entering the continuation. +liftCallCC' :: (Monoid w) => + ((((a,s,w) -> m (b,s,w)) -> m (a,s,w)) -> m (a,s,w)) -> + ((a -> RWST r w s m b) -> RWST r w s m a) -> RWST r w s m a +liftCallCC' callCC f = RWST $ \r s -> + callCC $ \c -> + runRWST (f (\a -> RWST $ \_ s' -> c (a, s', mempty))) r s + +-- | Lift a @catchError@ operation to the new monad. +liftCatch :: (m (a,s,w) -> (e -> m (a,s,w)) -> m (a,s,w)) -> + RWST l w s m a -> (e -> RWST l w s m a) -> RWST l w s m a +liftCatch catchError m h = + RWST $ \r s -> runRWST m r s `catchError` \e -> runRWST (h e) r s diff --git a/Control/Monad/Trans/RWS/Strict.hs b/Control/Monad/Trans/RWS/Strict.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Trans/RWS/Strict.hs @@ -0,0 +1,317 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.RWS.Strict +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : ross@soi.city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- A monad transformer that combines 'ReaderT', 'WriterT' and 'StateT'. +-- This version is strict; for a lazy version, see +-- "Control.Monad.Trans.RWS.Lazy", which has the same interface. +----------------------------------------------------------------------------- + +module Control.Monad.Trans.RWS.Strict ( + -- * The RWS monad + RWS, + rws, + runRWS, + evalRWS, + execRWS, + mapRWS, + withRWS, + -- * The RWST monad transformer + RWST(..), + evalRWST, + execRWST, + mapRWST, + withRWST, + -- * Reader operations + reader, + ask, + local, + asks, + -- * Writer operations + writer, + tell, + listen, + listens, + pass, + censor, + -- * State operations + state, + get, + put, + modify, + gets, + -- * Lifting other operations + liftCallCC, + liftCallCC', + liftCatch, + ) where + +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Data.Functor.Identity + +import Control.Applicative +import Control.Monad +import Control.Monad.Fix +import Data.Monoid + +-- | A monad containing an environment of type @r@, output of type @w@ +-- and an updatable state of type @s@. +type RWS r w s = RWST r w s Identity + +-- | Construct an RWS computation from a function. +-- (The inverse of 'runRWS'.) +rws :: (r -> s -> (a, s, w)) -> RWS r w s a +rws f = RWST (\ r s -> Identity (f r s)) + +-- | Unwrap an RWS computation as a function. +-- (The inverse of 'rws'.) +runRWS :: RWS r w s a -> r -> s -> (a, s, w) +runRWS m r s = runIdentity (runRWST m r s) + +-- | Evaluate a computation with the given initial state and environment, +-- returning the final value and output, discarding the final state. +evalRWS :: RWS r w s a -- ^RWS computation to execute + -> r -- ^initial environment + -> s -- ^initial value + -> (a, w) -- ^final value and output +evalRWS m r s = let + (a, _, w) = runRWS m r s + in (a, w) + +-- | Evaluate a computation with the given initial state and environment, +-- returning the final state and output, discarding the final value. +execRWS :: RWS r w s a -- ^RWS computation to execute + -> r -- ^initial environment + -> s -- ^initial value + -> (s, w) -- ^final state and output +execRWS m r s = let + (_, s', w) = runRWS m r s + in (s', w) + +-- | Map the return value, final state and output of a computation using +-- the given function. +-- +-- * @'runRWS' ('mapRWS' f m) r s = f ('runRWS' m r s)@ +mapRWS :: ((a, s, w) -> (b, s, w')) -> RWS r w s a -> RWS r w' s b +mapRWS f = mapRWST (Identity . f . runIdentity) + +-- | @'withRWS' f m@ executes action @m@ with an initial environment +-- and state modified by applying @f@. +-- +-- * @'runRWS' ('withRWS' f m) r s = 'uncurry' ('runRWS' m) (f r s)@ +withRWS :: (r' -> s -> (r, s)) -> RWS r w s a -> RWS r' w s a +withRWS = withRWST + +-- --------------------------------------------------------------------------- +-- | A monad transformer adding reading an environment of type @r@, +-- collecting an output of type @w@ and updating a state of type @s@ +-- to an inner monad @m@. +newtype RWST r w s m a = RWST { runRWST :: r -> s -> m (a, s, w) } + +-- | Evaluate a computation with the given initial state and environment, +-- returning the final value and output, discarding the final state. +evalRWST :: (Monad m) + => RWST r w s m a -- ^computation to execute + -> r -- ^initial environment + -> s -- ^initial value + -> m (a, w) -- ^computation yielding final value and output +evalRWST m r s = do + (a, _, w) <- runRWST m r s + return (a, w) + +-- | Evaluate a computation with the given initial state and environment, +-- returning the final state and output, discarding the final value. +execRWST :: (Monad m) + => RWST r w s m a -- ^computation to execute + -> r -- ^initial environment + -> s -- ^initial value + -> m (s, w) -- ^computation yielding final state and output +execRWST m r s = do + (_, s', w) <- runRWST m r s + return (s', w) + +-- | Map the inner computation using the given function. +-- +-- * @'runRWST' ('mapRWST' f m) r s = f ('runRWST' m r s)@ +mapRWST :: (m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b +mapRWST f m = RWST $ \r s -> f (runRWST m r s) + +-- | @'withRWST' f m@ executes action @m@ with an initial environment +-- and state modified by applying @f@. +-- +-- * @'runRWST' ('withRWST' f m) r s = 'uncurry' ('runRWST' m) (f r s)@ +withRWST :: (r' -> s -> (r, s)) -> RWST r w s m a -> RWST r' w s m a +withRWST f m = RWST $ \r s -> uncurry (runRWST m) (f r s) + +instance (Functor m) => Functor (RWST r w s m) where + fmap f m = RWST $ \r s -> + fmap (\ (a, s', w) -> (f a, s', w)) $ runRWST m r s + +instance (Monoid w, Functor m, Monad m) => Applicative (RWST r w s m) where + pure = return + (<*>) = ap + +instance (Monoid w, Functor m, MonadPlus m) => Alternative (RWST r w s m) where + empty = mzero + (<|>) = mplus + +instance (Monoid w, Monad m) => Monad (RWST r w s m) where + return a = RWST $ \_ s -> return (a, s, mempty) + m >>= k = RWST $ \r s -> do + (a, s', w) <- runRWST m r s + (b, s'',w') <- runRWST (k a) r s' + return (b, s'', w `mappend` w') + fail msg = RWST $ \_ _ -> fail msg + +instance (Monoid w, MonadPlus m) => MonadPlus (RWST r w s m) where + mzero = RWST $ \_ _ -> mzero + m `mplus` n = RWST $ \r s -> runRWST m r s `mplus` runRWST n r s + +instance (Monoid w, MonadFix m) => MonadFix (RWST r w s m) where + mfix f = RWST $ \r s -> mfix $ \ ~(a, _, _) -> runRWST (f a) r s + +instance (Monoid w) => MonadTrans (RWST r w s) where + lift m = RWST $ \_ s -> do + a <- m + return (a, s, mempty) + +instance (Monoid w, MonadIO m) => MonadIO (RWST r w s m) where + liftIO = lift . liftIO + +-- --------------------------------------------------------------------------- +-- Reader operations + +-- | Constructor for computations in the reader monad (equivalent to 'asks'). +reader :: (Monoid w, Monad m) => (r -> a) -> RWST r w s m a +reader = asks + +-- | Fetch the value of the environment. +ask :: (Monoid w, Monad m) => RWST r w s m r +ask = RWST $ \r s -> return (r, s, mempty) + +-- | Execute a computation in a modified environment +-- +-- * @'runRWST' ('local' f m) r s = 'runRWST' m (f r) s@ +local :: (Monoid w, Monad m) => (r -> r) -> RWST r w s m a -> RWST r w s m a +local f m = RWST $ \r s -> runRWST m (f r) s + +-- | Retrieve a function of the current environment. +-- +-- * @'asks' f = 'liftM' f 'ask'@ +asks :: (Monoid w, Monad m) => (r -> a) -> RWST r w s m a +asks f = RWST $ \r s -> return (f r, s, mempty) + +-- --------------------------------------------------------------------------- +-- Writer operations + +-- | Construct a writer computation from a (result, output) pair. +writer :: Monad m => (a, w) -> RWST r w s m a +writer (a, w) = RWST $ \_ s -> return (a, s, w) + +-- | @'tell' w@ is an action that produces the output @w@. +tell :: (Monoid w, Monad m) => w -> RWST r w s m () +tell w = RWST $ \_ s -> return ((),s,w) + +-- | @'listen' m@ is an action that executes the action @m@ and adds its +-- output to the value of the computation. +-- +-- * @'runRWST' ('listen' m) r s = 'liftM' (\\(a, w) -> ((a, w), w)) ('runRWST' m r s)@ +listen :: (Monoid w, Monad m) => RWST r w s m a -> RWST r w s m (a, w) +listen m = RWST $ \r s -> do + (a, s', w) <- runRWST m r s + return ((a, w), s', w) + +-- | @'listens' f m@ is an action that executes the action @m@ and adds +-- the result of applying @f@ to the output to the value of the computation. +-- +-- * @'listens' f m = 'liftM' (id *** f) ('listen' m)@ +-- +-- * @'runRWST' ('listens' f m) r s = 'liftM' (\\(a, w) -> ((a, f w), w)) ('runRWST' m r s)@ +listens :: (Monoid w, Monad m) => (w -> b) -> RWST r w s m a -> RWST r w s m (a, b) +listens f m = RWST $ \r s -> do + (a, s', w) <- runRWST m r s + return ((a, f w), s', w) + +-- | @'pass' m@ is an action that executes the action @m@, which returns +-- a value and a function, and returns the value, applying the function +-- to the output. +-- +-- * @'runRWST' ('pass' m) r s = 'liftM' (\\((a, f), w) -> (a, f w)) ('runRWST' m r s)@ +pass :: (Monoid w, Monad m) => RWST r w s m (a, w -> w) -> RWST r w s m a +pass m = RWST $ \r s -> do + ((a, f), s', w) <- runRWST m r s + return (a, s', f w) + +-- | @'censor' f m@ is an action that executes the action @m@ and +-- applies the function @f@ to its output, leaving the return value +-- unchanged. +-- +-- * @'censor' f m = 'pass' ('liftM' (\\x -> (x,f)) m)@ +-- +-- * @'runRWST' ('censor' f m) r s = 'liftM' (\\(a, w) -> (a, f w)) ('runRWST' m r s)@ +censor :: (Monoid w, Monad m) => (w -> w) -> RWST r w s m a -> RWST r w s m a +censor f m = RWST $ \r s -> do + (a, s', w) <- runRWST m r s + return (a, s', f w) + +-- --------------------------------------------------------------------------- +-- State operations + +-- | Construct a state monad computation from a state transformer function. +state :: (Monoid w, Monad m) => (s -> (a,s)) -> RWST r w s m a +state f = RWST $ \_ s -> case f s of (a,s') -> return (a, s', mempty) + +-- | Fetch the current value of the state within the monad. +get :: (Monoid w, Monad m) => RWST r w s m s +get = RWST $ \_ s -> return (s, s, mempty) + +-- | @'put' s@ sets the state within the monad to @s@. +put :: (Monoid w, Monad m) => s -> RWST r w s m () +put s = RWST $ \_ _ -> return ((), s, mempty) + +-- | @'modify' f@ is an action that updates the state to the result of +-- applying @f@ to the current state. +-- +-- * @'modify' f = 'get' >>= ('put' . f)@ +modify :: (Monoid w, Monad m) => (s -> s) -> RWST r w s m () +modify f = RWST $ \_ s -> return ((), f s, mempty) + +-- | Get a specific component of the state, using a projection function +-- supplied. +-- +-- * @'gets' f = 'liftM' f 'get'@ +gets :: (Monoid w, Monad m) => (s -> a) -> RWST r w s m a +gets f = RWST $ \_ s -> return (f s, s, mempty) + +-- | Uniform lifting of a @callCC@ operation to the new monad. +-- This version rolls back to the original state on entering the +-- continuation. +liftCallCC :: (Monoid w) => + ((((a,s,w) -> m (b,s,w)) -> m (a,s,w)) -> m (a,s,w)) -> + ((a -> RWST r w s m b) -> RWST r w s m a) -> RWST r w s m a +liftCallCC callCC f = RWST $ \r s -> + callCC $ \c -> + runRWST (f (\a -> RWST $ \_ _ -> c (a, s, mempty))) r s + +-- | In-situ lifting of a @callCC@ operation to the new monad. +-- This version uses the current state on entering the continuation. +liftCallCC' :: (Monoid w) => + ((((a,s,w) -> m (b,s,w)) -> m (a,s,w)) -> m (a,s,w)) -> + ((a -> RWST r w s m b) -> RWST r w s m a) -> RWST r w s m a +liftCallCC' callCC f = RWST $ \r s -> + callCC $ \c -> + runRWST (f (\a -> RWST $ \_ s' -> c (a, s', mempty))) r s + +-- | Lift a @catchError@ operation to the new monad. +liftCatch :: (m (a,s,w) -> (e -> m (a,s,w)) -> m (a,s,w)) -> + RWST l w s m a -> (e -> RWST l w s m a) -> RWST l w s m a +liftCatch catchError m h = + RWST $ \r s -> runRWST m r s `catchError` \e -> runRWST (h e) r s diff --git a/Control/Monad/Trans/Reader.hs b/Control/Monad/Trans/Reader.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Trans/Reader.hs @@ -0,0 +1,180 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Reader +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : ross@soi.city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- Declaration of the 'ReaderT' monad transformer, which adds a static +-- environment to a given monad. +-- +-- If the computation is to modify the stored information, use +-- "Control.Monad.Trans.State" instead. +----------------------------------------------------------------------------- + +module Control.Monad.Trans.Reader ( + -- * The Reader monad + Reader, + reader, + runReader, + mapReader, + withReader, + -- * The ReaderT monad transformer + ReaderT(..), + mapReaderT, + withReaderT, + -- * Reader operations + ask, + local, + asks, + -- * Lifting other operations + liftCallCC, + liftCatch, + ) where + +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Data.Functor.Identity + +import Control.Applicative +import Control.Monad +import Control.Monad.Fix +import Control.Monad.Instances () + +-- | The parameterizable reader monad. +-- +-- Computations are functions of a shared environment. +-- +-- The 'return' function ignores the environment, while @>>=@ passes +-- the inherited environment to both subcomputations. +type Reader r = ReaderT r Identity + +-- | Constructor for computations in the reader monad (equivalent to 'asks'). +reader :: Monad m => (r -> a) -> ReaderT r m a +reader f = ReaderT (return . f) + +-- | Runs a @Reader@ and extracts the final value from it. +-- (The inverse of 'reader'.) +runReader :: Reader r a -- ^ A @Reader@ to run. + -> r -- ^ An initial environment. + -> a +runReader m = runIdentity . runReaderT m + +-- | Transform the value returned by a @Reader@. +-- +-- * @'runReader' ('mapReader' f m) = f . 'runReader' m@ +mapReader :: (a -> b) -> Reader r a -> Reader r b +mapReader f = mapReaderT (Identity . f . runIdentity) + +-- | Execute a computation in a modified environment +-- (a specialization of 'withReaderT'). +-- +-- * @'runReader' ('withReader' f m) = 'runReader' m . f@ +withReader + :: (r' -> r) -- ^ The function to modify the environment. + -> Reader r a -- ^ Computation to run in the modified environment. + -> Reader r' a +withReader = withReaderT + +-- | The reader monad transformer, +-- which adds a read-only environment to the given monad. +-- +-- The 'return' function ignores the environment, while @>>=@ passes +-- the inherited environment to both subcomputations. +newtype ReaderT r m a = ReaderT { + -- | The underlying computation, as a function of the environment. + runReaderT :: r -> m a + } + +-- | Transform the computation inside a @ReaderT@. +-- +-- * @'runReaderT' ('mapReaderT' f m) = f . 'runReaderT' m@ +mapReaderT :: (m a -> n b) -> ReaderT r m a -> ReaderT r n b +mapReaderT f m = ReaderT $ f . runReaderT m + +-- | Execute a computation in a modified environment +-- (a more general version of 'local'). +-- +-- * @'runReaderT' ('withReaderT' f m) = 'runReaderT' m . f@ +withReaderT + :: (r' -> r) -- ^ The function to modify the environment. + -> ReaderT r m a -- ^ Computation to run in the modified environment. + -> ReaderT r' m a +withReaderT f m = ReaderT $ runReaderT m . f + +instance (Functor m) => Functor (ReaderT r m) where + fmap f = mapReaderT (fmap f) + +instance (Applicative m) => Applicative (ReaderT r m) where + pure = liftReaderT . pure + f <*> v = ReaderT $ \ r -> runReaderT f r <*> runReaderT v r + +instance (Alternative m) => Alternative (ReaderT r m) where + empty = liftReaderT empty + m <|> n = ReaderT $ \ r -> runReaderT m r <|> runReaderT n r + +instance (Monad m) => Monad (ReaderT r m) where + return = lift . return + m >>= k = ReaderT $ \ r -> do + a <- runReaderT m r + runReaderT (k a) r + fail msg = lift (fail msg) + +instance (MonadPlus m) => MonadPlus (ReaderT r m) where + mzero = lift mzero + m `mplus` n = ReaderT $ \ r -> runReaderT m r `mplus` runReaderT n r + +instance (MonadFix m) => MonadFix (ReaderT r m) where + mfix f = ReaderT $ \ r -> mfix $ \ a -> runReaderT (f a) r + +instance MonadTrans (ReaderT r) where + lift = liftReaderT + +instance (MonadIO m) => MonadIO (ReaderT r m) where + liftIO = lift . liftIO + +liftReaderT :: m a -> ReaderT r m a +liftReaderT m = ReaderT (const m) + +-- | Fetch the value of the environment. +ask :: (Monad m) => ReaderT r m r +ask = ReaderT return + +-- | Execute a computation in a modified environment +-- (a specialization of 'withReaderT'). +-- +-- * @'runReaderT' ('local' f m) = 'runReaderT' m . f@ +local :: (Monad m) + => (r -> r) -- ^ The function to modify the environment. + -> ReaderT r m a -- ^ Computation to run in the modified environment. + -> ReaderT r m a +local = withReaderT + +-- | Retrieve a function of the current environment. +-- +-- * @'asks' f = 'liftM' f 'ask'@ +asks :: (Monad m) + => (r -> a) -- ^ The selector function to apply to the environment. + -> ReaderT r m a +asks f = ReaderT (return . f) + +-- | Lift a @callCC@ operation to the new monad. +liftCallCC :: + (((a -> m b) -> m a) -> m a) -- ^ @callCC@ on the argument monad. + -> ((a -> ReaderT r m b) -> ReaderT r m a) -> ReaderT r m a +liftCallCC callCC f = ReaderT $ \ r -> + callCC $ \ c -> + runReaderT (f (ReaderT . const . c)) r + +-- | Lift a @catchError@ operation to the new monad. +liftCatch :: + (m a -> (e -> m a) -> m a) -- ^ @catch@ on the argument monad. + -> ReaderT r m a -- ^ Computation to attempt. + -> (e -> ReaderT r m a) -- ^ Exception handler. + -> ReaderT r m a +liftCatch f m h = + ReaderT $ \ r -> f (runReaderT m r) (\ e -> runReaderT (h e) r) diff --git a/Control/Monad/Trans/State.hs b/Control/Monad/Trans/State.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Trans/State.hs @@ -0,0 +1,29 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.State +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : ross@soi.city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- State monads, passing an updatable state through a computation. +-- +-- Some computations may not require the full power of state transformers: +-- +-- * For a read-only state, see "Control.Monad.Trans.Reader". +-- +-- * To accumulate a value without using it on the way, see +-- "Control.Monad.Trans.Writer". +-- +-- This version is lazy; for a strict version, see +-- "Control.Monad.Trans.State.Strict", which has the same interface. +----------------------------------------------------------------------------- + +module Control.Monad.Trans.State ( + module Control.Monad.Trans.State.Lazy + ) where + +import Control.Monad.Trans.State.Lazy diff --git a/Control/Monad/Trans/State/Lazy.hs b/Control/Monad/Trans/State/Lazy.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Trans/State/Lazy.hs @@ -0,0 +1,366 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.State.Lazy +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : ross@soi.city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- Lazy state monads, passing an updatable state through a computation. +-- See below for examples. +-- +-- In this version, sequencing of computations is lazy. +-- For a strict version, see "Control.Monad.Trans.State.Strict", which +-- has the same interface. +-- +-- Some computations may not require the full power of state transformers: +-- +-- * For a read-only state, see "Control.Monad.Trans.Reader". +-- +-- * To accumulate a value without using it on the way, see +-- "Control.Monad.Trans.Writer". +----------------------------------------------------------------------------- + +module Control.Monad.Trans.State.Lazy ( + -- * The State monad + State, + state, + runState, + evalState, + execState, + mapState, + withState, + -- * The StateT monad transformer + StateT(..), + evalStateT, + execStateT, + mapStateT, + withStateT, + -- * State operations + get, + put, + modify, + gets, + -- * Lifting other operations + liftCallCC, + liftCallCC', + liftCatch, + liftListen, + liftPass, + -- * Examples + -- ** State monads + -- $examples + + -- ** Counting + -- $counting + + -- ** Labelling trees + -- $labelling + ) where + +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Data.Functor.Identity + +import Control.Applicative +import Control.Monad +import Control.Monad.Fix + +-- --------------------------------------------------------------------------- +-- | A state monad parameterized by the type @s@ of the state to carry. +-- +-- The 'return' function leaves the state unchanged, while @>>=@ uses +-- the final state of the first computation as the initial state of +-- the second. +type State s = StateT s Identity + +-- | Construct a state monad computation from a function. +-- (The inverse of 'runState'.) +state :: Monad m + => (s -> (a, s)) -- ^pure state transformer + -> StateT s m a -- ^equivalent state-passing computation +state f = StateT (return . f) + +-- | Unwrap a state monad computation as a function. +-- (The inverse of 'state'.) +runState :: State s a -- ^state-passing computation to execute + -> s -- ^initial state + -> (a, s) -- ^return value and final state +runState m = runIdentity . runStateT m + +-- | Evaluate a state computation with the given initial state +-- and return the final value, discarding the final state. +-- +-- * @'evalState' m s = 'fst' ('runState' m s)@ +evalState :: State s a -- ^state-passing computation to execute + -> s -- ^initial value + -> a -- ^return value of the state computation +evalState m s = fst (runState m s) + +-- | Evaluate a state computation with the given initial state +-- and return the final state, discarding the final value. +-- +-- * @'execState' m s = 'snd' ('runState' m s)@ +execState :: State s a -- ^state-passing computation to execute + -> s -- ^initial value + -> s -- ^final state +execState m s = snd (runState m s) + +-- | Map both the return value and final state of a computation using +-- the given function. +-- +-- * @'runState' ('mapState' f m) = f . 'runState' m@ +mapState :: ((a, s) -> (b, s)) -> State s a -> State s b +mapState f = mapStateT (Identity . f . runIdentity) + +-- | @'withState' f m@ executes action @m@ on a state modified by +-- applying @f@. +-- +-- * @'withState' f m = 'modify' f >> m@ +withState :: (s -> s) -> State s a -> State s a +withState = withStateT + +-- --------------------------------------------------------------------------- +-- | A state transformer monad parameterized by: +-- +-- * @s@ - The state. +-- +-- * @m@ - The inner monad. +-- +-- The 'return' function leaves the state unchanged, while @>>=@ uses +-- the final state of the first computation as the initial state of +-- the second. +newtype StateT s m a = StateT { runStateT :: s -> m (a,s) } + +-- | Evaluate a state computation with the given initial state +-- and return the final value, discarding the final state. +-- +-- * @'evalStateT' m s = 'liftM' 'fst' ('runStateT' m s)@ +evalStateT :: (Monad m) => StateT s m a -> s -> m a +evalStateT m s = do + ~(a, _) <- runStateT m s + return a + +-- | Evaluate a state computation with the given initial state +-- and return the final state, discarding the final value. +-- +-- * @'execStateT' m s = 'liftM' 'snd' ('runStateT' m s)@ +execStateT :: (Monad m) => StateT s m a -> s -> m s +execStateT m s = do + ~(_, s') <- runStateT m s + return s' + +-- | Map both the return value and final state of a computation using +-- the given function. +-- +-- * @'runStateT' ('mapStateT' f m) = f . 'runStateT' m@ +mapStateT :: (m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b +mapStateT f m = StateT $ f . runStateT m + +-- | @'withStateT' f m@ executes action @m@ on a state modified by +-- applying @f@. +-- +-- * @'withStateT' f m = 'modify' f >> m@ +withStateT :: (s -> s) -> StateT s m a -> StateT s m a +withStateT f m = StateT $ runStateT m . f + +instance (Functor m) => Functor (StateT s m) where + fmap f m = StateT $ \ s -> + fmap (\ ~(a, s') -> (f a, s')) $ runStateT m s + +instance (Functor m, Monad m) => Applicative (StateT s m) where + pure = return + (<*>) = ap + +instance (Functor m, MonadPlus m) => Alternative (StateT s m) where + empty = mzero + (<|>) = mplus + +instance (Monad m) => Monad (StateT s m) where + return a = state $ \s -> (a, s) + m >>= k = StateT $ \s -> do + ~(a, s') <- runStateT m s + runStateT (k a) s' + fail str = StateT $ \_ -> fail str + +instance (MonadPlus m) => MonadPlus (StateT s m) where + mzero = StateT $ \_ -> mzero + m `mplus` n = StateT $ \s -> runStateT m s `mplus` runStateT n s + +instance (MonadFix m) => MonadFix (StateT s m) where + mfix f = StateT $ \s -> mfix $ \ ~(a, _) -> runStateT (f a) s + +instance MonadTrans (StateT s) where + lift m = StateT $ \s -> do + a <- m + return (a, s) + +instance (MonadIO m) => MonadIO (StateT s m) where + liftIO = lift . liftIO + +-- | Fetch the current value of the state within the monad. +get :: (Monad m) => StateT s m s +get = state $ \s -> (s, s) + +-- | @'put' s@ sets the state within the monad to @s@. +put :: (Monad m) => s -> StateT s m () +put s = state $ \_ -> ((), s) + +-- | @'modify' f@ is an action that updates the state to the result of +-- applying @f@ to the current state. +-- +-- * @'modify' f = 'get' >>= ('put' . f)@ +modify :: (Monad m) => (s -> s) -> StateT s m () +modify f = state $ \s -> ((), f s) + +-- | Get a specific component of the state, using a projection function +-- supplied. +-- +-- * @'gets' f = 'liftM' f 'get'@ +gets :: (Monad m) => (s -> a) -> StateT s m a +gets f = state $ \s -> (f s, s) + +-- | Uniform lifting of a @callCC@ operation to the new monad. +-- This version rolls back to the original state on entering the +-- continuation. +liftCallCC :: ((((a,s) -> m (b,s)) -> m (a,s)) -> m (a,s)) -> + ((a -> StateT s m b) -> StateT s m a) -> StateT s m a +liftCallCC callCC f = StateT $ \s -> + callCC $ \c -> + runStateT (f (\a -> StateT $ \ _ -> c (a, s))) s + +-- | In-situ lifting of a @callCC@ operation to the new monad. +-- This version uses the current state on entering the continuation. +-- It does not satisfy the laws of a monad transformer. +liftCallCC' :: ((((a,s) -> m (b,s)) -> m (a,s)) -> m (a,s)) -> + ((a -> StateT s m b) -> StateT s m a) -> StateT s m a +liftCallCC' callCC f = StateT $ \s -> + callCC $ \c -> + runStateT (f (\a -> StateT $ \s' -> c (a, s'))) s + +-- | Lift a @catchError@ operation to the new monad. +liftCatch :: (m (a,s) -> (e -> m (a,s)) -> m (a,s)) -> + StateT s m a -> (e -> StateT s m a) -> StateT s m a +liftCatch catchError m h = + StateT $ \s -> runStateT m s `catchError` \e -> runStateT (h e) s + +-- | Lift a @listen@ operation to the new monad. +liftListen :: Monad m => + (m (a,s) -> m ((a,s),w)) -> StateT s m a -> StateT s m (a,w) +liftListen listen m = StateT $ \s -> do + ~((a, s'), w) <- listen (runStateT m s) + return ((a, w), s') + +-- | Lift a @pass@ operation to the new monad. +liftPass :: Monad m => + (m ((a,s),b) -> m (a,s)) -> StateT s m (a,b) -> StateT s m a +liftPass pass m = StateT $ \s -> pass $ do + ~((a, f), s') <- runStateT m s + return ((a, s'), f) + +{- $examples + +Parser from ParseLib with Hugs: + +> type Parser a = StateT String [] a +> ==> StateT (String -> [(a,String)]) + +For example, item can be written as: + +> item = do (x:xs) <- get +> put xs +> return x +> +> type BoringState s a = StateT s Identity a +> ==> StateT (s -> Identity (a,s)) +> +> type StateWithIO s a = StateT s IO a +> ==> StateT (s -> IO (a,s)) +> +> type StateWithErr s a = StateT s Maybe a +> ==> StateT (s -> Maybe (a,s)) + +-} + +{- $counting + +A function to increment a counter. +Taken from the paper \"Generalising Monads to Arrows\", +John Hughes (), November 1998: + +> tick :: State Int Int +> tick = do n <- get +> put (n+1) +> return n + +Add one to the given number using the state monad: + +> plusOne :: Int -> Int +> plusOne n = execState tick n + +A contrived addition example. Works only with positive numbers: + +> plus :: Int -> Int -> Int +> plus n x = execState (sequence $ replicate n tick) x + +-} + +{- $labelling + +An example from /The Craft of Functional Programming/, Simon +Thompson (), +Addison-Wesley 1999: \"Given an arbitrary tree, transform it to a +tree of integers in which the original elements are replaced by +natural numbers, starting from 0. The same element has to be +replaced by the same number at every occurrence, and when we meet +an as-yet-unvisited element we have to find a \'new\' number to match +it with:\" + +> data Tree a = Nil | Node a (Tree a) (Tree a) deriving (Show, Eq) +> type Table a = [a] + +> numberTree :: Eq a => Tree a -> State (Table a) (Tree Int) +> numberTree Nil = return Nil +> numberTree (Node x t1 t2) +> = do num <- numberNode x +> nt1 <- numberTree t1 +> nt2 <- numberTree t2 +> return (Node num nt1 nt2) +> where +> numberNode :: Eq a => a -> State (Table a) Int +> numberNode x +> = do table <- get +> (newTable, newPos) <- return (nNode x table) +> put newTable +> return newPos +> nNode:: (Eq a) => a -> Table a -> (Table a, Int) +> nNode x table +> = case (findIndexInList (== x) table) of +> Nothing -> (table ++ [x], length table) +> Just i -> (table, i) +> findIndexInList :: (a -> Bool) -> [a] -> Maybe Int +> findIndexInList = findIndexInListHelp 0 +> findIndexInListHelp _ _ [] = Nothing +> findIndexInListHelp count f (h:t) +> = if (f h) +> then Just count +> else findIndexInListHelp (count+1) f t + +numTree applies numberTree with an initial state: + +> numTree :: (Eq a) => Tree a -> Tree Int +> numTree t = evalState (numberTree t) [] + +> testTree = Node "Zero" (Node "One" (Node "Two" Nil Nil) (Node "One" (Node "Zero" Nil Nil) Nil)) Nil +> numTree testTree => Node 0 (Node 1 (Node 2 Nil Nil) (Node 1 (Node 0 Nil Nil) Nil)) Nil + +sumTree is a little helper function that does not use the State monad: + +> sumTree :: (Num a) => Tree a -> a +> sumTree Nil = 0 +> sumTree (Node e t1 t2) = e + (sumTree t1) + (sumTree t2) + +-} diff --git a/Control/Monad/Trans/State/Strict.hs b/Control/Monad/Trans/State/Strict.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Trans/State/Strict.hs @@ -0,0 +1,366 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.State.Strict +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : ross@soi.city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- Strict state monads, passing an updatable state through a computation. +-- See below for examples. +-- +-- In this version, sequencing of computations is strict. +-- For a lazy version, see "Control.Monad.Trans.State.Lazy", which +-- has the same interface. +-- +-- Some computations may not require the full power of state transformers: +-- +-- * For a read-only state, see "Control.Monad.Trans.Reader". +-- +-- * To accumulate a value without using it on the way, see +-- "Control.Monad.Trans.Writer". +----------------------------------------------------------------------------- + +module Control.Monad.Trans.State.Strict ( + -- * The State monad + State, + state, + runState, + evalState, + execState, + mapState, + withState, + -- * The StateT monad transformer + StateT(..), + evalStateT, + execStateT, + mapStateT, + withStateT, + -- * State operations + get, + put, + modify, + gets, + -- * Lifting other operations + liftCallCC, + liftCallCC', + liftCatch, + liftListen, + liftPass, + -- * Examples + -- ** State monads + -- $examples + + -- ** Counting + -- $counting + + -- ** Labelling trees + -- $labelling + ) where + +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Data.Functor.Identity + +import Control.Applicative +import Control.Monad +import Control.Monad.Fix + +-- --------------------------------------------------------------------------- +-- | A state monad parameterized by the type @s@ of the state to carry. +-- +-- The 'return' function leaves the state unchanged, while @>>=@ uses +-- the final state of the first computation as the initial state of +-- the second. +type State s = StateT s Identity + +-- | Construct a state monad computation from a function. +-- (The inverse of 'runState'.) +state :: Monad m + => (s -> (a, s)) -- ^pure state transformer + -> StateT s m a -- ^equivalent state-passing computation +state f = StateT (return . f) + +-- | Unwrap a state monad computation as a function. +-- (The inverse of 'state'.) +runState :: State s a -- ^state-passing computation to execute + -> s -- ^initial state + -> (a, s) -- ^return value and final state +runState m = runIdentity . runStateT m + +-- | Evaluate a state computation with the given initial state +-- and return the final value, discarding the final state. +-- +-- * @'evalState' m s = 'fst' ('runState' m s)@ +evalState :: State s a -- ^state-passing computation to execute + -> s -- ^initial value + -> a -- ^return value of the state computation +evalState m s = fst (runState m s) + +-- | Evaluate a state computation with the given initial state +-- and return the final state, discarding the final value. +-- +-- * @'execState' m s = 'snd' ('runState' m s)@ +execState :: State s a -- ^state-passing computation to execute + -> s -- ^initial value + -> s -- ^final state +execState m s = snd (runState m s) + +-- | Map both the return value and final state of a computation using +-- the given function. +-- +-- * @'runState' ('mapState' f m) = f . 'runState' m@ +mapState :: ((a, s) -> (b, s)) -> State s a -> State s b +mapState f = mapStateT (Identity . f . runIdentity) + +-- | @'withState' f m@ executes action @m@ on a state modified by +-- applying @f@. +-- +-- * @'withState' f m = 'modify' f >> m@ +withState :: (s -> s) -> State s a -> State s a +withState = withStateT + +-- --------------------------------------------------------------------------- +-- | A state transformer monad parameterized by: +-- +-- * @s@ - The state. +-- +-- * @m@ - The inner monad. +-- +-- The 'return' function leaves the state unchanged, while @>>=@ uses +-- the final state of the first computation as the initial state of +-- the second. +newtype StateT s m a = StateT { runStateT :: s -> m (a,s) } + +-- | Evaluate a state computation with the given initial state +-- and return the final value, discarding the final state. +-- +-- * @'evalStateT' m s = 'liftM' 'fst' ('runStateT' m s)@ +evalStateT :: (Monad m) => StateT s m a -> s -> m a +evalStateT m s = do + (a, _) <- runStateT m s + return a + +-- | Evaluate a state computation with the given initial state +-- and return the final state, discarding the final value. +-- +-- * @'execStateT' m s = 'liftM' 'snd' ('runStateT' m s)@ +execStateT :: (Monad m) => StateT s m a -> s -> m s +execStateT m s = do + (_, s') <- runStateT m s + return s' + +-- | Map both the return value and final state of a computation using +-- the given function. +-- +-- * @'runStateT' ('mapStateT' f m) = f . 'runStateT' m@ +mapStateT :: (m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b +mapStateT f m = StateT $ f . runStateT m + +-- | @'withStateT' f m@ executes action @m@ on a state modified by +-- applying @f@. +-- +-- * @'withStateT' f m = 'modify' f >> m@ +withStateT :: (s -> s) -> StateT s m a -> StateT s m a +withStateT f m = StateT $ runStateT m . f + +instance (Functor m) => Functor (StateT s m) where + fmap f m = StateT $ \ s -> + fmap (\ (a, s') -> (f a, s')) $ runStateT m s + +instance (Functor m, Monad m) => Applicative (StateT s m) where + pure = return + (<*>) = ap + +instance (Functor m, MonadPlus m) => Alternative (StateT s m) where + empty = mzero + (<|>) = mplus + +instance (Monad m) => Monad (StateT s m) where + return a = state $ \s -> (a, s) + m >>= k = StateT $ \s -> do + (a, s') <- runStateT m s + runStateT (k a) s' + fail str = StateT $ \_ -> fail str + +instance (MonadPlus m) => MonadPlus (StateT s m) where + mzero = StateT $ \_ -> mzero + m `mplus` n = StateT $ \s -> runStateT m s `mplus` runStateT n s + +instance (MonadFix m) => MonadFix (StateT s m) where + mfix f = StateT $ \s -> mfix $ \ ~(a, _) -> runStateT (f a) s + +instance MonadTrans (StateT s) where + lift m = StateT $ \s -> do + a <- m + return (a, s) + +instance (MonadIO m) => MonadIO (StateT s m) where + liftIO = lift . liftIO + +-- | Fetch the current value of the state within the monad. +get :: (Monad m) => StateT s m s +get = state $ \s -> (s, s) + +-- | @'put' s@ sets the state within the monad to @s@. +put :: (Monad m) => s -> StateT s m () +put s = state $ \_ -> ((), s) + +-- | @'modify' f@ is an action that updates the state to the result of +-- applying @f@ to the current state. +-- +-- * @'modify' f = 'get' >>= ('put' . f)@ +modify :: (Monad m) => (s -> s) -> StateT s m () +modify f = state $ \s -> ((), f s) + +-- | Get a specific component of the state, using a projection function +-- supplied. +-- +-- * @'gets' f = 'liftM' f 'get'@ +gets :: (Monad m) => (s -> a) -> StateT s m a +gets f = state $ \s -> (f s, s) + +-- | Uniform lifting of a @callCC@ operation to the new monad. +-- This version rolls back to the original state on entering the +-- continuation. +liftCallCC :: ((((a,s) -> m (b,s)) -> m (a,s)) -> m (a,s)) -> + ((a -> StateT s m b) -> StateT s m a) -> StateT s m a +liftCallCC callCC f = StateT $ \s -> + callCC $ \c -> + runStateT (f (\a -> StateT $ \ _ -> c (a, s))) s + +-- | In-situ lifting of a @callCC@ operation to the new monad. +-- This version uses the current state on entering the continuation. +-- It does not satisfy the laws of a monad transformer. +liftCallCC' :: ((((a,s) -> m (b,s)) -> m (a,s)) -> m (a,s)) -> + ((a -> StateT s m b) -> StateT s m a) -> StateT s m a +liftCallCC' callCC f = StateT $ \s -> + callCC $ \c -> + runStateT (f (\a -> StateT $ \s' -> c (a, s'))) s + +-- | Lift a @catchError@ operation to the new monad. +liftCatch :: (m (a,s) -> (e -> m (a,s)) -> m (a,s)) -> + StateT s m a -> (e -> StateT s m a) -> StateT s m a +liftCatch catchError m h = + StateT $ \s -> runStateT m s `catchError` \e -> runStateT (h e) s + +-- | Lift a @listen@ operation to the new monad. +liftListen :: Monad m => + (m (a,s) -> m ((a,s),w)) -> StateT s m a -> StateT s m (a,w) +liftListen listen m = StateT $ \s -> do + ((a, s'), w) <- listen (runStateT m s) + return ((a, w), s') + +-- | Lift a @pass@ operation to the new monad. +liftPass :: Monad m => + (m ((a,s),b) -> m (a,s)) -> StateT s m (a,b) -> StateT s m a +liftPass pass m = StateT $ \s -> pass $ do + ((a, f), s') <- runStateT m s + return ((a, s'), f) + +{- $examples + +Parser from ParseLib with Hugs: + +> type Parser a = StateT String [] a +> ==> StateT (String -> [(a,String)]) + +For example, item can be written as: + +> item = do (x:xs) <- get +> put xs +> return x +> +> type BoringState s a = StateT s Identity a +> ==> StateT (s -> Identity (a,s)) +> +> type StateWithIO s a = StateT s IO a +> ==> StateT (s -> IO (a,s)) +> +> type StateWithErr s a = StateT s Maybe a +> ==> StateT (s -> Maybe (a,s)) + +-} + +{- $counting + +A function to increment a counter. +Taken from the paper \"Generalising Monads to Arrows\", +John Hughes (), November 1998: + +> tick :: State Int Int +> tick = do n <- get +> put (n+1) +> return n + +Add one to the given number using the state monad: + +> plusOne :: Int -> Int +> plusOne n = execState tick n + +A contrived addition example. Works only with positive numbers: + +> plus :: Int -> Int -> Int +> plus n x = execState (sequence $ replicate n tick) x + +-} + +{- $labelling + +An example from /The Craft of Functional Programming/, Simon +Thompson (), +Addison-Wesley 1999: \"Given an arbitrary tree, transform it to a +tree of integers in which the original elements are replaced by +natural numbers, starting from 0. The same element has to be +replaced by the same number at every occurrence, and when we meet +an as-yet-unvisited element we have to find a \'new\' number to match +it with:\" + +> data Tree a = Nil | Node a (Tree a) (Tree a) deriving (Show, Eq) +> type Table a = [a] + +> numberTree :: Eq a => Tree a -> State (Table a) (Tree Int) +> numberTree Nil = return Nil +> numberTree (Node x t1 t2) +> = do num <- numberNode x +> nt1 <- numberTree t1 +> nt2 <- numberTree t2 +> return (Node num nt1 nt2) +> where +> numberNode :: Eq a => a -> State (Table a) Int +> numberNode x +> = do table <- get +> (newTable, newPos) <- return (nNode x table) +> put newTable +> return newPos +> nNode:: (Eq a) => a -> Table a -> (Table a, Int) +> nNode x table +> = case (findIndexInList (== x) table) of +> Nothing -> (table ++ [x], length table) +> Just i -> (table, i) +> findIndexInList :: (a -> Bool) -> [a] -> Maybe Int +> findIndexInList = findIndexInListHelp 0 +> findIndexInListHelp _ _ [] = Nothing +> findIndexInListHelp count f (h:t) +> = if (f h) +> then Just count +> else findIndexInListHelp (count+1) f t + +numTree applies numberTree with an initial state: + +> numTree :: (Eq a) => Tree a -> Tree Int +> numTree t = evalState (numberTree t) [] + +> testTree = Node "Zero" (Node "One" (Node "Two" Nil Nil) (Node "One" (Node "Zero" Nil Nil) Nil)) Nil +> numTree testTree => Node 0 (Node 1 (Node 2 Nil Nil) (Node 1 (Node 0 Nil Nil) Nil)) Nil + +sumTree is a little helper function that does not use the State monad: + +> sumTree :: (Num a) => Tree a -> a +> sumTree Nil = 0 +> sumTree (Node e t1 t2) = e + (sumTree t1) + (sumTree t2) + +-} diff --git a/Control/Monad/Trans/Writer.hs b/Control/Monad/Trans/Writer.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Trans/Writer.hs @@ -0,0 +1,21 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Writer +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : ross@soi.city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- The WriterT monad transformer. +-- This version is lazy; for a strict version, see +-- "Control.Monad.Trans.Writer.Strict", which has the same interface. +----------------------------------------------------------------------------- + +module Control.Monad.Trans.Writer ( + module Control.Monad.Trans.Writer.Lazy + ) where + +import Control.Monad.Trans.Writer.Lazy diff --git a/Control/Monad/Trans/Writer/Lazy.hs b/Control/Monad/Trans/Writer/Lazy.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Trans/Writer/Lazy.hs @@ -0,0 +1,211 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Writer.Lazy +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : ross@soi.city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- The lazy 'WriterT' monad transformer, which adds collection of +-- outputs (such as a count or string output) to a given monad. +-- +-- This version builds its output lazily; for a strict version, see +-- "Control.Monad.Trans.Writer.Strict", which has the same interface. +-- +-- This monad transformer provides only limited access to the output +-- during the computation. For more general access, use +-- "Control.Monad.Trans.State" instead. +----------------------------------------------------------------------------- + +module Control.Monad.Trans.Writer.Lazy ( + -- * The Writer monad + Writer, + writer, + runWriter, + execWriter, + mapWriter, + -- * The WriterT monad transformer + WriterT(..), + execWriterT, + mapWriterT, + -- * Writer operations + tell, + listen, + listens, + pass, + censor, + -- * Lifting other operations + liftCallCC, + liftCatch, + ) where + +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Data.Functor.Identity + +import Control.Applicative +import Control.Monad +import Control.Monad.Fix +import Data.Foldable (Foldable(foldMap)) +import Data.Monoid +import Data.Traversable (Traversable(traverse)) + +-- --------------------------------------------------------------------------- +-- | A writer monad parameterized by the type @w@ of output to accumulate. +-- +-- The 'return' function produces the output 'mempty', while @>>=@ +-- combines the outputs of the subcomputations using 'mappend'. +type Writer w = WriterT w Identity + +-- | Construct a writer computation from a (result, output) pair. +-- (The inverse of 'runWriter'.) +writer :: Monad m => (a, w) -> WriterT w m a +writer = WriterT . return + +-- | Unwrap a writer computation as a (result, output) pair. +-- (The inverse of 'writer'.) +runWriter :: Writer w a -> (a, w) +runWriter = runIdentity . runWriterT + +-- | Extract the output from a writer computation. +-- +-- * @'execWriter' m = 'snd' ('runWriter' m)@ +execWriter :: Writer w a -> w +execWriter m = snd (runWriter m) + +-- | Map both the return value and output of a computation using +-- the given function. +-- +-- * @'runWriter' ('mapWriter' f m) = f ('runWriter' m)@ +mapWriter :: ((a, w) -> (b, w')) -> Writer w a -> Writer w' b +mapWriter f = mapWriterT (Identity . f . runIdentity) + +-- --------------------------------------------------------------------------- +-- | A writer monad parameterized by: +-- +-- * @w@ - the output to accumulate. +-- +-- * @m@ - The inner monad. +-- +-- The 'return' function produces the output 'mempty', while @>>=@ +-- combines the outputs of the subcomputations using 'mappend'. +newtype WriterT w m a = WriterT { runWriterT :: m (a, w) } + +-- | Extract the output from a writer computation. +-- +-- * @'execWriterT' m = 'liftM' 'snd' ('runWriterT' m)@ +execWriterT :: Monad m => WriterT w m a -> m w +execWriterT m = do + ~(_, w) <- runWriterT m + return w + +-- | Map both the return value and output of a computation using +-- the given function. +-- +-- * @'runWriterT' ('mapWriterT' f m) = f ('runWriterT' m)@ +mapWriterT :: (m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b +mapWriterT f m = WriterT $ f (runWriterT m) + +instance (Functor m) => Functor (WriterT w m) where + fmap f = mapWriterT $ fmap $ \ ~(a, w) -> (f a, w) + +instance (Monoid w, Applicative m) => Applicative (WriterT w m) where + pure a = WriterT $ pure (a, mempty) + f <*> v = WriterT $ liftA2 k (runWriterT f) (runWriterT v) + where k ~(a, w) ~(b, w') = (a b, w `mappend` w') + +instance (Monoid w, Alternative m) => Alternative (WriterT w m) where + empty = WriterT empty + m <|> n = WriterT $ runWriterT m <|> runWriterT n + +instance (Monoid w, Monad m) => Monad (WriterT w m) where + return a = writer (a, mempty) + m >>= k = WriterT $ do + ~(a, w) <- runWriterT m + ~(b, w') <- runWriterT (k a) + return (b, w `mappend` w') + fail msg = WriterT $ fail msg + +instance (Monoid w, MonadPlus m) => MonadPlus (WriterT w m) where + mzero = WriterT mzero + m `mplus` n = WriterT $ runWriterT m `mplus` runWriterT n + +instance (Monoid w, MonadFix m) => MonadFix (WriterT w m) where + mfix m = WriterT $ mfix $ \ ~(a, _) -> runWriterT (m a) + +instance (Monoid w) => MonadTrans (WriterT w) where + lift m = WriterT $ do + a <- m + return (a, mempty) + +instance (Monoid w, MonadIO m) => MonadIO (WriterT w m) where + liftIO = lift . liftIO + +instance Foldable f => Foldable (WriterT w f) where + foldMap f (WriterT a) = foldMap (f . fst) a + +instance Traversable f => Traversable (WriterT w f) where + traverse f (WriterT a) = WriterT <$> traverse f' a where + f' (a, b) = fmap (\c -> (c, b)) (f a) + +-- | @'tell' w@ is an action that produces the output @w@. +tell :: (Monoid w, Monad m) => w -> WriterT w m () +tell w = writer ((), w) + +-- | @'listen' m@ is an action that executes the action @m@ and adds its +-- output to the value of the computation. +-- +-- * @'runWriterT' ('listen' m) = 'liftM' (\\(a, w) -> ((a, w), w)) ('runWriterT' m)@ +listen :: (Monoid w, Monad m) => WriterT w m a -> WriterT w m (a, w) +listen m = WriterT $ do + ~(a, w) <- runWriterT m + return ((a, w), w) + +-- | @'listens' f m@ is an action that executes the action @m@ and adds +-- the result of applying @f@ to the output to the value of the computation. +-- +-- * @'listens' f m = 'liftM' (id *** f) ('listen' m)@ +-- +-- * @'runWriterT' ('listens' f m) = 'liftM' (\\(a, w) -> ((a, f w), w)) ('runWriterT' m)@ +listens :: (Monoid w, Monad m) => (w -> b) -> WriterT w m a -> WriterT w m (a, b) +listens f m = WriterT $ do + ~(a, w) <- runWriterT m + return ((a, f w), w) + +-- | @'pass' m@ is an action that executes the action @m@, which returns +-- a value and a function, and returns the value, applying the function +-- to the output. +-- +-- * @'runWriterT' ('pass' m) = 'liftM' (\\((a, f), w) -> (a, f w)) ('runWriterT' m)@ +pass :: (Monoid w, Monad m) => WriterT w m (a, w -> w) -> WriterT w m a +pass m = WriterT $ do + ~((a, f), w) <- runWriterT m + return (a, f w) + +-- | @'censor' f m@ is an action that executes the action @m@ and +-- applies the function @f@ to its output, leaving the return value +-- unchanged. +-- +-- * @'censor' f m = 'pass' ('liftM' (\\x -> (x,f)) m)@ +-- +-- * @'runWriterT' ('censor' f m) = 'liftM' (\\(a, w) -> (a, f w)) ('runWriterT' m)@ +censor :: (Monoid w, Monad m) => (w -> w) -> WriterT w m a -> WriterT w m a +censor f m = WriterT $ do + ~(a, w) <- runWriterT m + return (a, f w) + +-- | Lift a @callCC@ operation to the new monad. +liftCallCC :: (Monoid w) => ((((a,w) -> m (b,w)) -> m (a,w)) -> m (a,w)) -> + ((a -> WriterT w m b) -> WriterT w m a) -> WriterT w m a +liftCallCC callCC f = WriterT $ + callCC $ \c -> + runWriterT (f (\a -> WriterT $ c (a, mempty))) + +-- | Lift a @catchError@ operation to the new monad. +liftCatch :: (m (a,w) -> (e -> m (a,w)) -> m (a,w)) -> + WriterT w m a -> (e -> WriterT w m a) -> WriterT w m a +liftCatch catchError m h = + WriterT $ runWriterT m `catchError` \e -> runWriterT (h e) diff --git a/Control/Monad/Trans/Writer/Strict.hs b/Control/Monad/Trans/Writer/Strict.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Trans/Writer/Strict.hs @@ -0,0 +1,211 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans.Writer.Strict +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : ross@soi.city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- The strict 'WriterT' monad transformer, which adds collection of +-- outputs (such as a count or string output) to a given monad. +-- +-- This version builds its output strictly; for a lazy version, see +-- "Control.Monad.Trans.Writer.Lazy", which has the same interface. +-- +-- This monad transformer provides only limited access to the output +-- during the computation. For more general access, use +-- "Control.Monad.Trans.State" instead. +----------------------------------------------------------------------------- + +module Control.Monad.Trans.Writer.Strict ( + -- * The Writer monad + Writer, + writer, + runWriter, + execWriter, + mapWriter, + -- * The WriterT monad transformer + WriterT(..), + execWriterT, + mapWriterT, + -- * Writer operations + tell, + listen, + listens, + pass, + censor, + -- * Lifting other operations + liftCallCC, + liftCatch, + ) where + +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Data.Functor.Identity + +import Control.Applicative +import Control.Monad +import Control.Monad.Fix +import Data.Foldable (Foldable(foldMap)) +import Data.Monoid +import Data.Traversable (Traversable(traverse)) + +-- --------------------------------------------------------------------------- +-- | A writer monad parameterized by the type @w@ of output to accumulate. +-- +-- The 'return' function produces the output 'mempty', while @>>=@ +-- combines the outputs of the subcomputations using 'mappend'. +type Writer w = WriterT w Identity + +-- | Construct a writer computation from a (result, output) pair. +-- (The inverse of 'runWriter'.) +writer :: Monad m => (a, w) -> WriterT w m a +writer = WriterT . return + +-- | Unwrap a writer computation as a (result, output) pair. +-- (The inverse of 'writer'.) +runWriter :: Writer w a -> (a, w) +runWriter = runIdentity . runWriterT + +-- | Extract the output from a writer computation. +-- +-- * @'execWriter' m = 'snd' ('runWriter' m)@ +execWriter :: Writer w a -> w +execWriter m = snd (runWriter m) + +-- | Map both the return value and output of a computation using +-- the given function. +-- +-- * @'runWriter' ('mapWriter' f m) = f ('runWriter' m)@ +mapWriter :: ((a, w) -> (b, w')) -> Writer w a -> Writer w' b +mapWriter f = mapWriterT (Identity . f . runIdentity) + +-- --------------------------------------------------------------------------- +-- | A writer monad parameterized by: +-- +-- * @w@ - the output to accumulate. +-- +-- * @m@ - The inner monad. +-- +-- The 'return' function produces the output 'mempty', while @>>=@ +-- combines the outputs of the subcomputations using 'mappend'. +newtype WriterT w m a = WriterT { runWriterT :: m (a, w) } + +-- | Extract the output from a writer computation. +-- +-- * @'execWriterT' m = 'liftM' 'snd' ('runWriterT' m)@ +execWriterT :: Monad m => WriterT w m a -> m w +execWriterT m = do + (_, w) <- runWriterT m + return w + +-- | Map both the return value and output of a computation using +-- the given function. +-- +-- * @'runWriterT' ('mapWriterT' f m) = f ('runWriterT' m)@ +mapWriterT :: (m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b +mapWriterT f m = WriterT $ f (runWriterT m) + +instance (Functor m) => Functor (WriterT w m) where + fmap f = mapWriterT $ fmap $ \ (a, w) -> (f a, w) + +instance (Foldable f) => Foldable (WriterT w f) where + foldMap f (WriterT a) = foldMap (f . fst) a + +instance (Traversable f) => Traversable (WriterT w f) where + traverse f (WriterT a) = WriterT <$> traverse f' a where + f' (a, b) = fmap (\c -> (c, b)) (f a) + +instance (Monoid w, Applicative m) => Applicative (WriterT w m) where + pure a = WriterT $ pure (a, mempty) + f <*> v = WriterT $ liftA2 k (runWriterT f) (runWriterT v) + where k (a, w) (b, w') = (a b, w `mappend` w') + +instance (Monoid w, Alternative m) => Alternative (WriterT w m) where + empty = WriterT empty + m <|> n = WriterT $ runWriterT m <|> runWriterT n + +instance (Monoid w, Monad m) => Monad (WriterT w m) where + return a = WriterT $ return (a, mempty) + m >>= k = WriterT $ do + (a, w) <- runWriterT m + (b, w') <- runWriterT (k a) + return (b, w `mappend` w') + fail msg = WriterT $ fail msg + +instance (Monoid w, MonadPlus m) => MonadPlus (WriterT w m) where + mzero = WriterT mzero + m `mplus` n = WriterT $ runWriterT m `mplus` runWriterT n + +instance (Monoid w, MonadFix m) => MonadFix (WriterT w m) where + mfix m = WriterT $ mfix $ \ ~(a, _) -> runWriterT (m a) + +instance (Monoid w) => MonadTrans (WriterT w) where + lift m = WriterT $ do + a <- m + return (a, mempty) + +instance (Monoid w, MonadIO m) => MonadIO (WriterT w m) where + liftIO = lift . liftIO + +-- | @'tell' w@ is an action that produces the output @w@. +tell :: (Monoid w, Monad m) => w -> WriterT w m () +tell w = WriterT $ return ((), w) + +-- | @'listen' m@ is an action that executes the action @m@ and adds its +-- output to the value of the computation. +-- +-- * @'runWriterT' ('listen' m) = 'liftM' (\\(a, w) -> ((a, w), w)) ('runWriterT' m)@ +listen :: (Monoid w, Monad m) => WriterT w m a -> WriterT w m (a, w) +listen m = WriterT $ do + (a, w) <- runWriterT m + return ((a, w), w) + +-- | @'listens' f m@ is an action that executes the action @m@ and adds +-- the result of applying @f@ to the output to the value of the computation. +-- +-- * @'listens' f m = 'liftM' (id *** f) ('listen' m)@ +-- +-- * @'runWriterT' ('listens' f m) = 'liftM' (\\(a, w) -> ((a, f w), w)) ('runWriterT' m)@ +listens :: (Monoid w, Monad m) => (w -> b) -> WriterT w m a -> WriterT w m (a, b) +listens f m = WriterT $ do + (a, w) <- runWriterT m + return ((a, f w), w) + +-- | @'pass' m@ is an action that executes the action @m@, which returns +-- a value and a function, and returns the value, applying the function +-- to the output. +-- +-- * @'runWriterT' ('pass' m) = 'liftM' (\\((a, f), w) -> (a, f w)) ('runWriterT' m)@ +pass :: (Monoid w, Monad m) => WriterT w m (a, w -> w) -> WriterT w m a +pass m = WriterT $ do + ((a, f), w) <- runWriterT m + return (a, f w) + +-- | @'censor' f m@ is an action that executes the action @m@ and +-- applies the function @f@ to its output, leaving the return value +-- unchanged. +-- +-- * @'censor' f m = 'pass' ('liftM' (\\x -> (x,f)) m)@ +-- +-- * @'runWriterT' ('censor' f m) = 'liftM' (\\(a, w) -> (a, f w)) ('runWriterT' m)@ +censor :: (Monoid w, Monad m) => (w -> w) -> WriterT w m a -> WriterT w m a +censor f m = WriterT $ do + (a, w) <- runWriterT m + return (a, f w) + +-- | Lift a @callCC@ operation to the new monad. +liftCallCC :: (Monoid w) => ((((a,w) -> m (b,w)) -> m (a,w)) -> m (a,w)) -> + ((a -> WriterT w m b) -> WriterT w m a) -> WriterT w m a +liftCallCC callCC f = WriterT $ + callCC $ \c -> + runWriterT (f (\a -> WriterT $ c (a, mempty))) + +-- | Lift a @catchError@ operation to the new monad. +liftCatch :: (m (a,w) -> (e -> m (a,w)) -> m (a,w)) -> + WriterT w m a -> (e -> WriterT w m a) -> WriterT w m a +liftCatch catchError m h = + WriterT $ runWriterT m `catchError` \e -> runWriterT (h e) diff --git a/Control/Monad/Writer.hs b/Control/Monad/Writer.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Writer.hs @@ -0,0 +1,24 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Writer +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (multi-param classes, functional dependencies) +-- +-- The MonadWriter class. +-- +-- Inspired by the paper +-- /Functional Programming with Overloading and Higher-Order Polymorphism/, +-- Mark P Jones () +-- Advanced School of Functional Programming, 1995. +----------------------------------------------------------------------------- + +module Control.Monad.Writer ( + module Control.Monad.Writer.Lazy + ) where + +import Control.Monad.Writer.Lazy diff --git a/Control/Monad/Writer/Class.hs b/Control/Monad/Writer/Class.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Writer/Class.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE UndecidableInstances #-} +-- Search for UndecidableInstances to see why this is needed + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Writer.Class +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (multi-param classes, functional dependencies) +-- +-- The MonadWriter class. +-- +-- Inspired by the paper +-- /Functional Programming with Overloading and Higher-Order Polymorphism/, +-- Mark P Jones () +-- Advanced School of Functional Programming, 1995. +----------------------------------------------------------------------------- + +module Control.Monad.Writer.Class ( + MonadWriter(..), + listens, + censor, + ) where + +import Control.Monad.Trans.Error as Error +import Control.Monad.Trans.Identity as Identity +import Control.Monad.Trans.Maybe as Maybe +import Control.Monad.Trans.Reader +import qualified Control.Monad.Trans.RWS.Lazy as LazyRWS ( + RWST, writer, tell, listen, pass) +import qualified Control.Monad.Trans.RWS.Strict as StrictRWS ( + RWST, writer, tell, listen, pass) +import Control.Monad.Trans.State.Lazy as Lazy +import Control.Monad.Trans.State.Strict as Strict +import qualified Control.Monad.Trans.Writer.Lazy as Lazy ( + WriterT, writer, tell, listen, pass) +import qualified Control.Monad.Trans.Writer.Strict as Strict ( + WriterT, writer, tell, listen, pass) + +import Control.Monad.Trans.Class (lift) +import Control.Monad +import Data.Monoid + +-- --------------------------------------------------------------------------- +-- MonadWriter class +-- +-- tell is like tell on the MUD's it shouts to monad +-- what you want to be heard. The monad carries this 'packet' +-- upwards, merging it if needed (hence the Monoid requirement). +-- +-- listen listens to a monad acting, and returns what the monad "said". +-- +-- pass lets you provide a writer transformer which changes internals of +-- the written object. + +class (Monoid w, Monad m) => MonadWriter w m | m -> w where + -- | @'writer' (a,w)@ embeds a simple writer action. + writer :: (a,w) -> m a + writer ~(a, w) = do + tell w + return a + + -- | @'tell' w@ is an action that produces the output @w@. + tell :: w -> m () + tell w = writer ((),w) + + -- | @'listen' m@ is an action that executes the action @m@ and adds + -- its output to the value of the computation. + listen :: m a -> m (a, w) + -- | @'pass' m@ is an action that executes the action @m@, which + -- returns a value and a function, and returns the value, applying + -- the function to the output. + pass :: m (a, w -> w) -> m a + +-- | @'listens' f m@ is an action that executes the action @m@ and adds +-- the result of applying @f@ to the output to the value of the computation. +-- +-- * @'listens' f m = 'liftM' (id *** f) ('listen' m)@ +listens :: MonadWriter w m => (w -> b) -> m a -> m (a, b) +listens f m = do + ~(a, w) <- listen m + return (a, f w) + +-- | @'censor' f m@ is an action that executes the action @m@ and +-- applies the function @f@ to its output, leaving the return value +-- unchanged. +-- +-- * @'censor' f m = 'pass' ('liftM' (\\x -> (x,f)) m)@ +censor :: MonadWriter w m => (w -> w) -> m a -> m a +censor f m = pass $ do + a <- m + return (a, f) + +instance (Monoid w, Monad m) => MonadWriter w (Lazy.WriterT w m) where + writer = Lazy.writer + tell = Lazy.tell + listen = Lazy.listen + pass = Lazy.pass + +instance (Monoid w, Monad m) => MonadWriter w (Strict.WriterT w m) where + writer = Strict.writer + tell = Strict.tell + listen = Strict.listen + pass = Strict.pass + +instance (Monoid w, Monad m) => MonadWriter w (LazyRWS.RWST r w s m) where + writer = LazyRWS.writer + tell = LazyRWS.tell + listen = LazyRWS.listen + pass = LazyRWS.pass + +instance (Monoid w, Monad m) => MonadWriter w (StrictRWS.RWST r w s m) where + writer = StrictRWS.writer + tell = StrictRWS.tell + listen = StrictRWS.listen + pass = StrictRWS.pass + +-- --------------------------------------------------------------------------- +-- Instances for other mtl transformers +-- +-- All of these instances need UndecidableInstances, +-- because they do not satisfy the coverage condition. + +instance (Error e, MonadWriter w m) => MonadWriter w (ErrorT e m) where + writer = lift . writer + tell = lift . tell + listen = Error.liftListen listen + pass = Error.liftPass pass + +instance MonadWriter w m => MonadWriter w (IdentityT m) where + writer = lift . writer + tell = lift . tell + listen = Identity.mapIdentityT listen + pass = Identity.mapIdentityT pass + +instance MonadWriter w m => MonadWriter w (MaybeT m) where + writer = lift . writer + tell = lift . tell + listen = Maybe.liftListen listen + pass = Maybe.liftPass pass + +instance MonadWriter w m => MonadWriter w (ReaderT r m) where + writer = lift . writer + tell = lift . tell + listen = mapReaderT listen + pass = mapReaderT pass + +instance MonadWriter w m => MonadWriter w (Lazy.StateT s m) where + writer = lift . writer + tell = lift . tell + listen = Lazy.liftListen listen + pass = Lazy.liftPass pass + +instance MonadWriter w m => MonadWriter w (Strict.StateT s m) where + writer = lift . writer + tell = lift . tell + listen = Strict.liftListen listen + pass = Strict.liftPass pass diff --git a/Control/Monad/Writer/Lazy.hs b/Control/Monad/Writer/Lazy.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Writer/Lazy.hs @@ -0,0 +1,49 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Writer.Lazy +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (multi-param classes, functional dependencies) +-- +-- Lazy writer monads. +-- +-- Inspired by the paper +-- /Functional Programming with Overloading and Higher-Order Polymorphism/, +-- Mark P Jones () +-- Advanced School of Functional Programming, 1995. +----------------------------------------------------------------------------- + +module Control.Monad.Writer.Lazy ( + -- * MonadWriter class + MonadWriter(..), + listens, + censor, + -- * The Writer monad + Writer, + runWriter, + execWriter, + mapWriter, + -- * The WriterT monad transformer + WriterT(..), + execWriterT, + mapWriterT, + module Control.Monad, + module Control.Monad.Fix, + module Control.Monad.Trans, + module Data.Monoid, + ) where + +import Control.Monad.Writer.Class + +import Control.Monad.Trans +import Control.Monad.Trans.Writer.Lazy ( + Writer, runWriter, execWriter, mapWriter, + WriterT(..), execWriterT, mapWriterT) + +import Control.Monad +import Control.Monad.Fix +import Data.Monoid diff --git a/Control/Monad/Writer/Strict.hs b/Control/Monad/Writer/Strict.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Writer/Strict.hs @@ -0,0 +1,49 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Writer.Strict +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (multi-param classes, functional dependencies) +-- +-- Strict writer monads. +-- +-- Inspired by the paper +-- /Functional Programming with Overloading and Higher-Order Polymorphism/, +-- Mark P Jones () +-- Advanced School of Functional Programming, 1995. +----------------------------------------------------------------------------- + +module Control.Monad.Writer.Strict ( + -- * MonadWriter class + MonadWriter(..), + listens, + censor, + -- * The Writer monad + Writer, + runWriter, + execWriter, + mapWriter, + -- * The WriterT monad transformer + WriterT(..), + execWriterT, + mapWriterT, + module Control.Monad, + module Control.Monad.Fix, + module Control.Monad.Trans, + module Data.Monoid, + ) where + +import Control.Monad.Writer.Class + +import Control.Monad.Trans +import Control.Monad.Trans.Writer.Strict ( + Writer, runWriter, execWriter, mapWriter, + WriterT(..), execWriterT, mapWriterT) + +import Control.Monad +import Control.Monad.Fix +import Data.Monoid diff --git a/Data/Functor/Compose.hs b/Data/Functor/Compose.hs new file mode 100644 --- /dev/null +++ b/Data/Functor/Compose.hs @@ -0,0 +1,40 @@ +-- | +-- Module : Data.Functor.Compose +-- Copyright : (c) Ross Paterson 2010 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : ross@soi.city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- Composition of functors. + +module Data.Functor.Compose ( + Compose(..), + ) where + +import Control.Applicative +import Data.Foldable (Foldable(foldMap)) +import Data.Traversable (Traversable(traverse)) + +-- | Right-to-left composition of functors. +-- The composition of applicative functors is always applicative, +-- but the composition of monads is not always a monad. +newtype Compose f g a = Compose { getCompose :: f (g a) } + +instance (Functor f, Functor g) => Functor (Compose f g) where + fmap f (Compose x) = Compose (fmap (fmap f) x) + +instance (Foldable f, Foldable g) => Foldable (Compose f g) where + foldMap f (Compose t) = foldMap (foldMap f) t + +instance (Traversable f, Traversable g) => Traversable (Compose f g) where + traverse f (Compose t) = Compose <$> traverse (traverse f) t + +instance (Applicative f, Applicative g) => Applicative (Compose f g) where + pure x = Compose (pure (pure x)) + Compose f <*> Compose x = Compose ((<*>) <$> f <*> x) + +instance (Alternative f, Applicative g) => Alternative (Compose f g) where + empty = Compose empty + Compose x <|> Compose y = Compose (x <|> y) diff --git a/Data/Functor/Constant.hs b/Data/Functor/Constant.hs new file mode 100644 --- /dev/null +++ b/Data/Functor/Constant.hs @@ -0,0 +1,35 @@ +-- | +-- Module : Data.Functor.Constant +-- Copyright : (c) Ross Paterson 2010 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : ross@soi.city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- The constant functor. + +module Data.Functor.Constant ( + Constant(..), + ) where + +import Control.Applicative +import Data.Foldable (Foldable(foldMap)) +import Data.Monoid (Monoid(..)) +import Data.Traversable (Traversable(traverse)) + +-- | Constant functor. +newtype Constant a b = Constant { getConstant :: a } + +instance Functor (Constant a) where + fmap f (Constant x) = Constant x + +instance Foldable (Constant a) where + foldMap f (Constant x) = mempty + +instance Traversable (Constant a) where + traverse f (Constant x) = pure (Constant x) + +instance (Monoid a) => Applicative (Constant a) where + pure _ = Constant mempty + Constant x <*> Constant y = Constant (x `mappend` y) diff --git a/Data/Functor/Identity.hs b/Data/Functor/Identity.hs new file mode 100644 --- /dev/null +++ b/Data/Functor/Identity.hs @@ -0,0 +1,57 @@ +-- | +-- Module : Data.Functor.Identity +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : ross@soi.city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- The identity functor and monad. +-- +-- This trivial type constructor serves two purposes: +-- +-- * It can be used with functions parameterized by functor or monad classes. +-- +-- * It can be used as a base monad to which a series of monad +-- transformers may be applied to construct a composite monad. +-- Most monad transformer modules include the special case of +-- applying the transformer to 'Identity'. For example, @State s@ +-- is an abbreviation for @StateT s 'Identity'@. + +module Data.Functor.Identity ( + Identity(..), + ) where + +import Control.Applicative +import Control.Monad +import Control.Monad.Fix +import Data.Foldable (Foldable(foldMap)) +import Data.Traversable (Traversable(traverse)) + +-- | Identity functor and monad. +newtype Identity a = Identity { runIdentity :: a } + +-- --------------------------------------------------------------------------- +-- Identity instances for Functor and Monad + +instance Functor Identity where + fmap f m = Identity (f (runIdentity m)) + +instance Foldable Identity where + foldMap f (Identity x) = f x + +instance Traversable Identity where + traverse f (Identity x) = Identity <$> f x + +instance Applicative Identity where + pure a = Identity a + Identity f <*> Identity x = Identity (f x) + +instance Monad Identity where + return a = Identity a + m >>= k = k (runIdentity m) + +instance MonadFix Identity where + mfix f = Identity (fix (runIdentity . f)) diff --git a/Data/Functor/Product.hs b/Data/Functor/Product.hs new file mode 100644 --- /dev/null +++ b/Data/Functor/Product.hs @@ -0,0 +1,58 @@ +-- | +-- Module : Data.Functor.Product +-- Copyright : (c) Ross Paterson 2010 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : ross@soi.city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- Products, lifted to functors. + +module Data.Functor.Product ( + Product(..), + ) where + +import Control.Applicative +import Control.Monad (MonadPlus(..)) +import Control.Monad.Fix (MonadFix(..)) +import Data.Foldable (Foldable(foldMap)) +import Data.Monoid (mappend) +import Data.Traversable (Traversable(traverse)) + +-- | Lifted product of functors. +data Product f g a = Pair (f a) (g a) + +instance (Functor f, Functor g) => Functor (Product f g) where + fmap f (Pair x y) = Pair (fmap f x) (fmap f y) + +instance (Foldable f, Foldable g) => Foldable (Product f g) where + foldMap f (Pair x y) = foldMap f x `mappend` foldMap f y + +instance (Traversable f, Traversable g) => Traversable (Product f g) where + traverse f (Pair x y) = Pair <$> traverse f x <*> traverse f y + +instance (Applicative f, Applicative g) => Applicative (Product f g) where + pure x = Pair (pure x) (pure x) + Pair f g <*> Pair x y = Pair (f <*> x) (g <*> y) + +instance (Alternative f, Alternative g) => Alternative (Product f g) where + empty = Pair empty empty + Pair x1 y1 <|> Pair x2 y2 = Pair (x1 <|> x2) (y1 <|> y2) + +instance (Monad f, Monad g) => Monad (Product f g) where + return x = Pair (return x) (return x) + Pair m n >>= f = Pair (m >>= fstP . f) (n >>= sndP . f) + where + fstP (Pair a _) = a + sndP (Pair _ b) = b + +instance (MonadPlus f, MonadPlus g) => MonadPlus (Product f g) where + mzero = Pair mzero mzero + Pair x1 y1 `mplus` Pair x2 y2 = Pair (x1 `mplus` x2) (y1 `mplus` y2) + +instance (MonadFix f, MonadFix g) => MonadFix (Product f g) where + mfix f = Pair (mfix (fstP . f)) (mfix (sndP . f)) + where + fstP (Pair a _) = a + sndP (Pair _ b) = b diff --git a/Data/Functor/Reverse.hs b/Data/Functor/Reverse.hs new file mode 100644 --- /dev/null +++ b/Data/Functor/Reverse.hs @@ -0,0 +1,54 @@ +-- | +-- Module : Data.Functor.Reverse +-- Copyright : (c) Russell O'Connor 2009 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Making functors whose elements are notionally in the reverse order +-- from the original functor. + +module Data.Functor.Reverse where + +import Control.Applicative.Backwards + +import Prelude hiding (foldr, foldr1, foldl, foldl1) +import Control.Applicative +import Data.Foldable +import Data.Traversable +import Data.Monoid + +-- | The same functor, but with 'Foldable' and 'Traversable' instances +-- that process the elements in the reverse order. +newtype Reverse f a = Reverse { getReverse :: f a } + +-- | Derived instance. +instance (Functor f) => Functor (Reverse f) where + fmap f (Reverse a) = Reverse (fmap f a) + +-- | Derived instance. +instance (Applicative f) => Applicative (Reverse f) where + pure a = Reverse (pure a) + Reverse f <*> Reverse a = Reverse (f <*> a) + +-- | Derived instance. +instance (Alternative f) => Alternative (Reverse f) where + empty = Reverse empty + Reverse x <|> Reverse y = Reverse (x <|> y) + +-- | Fold from right to left. +instance (Foldable f) => Foldable (Reverse f) where + foldMap f (Reverse t) = getDual (foldMap (Dual . f) t) + foldr f z (Reverse t) = foldl (flip f) z t + foldl f z (Reverse t) = foldr (flip f) z t + foldr1 f (Reverse t) = foldl1 (flip f) t + foldl1 f (Reverse t) = foldr1 (flip f) t + +-- | Traverse from right to left. +instance (Traversable f) => Traversable (Reverse f) where + traverse f (Reverse t) = + fmap Reverse . forwards $ traverse (Backwards . f) t + sequenceA (Reverse t) = + fmap Reverse . forwards $ sequenceA (fmap Backwards t) diff --git a/Distribution/Client/BuildReports/Anonymous.hs b/Distribution/Client/BuildReports/Anonymous.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/BuildReports/Anonymous.hs @@ -0,0 +1,311 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Reporting +-- Copyright : (c) David Waern 2008 +-- License : BSD-like +-- +-- Maintainer : david.waern@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Anonymous build report data structure, printing and parsing +-- +----------------------------------------------------------------------------- +module Distribution.Client.BuildReports.Anonymous ( + BuildReport(..), + InstallOutcome(..), + Outcome(..), + + -- * Constructing and writing reports + new, + + -- * parsing and pretty printing + parse, + parseList, + show, +-- showList, + ) where + +import Distribution.Client.Types + ( ConfiguredPackage(..) ) +import qualified Distribution.Client.Types as BR + ( BuildResult, BuildFailure(..), BuildSuccess(..) + , DocsResult(..), TestsResult(..) ) +import Distribution.Client.Utils + ( mergeBy, MergeResult(..) ) +import qualified Paths_cabal_install_bundle (version) + +import Distribution.Package + ( PackageIdentifier(..), PackageName(..), Package(packageId) ) +import Distribution.PackageDescription + ( FlagName(..), FlagAssignment ) +--import Distribution.Version +-- ( Version ) +import Distribution.System + ( OS, Arch ) +import Distribution.Compiler + ( CompilerId ) +import qualified Distribution.Text as Text + ( Text(disp, parse) ) +import Distribution.ParseUtils + ( FieldDescr(..), ParseResult(..), Field(..) + , simpleField, listField, ppFields, readFields + , syntaxError, locatedErrorMsg ) +import Distribution.Simple.Utils + ( comparing ) + +import qualified Distribution.Compat.ReadP as Parse + ( ReadP, pfail, munch1, skipSpaces ) +import qualified Text.PrettyPrint.HughesPJ as Disp + ( Doc, render, char, text ) +import Text.PrettyPrint.HughesPJ + ( (<+>), (<>) ) + +import Data.List + ( unfoldr, sortBy ) +import Data.Char as Char + ( isAlpha, isAlphaNum ) + +import Prelude hiding (show) + +data BuildReport + = BuildReport { + -- | The package this build report is about + package :: PackageIdentifier, + + -- | The OS and Arch the package was built on + os :: OS, + arch :: Arch, + + -- | The Haskell compiler (and hopefully version) used + compiler :: CompilerId, + + -- | The uploading client, ie cabal-install-x.y.z + client :: PackageIdentifier, + + -- | Which configurations flags we used + flagAssignment :: FlagAssignment, + + -- | Which dependent packages we were using exactly + dependencies :: [PackageIdentifier], + + -- | Did installing work ok? + installOutcome :: InstallOutcome, + + -- Which version of the Cabal library was used to compile the Setup.hs +-- cabalVersion :: Version, + + -- Which build tools we were using (with versions) +-- tools :: [PackageIdentifier], + + -- | Configure outcome, did configure work ok? + docsOutcome :: Outcome, + + -- | Configure outcome, did configure work ok? + testsOutcome :: Outcome + } + +data InstallOutcome + = DependencyFailed PackageIdentifier + | DownloadFailed + | UnpackFailed + | SetupFailed + | ConfigureFailed + | BuildFailed + | InstallFailed + | InstallOk + deriving Eq + +data Outcome = NotTried | Failed | Ok + deriving Eq + +new :: OS -> Arch -> CompilerId -- -> Version + -> ConfiguredPackage -> BR.BuildResult + -> BuildReport +new os' arch' comp (ConfiguredPackage pkg flags deps) result = + BuildReport { + package = packageId pkg, + os = os', + arch = arch', + compiler = comp, + client = cabalInstallID, + flagAssignment = flags, + dependencies = deps, + installOutcome = convertInstallOutcome, +-- cabalVersion = undefined + docsOutcome = convertDocsOutcome, + testsOutcome = convertTestsOutcome + } + where + convertInstallOutcome = case result of + Left (BR.DependentFailed p) -> DependencyFailed p + Left (BR.DownloadFailed _) -> DownloadFailed + Left (BR.UnpackFailed _) -> UnpackFailed + Left (BR.ConfigureFailed _) -> ConfigureFailed + Left (BR.BuildFailed _) -> BuildFailed + Left (BR.InstallFailed _) -> InstallFailed + Right (BR.BuildOk _ _) -> InstallOk + convertDocsOutcome = case result of + Left _ -> NotTried + Right (BR.BuildOk BR.DocsNotTried _) -> NotTried + Right (BR.BuildOk BR.DocsFailed _) -> Failed + Right (BR.BuildOk BR.DocsOk _) -> Ok + convertTestsOutcome = case result of + Left _ -> NotTried + Right (BR.BuildOk _ BR.TestsNotTried) -> NotTried + Right (BR.BuildOk _ BR.TestsFailed) -> Failed + Right (BR.BuildOk _ BR.TestsOk) -> Ok + +cabalInstallID :: PackageIdentifier +cabalInstallID = + PackageIdentifier (PackageName "cabal-install") Paths_cabal_install_bundle.version + +-- ------------------------------------------------------------ +-- * External format +-- ------------------------------------------------------------ + +initialBuildReport :: BuildReport +initialBuildReport = BuildReport { + package = requiredField "package", + os = requiredField "os", + arch = requiredField "arch", + compiler = requiredField "compiler", + client = requiredField "client", + flagAssignment = [], + dependencies = [], + installOutcome = requiredField "install-outcome", +-- cabalVersion = Nothing, +-- tools = [], + docsOutcome = NotTried, + testsOutcome = NotTried + } + where + requiredField fname = error ("required field: " ++ fname) + +-- ----------------------------------------------------------------------------- +-- Parsing + +parse :: String -> Either String BuildReport +parse s = case parseFields s of + ParseFailed perror -> Left msg where (_, msg) = locatedErrorMsg perror + ParseOk _ report -> Right report + +--FIXME: this does not allow for optional or repeated fields +parseFields :: String -> ParseResult BuildReport +parseFields input = do + fields <- mapM extractField =<< readFields input + let merged = mergeBy (\desc (_,name,_) -> compare (fieldName desc) name) + sortedFieldDescrs + (sortBy (comparing (\(_,name,_) -> name)) fields) + checkMerged initialBuildReport merged + + where + extractField :: Field -> ParseResult (Int, String, String) + extractField (F line name value) = return (line, name, value) + extractField (Section line _ _ _) = syntaxError line "Unrecognized stanza" + extractField (IfBlock line _ _ _) = syntaxError line "Unrecognized stanza" + + checkMerged report [] = return report + checkMerged report (merged:remaining) = case merged of + InBoth fieldDescr (line, _name, value) -> do + report' <- fieldSet fieldDescr line value report + checkMerged report' remaining + OnlyInRight (line, name, _) -> + syntaxError line ("Unrecognized field " ++ name) + OnlyInLeft fieldDescr -> + fail ("Missing field " ++ fieldName fieldDescr) + +parseList :: String -> [BuildReport] +parseList str = + [ report | Right report <- map parse (split str) ] + + where + split :: String -> [String] + split = filter (not . null) . unfoldr chunk . lines + chunk [] = Nothing + chunk ls = case break null ls of + (r, rs) -> Just (unlines r, dropWhile null rs) + +-- ----------------------------------------------------------------------------- +-- Pretty-printing + +show :: BuildReport -> String +show = Disp.render . ppFields fieldDescrs + +-- ----------------------------------------------------------------------------- +-- Description of the fields, for parsing/printing + +fieldDescrs :: [FieldDescr BuildReport] +fieldDescrs = + [ simpleField "package" Text.disp Text.parse + package (\v r -> r { package = v }) + , simpleField "os" Text.disp Text.parse + os (\v r -> r { os = v }) + , simpleField "arch" Text.disp Text.parse + arch (\v r -> r { arch = v }) + , simpleField "compiler" Text.disp Text.parse + compiler (\v r -> r { compiler = v }) + , simpleField "client" Text.disp Text.parse + client (\v r -> r { client = v }) + , listField "flags" dispFlag parseFlag + flagAssignment (\v r -> r { flagAssignment = v }) + , listField "dependencies" Text.disp Text.parse + dependencies (\v r -> r { dependencies = v }) + , simpleField "install-outcome" Text.disp Text.parse + installOutcome (\v r -> r { installOutcome = v }) + , simpleField "docs-outcome" Text.disp Text.parse + docsOutcome (\v r -> r { docsOutcome = v }) + , simpleField "tests-outcome" Text.disp Text.parse + testsOutcome (\v r -> r { testsOutcome = v }) + ] + +sortedFieldDescrs :: [FieldDescr BuildReport] +sortedFieldDescrs = sortBy (comparing fieldName) fieldDescrs + +dispFlag :: (FlagName, Bool) -> Disp.Doc +dispFlag (FlagName name, True) = Disp.text name +dispFlag (FlagName name, False) = Disp.char '-' <> Disp.text name + +parseFlag :: Parse.ReadP r (FlagName, Bool) +parseFlag = do + name <- Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-') + case name of + ('-':flag) -> return (FlagName flag, False) + flag -> return (FlagName flag, True) + +instance Text.Text InstallOutcome where + disp (DependencyFailed pkgid) = Disp.text "DependencyFailed" <+> Text.disp pkgid + disp DownloadFailed = Disp.text "DownloadFailed" + disp UnpackFailed = Disp.text "UnpackFailed" + disp SetupFailed = Disp.text "SetupFailed" + disp ConfigureFailed = Disp.text "ConfigureFailed" + disp BuildFailed = Disp.text "BuildFailed" + disp InstallFailed = Disp.text "InstallFailed" + disp InstallOk = Disp.text "InstallOk" + + parse = do + name <- Parse.munch1 Char.isAlphaNum + case name of + "DependencyFailed" -> do Parse.skipSpaces + pkgid <- Text.parse + return (DependencyFailed pkgid) + "DownloadFailed" -> return DownloadFailed + "UnpackFailed" -> return UnpackFailed + "SetupFailed" -> return SetupFailed + "ConfigureFailed" -> return ConfigureFailed + "BuildFailed" -> return BuildFailed + "InstallFailed" -> return InstallFailed + "InstallOk" -> return InstallOk + _ -> Parse.pfail + +instance Text.Text Outcome where + disp NotTried = Disp.text "NotTried" + disp Failed = Disp.text "Failed" + disp Ok = Disp.text "Ok" + parse = do + name <- Parse.munch1 Char.isAlpha + case name of + "NotTried" -> return NotTried + "Failed" -> return Failed + "Ok" -> return Ok + _ -> Parse.pfail diff --git a/Distribution/Client/BuildReports/Storage.hs b/Distribution/Client/BuildReports/Storage.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/BuildReports/Storage.hs @@ -0,0 +1,127 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Reporting +-- Copyright : (c) David Waern 2008 +-- License : BSD-like +-- +-- Maintainer : david.waern@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Anonymous build report data structure, printing and parsing +-- +----------------------------------------------------------------------------- +module Distribution.Client.BuildReports.Storage ( + + -- * Storing and retrieving build reports + storeAnonymous, + storeLocal, +-- retrieve, + + -- * 'InstallPlan' support + fromInstallPlan, + ) where + +import qualified Distribution.Client.BuildReports.Anonymous as BuildReport +import Distribution.Client.BuildReports.Anonymous (BuildReport) + +import Distribution.Client.Types +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.InstallPlan + ( InstallPlan ) + +import Distribution.Simple.InstallDirs + ( PathTemplate, fromPathTemplate + , initialPathTemplateEnv, substPathTemplate ) +import Distribution.System + ( Platform(Platform) ) +import Distribution.Compiler + ( CompilerId ) +import Distribution.Simple.Utils + ( comparing, equating ) + +import Data.List + ( groupBy, sortBy ) +import Data.Maybe + ( catMaybes ) +import System.FilePath + ( (), takeDirectory ) +import System.Directory + ( createDirectoryIfMissing ) + +storeAnonymous :: [(BuildReport, Repo)] -> IO () +storeAnonymous reports = sequence_ + [ appendFile file (concatMap format reports') + | (repo, reports') <- separate reports + , let file = repoLocalDir repo "build-reports.log" ] + --TODO: make this concurrency safe, either lock the report file or make sure + -- the writes for each report are atomic (under 4k and flush at boundaries) + + where + format r = '\n' : BuildReport.show r ++ "\n" + separate :: [(BuildReport, Repo)] + -> [(Repo, [BuildReport])] + separate = map (\rs@((_,repo,_):_) -> (repo, [ r | (r,_,_) <- rs ])) + . map concat + . groupBy (equating (repoName . head)) + . sortBy (comparing (repoName . head)) + . groupBy (equating repoName) + . onlyRemote + repoName (_,_,rrepo) = remoteRepoName rrepo + + onlyRemote :: [(BuildReport, Repo)] -> [(BuildReport, Repo, RemoteRepo)] + onlyRemote rs = + [ (report, repo, remoteRepo) + | (report, repo@Repo { repoKind = Left remoteRepo }) <- rs ] + +storeLocal :: [PathTemplate] -> [(BuildReport, Repo)] -> IO () +storeLocal templates reports = sequence_ + [ do createDirectoryIfMissing True (takeDirectory file) + appendFile file output + --TODO: make this concurrency safe, either lock the report file or make + -- sure the writes for each report are atomic + | (file, reports') <- groupByFileName + [ (reportFileName template report, report) + | template <- templates + , (report, _repo) <- reports ] + , let output = concatMap format reports' + ] + where + format r = '\n' : BuildReport.show r ++ "\n" + + reportFileName template report = + fromPathTemplate (substPathTemplate env template) + where env = initialPathTemplateEnv + (BuildReport.package report) + (BuildReport.compiler report) + + groupByFileName = map (\grp@((filename,_):_) -> (filename, map snd grp)) + . groupBy (equating fst) + . sortBy (comparing fst) + +-- ------------------------------------------------------------ +-- * InstallPlan support +-- ------------------------------------------------------------ + +fromInstallPlan :: InstallPlan -> [(BuildReport, Repo)] +fromInstallPlan plan = catMaybes + . map (fromPlanPackage platform comp) + . InstallPlan.toList + $ plan + where platform = InstallPlan.planPlatform plan + comp = InstallPlan.planCompiler plan + +fromPlanPackage :: Platform -> CompilerId + -> InstallPlan.PlanPackage + -> Maybe (BuildReport, Repo) +fromPlanPackage (Platform arch os) comp planPackage = case planPackage of + + InstallPlan.Installed pkg@(ConfiguredPackage (AvailablePackage { + packageSource = RepoTarballPackage repo _ _ }) _ _) result + -> Just $ (BuildReport.new os arch comp pkg (Right result), repo) + + InstallPlan.Failed pkg@(ConfiguredPackage (AvailablePackage { + packageSource = RepoTarballPackage repo _ _ }) _ _) result + -> Just $ (BuildReport.new os arch comp pkg (Left result), repo) + + _ -> Nothing diff --git a/Distribution/Client/BuildReports/Types.hs b/Distribution/Client/BuildReports/Types.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/BuildReports/Types.hs @@ -0,0 +1,44 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.BuildReports.Types +-- Copyright : (c) Duncan Coutts 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Types related to build reporting +-- +----------------------------------------------------------------------------- +module Distribution.Client.BuildReports.Types ( + ReportLevel(..), + ) where + +import qualified Distribution.Text as Text + ( Text(..) ) + +import qualified Distribution.Compat.ReadP as Parse + ( pfail, munch1 ) +import qualified Text.PrettyPrint.HughesPJ as Disp + ( text ) + +import Data.Char as Char + ( isAlpha, toLower ) + +data ReportLevel = NoReports | AnonymousReports | DetailedReports + deriving (Eq, Ord, Show) + +instance Text.Text ReportLevel where + disp NoReports = Disp.text "none" + disp AnonymousReports = Disp.text "anonymous" + disp DetailedReports = Disp.text "detailed" + parse = do + name <- Parse.munch1 Char.isAlpha + case lowercase name of + "none" -> return NoReports + "anonymous" -> return AnonymousReports + "detailed" -> return DetailedReports + _ -> Parse.pfail + +lowercase :: String -> String +lowercase = map Char.toLower diff --git a/Distribution/Client/BuildReports/Upload.hs b/Distribution/Client/BuildReports/Upload.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/BuildReports/Upload.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE PatternGuards #-} +-- This is a quick hack for uploading build reports to Hackage. + +module Distribution.Client.BuildReports.Upload + ( BuildLog + , BuildReportId + , uploadReports + , postBuildReport + , putBuildLog + ) where + +import Network.Browser + ( BrowserAction, request, setAllowRedirects ) +import Network.HTTP + ( Header(..), HeaderName(..) + , Request(..), RequestMethod(..), Response(..) ) +import Network.TCP (HandleStream) +import Network.URI (URI, uriPath, parseRelativeReference, relativeTo) + +import Control.Monad + ( forM_ ) +import System.FilePath.Posix + ( () ) +import qualified Distribution.Client.BuildReports.Anonymous as BuildReport +import Distribution.Client.BuildReports.Anonymous (BuildReport) +import Distribution.Text (display) + +type BuildReportId = URI +type BuildLog = String + +uploadReports :: URI -> [(BuildReport, Maybe BuildLog)] + -> BrowserAction (HandleStream String) () + -> BrowserAction (HandleStream BuildLog) () +uploadReports uri reports auth = do + auth + forM_ reports $ \(report, mbBuildLog) -> do + buildId <- postBuildReport uri report + case mbBuildLog of + Just buildLog -> putBuildLog buildId buildLog + Nothing -> return () + +postBuildReport :: URI -> BuildReport + -> BrowserAction (HandleStream BuildLog) BuildReportId +postBuildReport uri buildReport = do + setAllowRedirects False + (_, response) <- request Request { + rqURI = uri { uriPath = "/package" display (BuildReport.package buildReport) "reports" }, + rqMethod = POST, + rqHeaders = [Header HdrContentType ("text/plain"), + Header HdrContentLength (show (length body)), + Header HdrAccept ("text/plain")], + rqBody = body + } + case rspCode response of + (3,0,3) | [Just buildId] <- [ do rel <- parseRelativeReference location + relativeTo rel uri + | Header HdrLocation location <- rspHeaders response ] + -> return $ buildId + _ -> error "Unrecognised response from server." + where body = BuildReport.show buildReport + +putBuildLog :: BuildReportId -> BuildLog + -> BrowserAction (HandleStream BuildLog) () +putBuildLog reportId buildLog = do + --FIXME: do something if the request fails + (_, response) <- request Request { + rqURI = reportId{uriPath = uriPath reportId "log"}, + rqMethod = PUT, + rqHeaders = [Header HdrContentType ("text/plain"), + Header HdrContentLength (show (length buildLog)), + Header HdrAccept ("text/plain")], + rqBody = buildLog + } + return () diff --git a/Distribution/Client/Check.hs b/Distribution/Client/Check.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Check.hs @@ -0,0 +1,85 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Check +-- Copyright : (c) Lennart Kolmodin 2008 +-- License : BSD-like +-- +-- Maintainer : kolmodin@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Check a package for common mistakes +-- +----------------------------------------------------------------------------- +module Distribution.Client.Check ( + check + ) where + +import Control.Monad ( when, unless ) + +import Distribution.PackageDescription.Parse + ( readPackageDescription ) +import Distribution.PackageDescription.Check +import Distribution.PackageDescription.Configuration + ( flattenPackageDescription ) +import Distribution.Verbosity + ( Verbosity ) +import Distribution.Simple.Utils + ( defaultPackageDesc, toUTF8, wrapText ) + +check :: Verbosity -> IO Bool +check verbosity = do + pdfile <- defaultPackageDesc verbosity + ppd <- readPackageDescription verbosity pdfile + -- flatten the generic package description into a regular package + -- description + -- TODO: this may give more warnings than it should give; + -- consider two branches of a condition, one saying + -- ghc-options: -Wall + -- and the other + -- ghc-options: -Werror + -- joined into + -- ghc-options: -Wall -Werror + -- checkPackages will yield a warning on the last line, but it + -- would not on each individual branch. + -- Hovever, this is the same way hackage does it, so we will yield + -- the exact same errors as it will. + let pkg_desc = flattenPackageDescription ppd + ioChecks <- checkPackageFiles pkg_desc "." + let packageChecks = ioChecks ++ checkPackage ppd (Just pkg_desc) + buildImpossible = [ x | x@PackageBuildImpossible {} <- packageChecks ] + buildWarning = [ x | x@PackageBuildWarning {} <- packageChecks ] + distSuspicious = [ x | x@PackageDistSuspicious {} <- packageChecks ] + distInexusable = [ x | x@PackageDistInexcusable {} <- packageChecks ] + + unless (null buildImpossible) $ do + putStrLn "The package will not build sanely due to these errors:" + printCheckMessages buildImpossible + + unless (null buildWarning) $ do + putStrLn "The following warnings are likely affect your build negatively:" + printCheckMessages buildWarning + + unless (null distSuspicious) $ do + putStrLn "These warnings may cause trouble when distributing the package:" + printCheckMessages distSuspicious + + unless (null distInexusable) $ do + putStrLn "The following errors will cause portability problems on other environments:" + printCheckMessages distInexusable + + let isDistError (PackageDistSuspicious {}) = False + isDistError _ = True + errors = filter isDistError packageChecks + + unless (null errors) $ do + putStrLn "Hackage would reject this package." + + when (null packageChecks) $ do + putStrLn "No errors or warnings could be found in the package." + + return (null packageChecks) + + where + printCheckMessages = mapM_ (putStrLn . format . explanation) + format = toUTF8 . wrapText . ("* "++) diff --git a/Distribution/Client/Config.hs b/Distribution/Client/Config.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Config.hs @@ -0,0 +1,532 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Config +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Utilities for handling saved state such as known packages, known servers and downloaded packages. +----------------------------------------------------------------------------- +module Distribution.Client.Config ( + SavedConfig(..), + loadConfig, + + showConfig, + showConfigWithComments, + parseConfig, + + defaultCabalDir, + defaultConfigFile, + defaultCacheDir, + defaultLogsDir, + ) where + + +import Distribution.Client.Types + ( RemoteRepo(..), Username(..), Password(..) ) +import Distribution.Client.BuildReports.Types + ( ReportLevel(..) ) +import Distribution.Client.Setup + ( GlobalFlags(..), globalCommand + , ConfigExFlags(..), configureExOptions, defaultConfigExFlags + , InstallFlags(..), installOptions, defaultInstallFlags + , UploadFlags(..), uploadCommand + , ReportFlags(..), reportCommand + , showRepo, parseRepo ) + +import Distribution.Simple.Setup + ( ConfigFlags(..), configureOptions, defaultConfigFlags + , installDirsOptions + , Flag, toFlag, flagToMaybe, fromFlagOrDefault ) +import Distribution.Simple.InstallDirs + ( InstallDirs(..), defaultInstallDirs + , PathTemplate, toPathTemplate ) +import Distribution.ParseUtils + ( FieldDescr(..), liftField + , ParseResult(..), locatedErrorMsg, showPWarning + , readFields, warning, lineNo + , simpleField, listField, parseFilePathQ, parseTokenQ ) +import qualified Distribution.ParseUtils as ParseUtils + ( Field(..) ) +import qualified Distribution.Text as Text + ( Text(..) ) +import Distribution.Simple.Command + ( CommandUI(commandOptions), commandDefaultFlags, ShowOrParseArgs(..) + , viewAsFieldDescr ) +import Distribution.Simple.Program + ( defaultProgramConfiguration ) +import Distribution.Simple.Utils + ( notice, warn, lowercase ) +import Distribution.Compiler + ( CompilerFlavor(..), defaultCompilerFlavor ) +import Distribution.Verbosity + ( Verbosity, normal ) + +import Data.List + ( partition, find ) +import Data.Maybe + ( fromMaybe ) +import Data.Monoid + ( Monoid(..) ) +import Control.Monad + ( when, foldM, liftM ) +import qualified Data.Map as Map +import qualified Distribution.Compat.ReadP as Parse + ( option ) +import qualified Text.PrettyPrint.HughesPJ as Disp + ( Doc, render, text, colon, vcat, empty, isEmpty, nest ) +import Text.PrettyPrint.HughesPJ + ( (<>), (<+>), ($$), ($+$) ) +import System.Directory + ( createDirectoryIfMissing, getAppUserDataDirectory ) +import Network.URI + ( URI(..), URIAuth(..) ) +import System.FilePath + ( (), takeDirectory ) +import System.Environment + ( getEnvironment ) +import System.IO.Error + ( isDoesNotExistError ) + +-- +-- * Configuration saved in the config file +-- + +data SavedConfig = SavedConfig { + savedGlobalFlags :: GlobalFlags, + savedInstallFlags :: InstallFlags, + savedConfigureFlags :: ConfigFlags, + savedConfigureExFlags :: ConfigExFlags, + savedUserInstallDirs :: InstallDirs (Flag PathTemplate), + savedGlobalInstallDirs :: InstallDirs (Flag PathTemplate), + savedUploadFlags :: UploadFlags, + savedReportFlags :: ReportFlags + } + +instance Monoid SavedConfig where + mempty = SavedConfig { + savedGlobalFlags = mempty, + savedInstallFlags = mempty, + savedConfigureFlags = mempty, + savedConfigureExFlags = mempty, + savedUserInstallDirs = mempty, + savedGlobalInstallDirs = mempty, + savedUploadFlags = mempty, + savedReportFlags = mempty + } + mappend a b = SavedConfig { + savedGlobalFlags = combine savedGlobalFlags, + savedInstallFlags = combine savedInstallFlags, + savedConfigureFlags = combine savedConfigureFlags, + savedConfigureExFlags = combine savedConfigureExFlags, + savedUserInstallDirs = combine savedUserInstallDirs, + savedGlobalInstallDirs = combine savedGlobalInstallDirs, + savedUploadFlags = combine savedUploadFlags, + savedReportFlags = combine savedReportFlags + } + where combine field = field a `mappend` field b + +updateInstallDirs :: Flag Bool -> SavedConfig -> SavedConfig +updateInstallDirs userInstallFlag + savedConfig@SavedConfig { + savedConfigureFlags = configureFlags, + savedUserInstallDirs = userInstallDirs, + savedGlobalInstallDirs = globalInstallDirs + } = + savedConfig { + savedConfigureFlags = configureFlags { + configInstallDirs = installDirs + } + } + where + installDirs | userInstall = userInstallDirs + | otherwise = globalInstallDirs + userInstall = fromFlagOrDefault defaultUserInstall $ + configUserInstall configureFlags `mappend` userInstallFlag + +-- +-- * Default config +-- + +-- | These are the absolute basic defaults. The fields that must be +-- initialised. When we load the config from the file we layer the loaded +-- values over these ones, so any missing fields in the file take their values +-- from here. +-- +baseSavedConfig :: IO SavedConfig +baseSavedConfig = do + userPrefix <- defaultCabalDir + logsDir <- defaultLogsDir + worldFile <- defaultWorldFile + return mempty { + savedConfigureFlags = mempty { + configHcFlavor = toFlag defaultCompiler, + configUserInstall = toFlag defaultUserInstall, + configVerbosity = toFlag normal + }, + savedUserInstallDirs = mempty { + prefix = toFlag (toPathTemplate userPrefix) + }, + savedGlobalFlags = mempty { + globalLogsDir = toFlag logsDir, + globalWorldFile = toFlag worldFile + } + } + +-- | This is the initial configuration that we write out to to the config file +-- if the file does not exist (or the config we use if the file cannot be read +-- for some other reason). When the config gets loaded it gets layered on top +-- of 'baseSavedConfig' so we do not need to include it into the initial +-- values we save into the config file. +-- +initialSavedConfig :: IO SavedConfig +initialSavedConfig = do + cacheDir <- defaultCacheDir + logsDir <- defaultLogsDir + worldFile <- defaultWorldFile + return mempty { + savedGlobalFlags = mempty { + globalCacheDir = toFlag cacheDir, + globalRemoteRepos = [defaultRemoteRepo], + globalWorldFile = toFlag worldFile + }, + savedInstallFlags = mempty { + installSummaryFile = [toPathTemplate (logsDir "build.log")], + installBuildReports= toFlag AnonymousReports + } + } + +--TODO: misleading, there's no way to override this default +-- either make it possible or rename to simply getCabalDir. +defaultCabalDir :: IO FilePath +defaultCabalDir = getAppUserDataDirectory "cabal" + +defaultConfigFile :: IO FilePath +defaultConfigFile = do + dir <- defaultCabalDir + return $ dir "config" + +defaultCacheDir :: IO FilePath +defaultCacheDir = do + dir <- defaultCabalDir + return $ dir "packages" + +defaultLogsDir :: IO FilePath +defaultLogsDir = do + dir <- defaultCabalDir + return $ dir "logs" + +-- | Default position of the world file +defaultWorldFile :: IO FilePath +defaultWorldFile = do + dir <- defaultCabalDir + return $ dir "world" + +defaultCompiler :: CompilerFlavor +defaultCompiler = fromMaybe GHC defaultCompilerFlavor + +defaultUserInstall :: Bool +defaultUserInstall = True +-- We do per-user installs by default on all platforms. We used to default to +-- global installs on Windows but that no longer works on Windows Vista or 7. + +defaultRemoteRepo :: RemoteRepo +defaultRemoteRepo = RemoteRepo name uri + where + name = "hackage.haskell.org" + uri = URI "http:" (Just (URIAuth "" name "")) "/packages/archive" "" "" + +-- +-- * Config file reading +-- + +loadConfig :: Verbosity -> Flag FilePath -> Flag Bool -> IO SavedConfig +loadConfig verbosity configFileFlag userInstallFlag = addBaseConf $ do + let sources = [ + ("commandline option", return . flagToMaybe $ configFileFlag), + ("env var CABAL_CONFIG", lookup "CABAL_CONFIG" `liftM` getEnvironment), + ("default config file", Just `liftM` defaultConfigFile) ] + + getSource [] = error "no config file path candidate found." + getSource ((msg,action): xs) = + action >>= maybe (getSource xs) (return . (,) msg) + + (source, configFile) <- getSource sources + minp <- readConfigFile mempty configFile + case minp of + Nothing -> do + notice verbosity $ "Config file path source is " ++ source ++ "." + notice verbosity $ "Config file " ++ configFile ++ " not found." + notice verbosity $ "Writing default configuration to " ++ configFile + commentConf <- commentSavedConfig + initialConf <- initialSavedConfig + writeConfigFile configFile commentConf initialConf + return initialConf + Just (ParseOk ws conf) -> do + when (not $ 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." + initialSavedConfig + + where + addBaseConf body = do + base <- baseSavedConfig + extra <- body + return (updateInstallDirs userInstallFlag (base `mappend` extra)) + +readConfigFile :: SavedConfig -> FilePath -> IO (Maybe (ParseResult SavedConfig)) +readConfigFile initial file = handleNotExists $ + fmap (Just . parseConfig initial) (readFile file) + + where + handleNotExists action = catch action $ \ioe -> + if isDoesNotExistError ioe + then return Nothing + else ioError ioe + +writeConfigFile :: FilePath -> SavedConfig -> SavedConfig -> IO () +writeConfigFile file comments vals = do + createDirectoryIfMissing True (takeDirectory file) + writeFile file $ explanation ++ showConfigWithComments comments vals ++ "\n" + where + explanation = unlines + ["-- This is the configuration file for the 'cabal' command line tool." + ,"" + ,"-- The available configuration options are listed below." + ,"-- Some of them have default values listed." + ,"" + ,"-- Lines (like this one) beginning with '--' are comments." + ,"-- Be careful with spaces and indentation because they are" + ,"-- used to indicate layout for nested sections." + ,"","" + ] + +-- | These are the default values that get used in Cabal if a no value is +-- given. We use these here to include in comments when we write out the +-- initial config file so that the user can see what default value they are +-- overriding. +-- +commentSavedConfig :: IO SavedConfig +commentSavedConfig = do + userInstallDirs <- defaultInstallDirs defaultCompiler True True + globalInstallDirs <- defaultInstallDirs defaultCompiler False True + return SavedConfig { + savedGlobalFlags = commandDefaultFlags globalCommand, + savedInstallFlags = defaultInstallFlags, + savedConfigureExFlags = defaultConfigExFlags, + savedConfigureFlags = (defaultConfigFlags defaultProgramConfiguration) { + configUserInstall = toFlag defaultUserInstall + }, + savedUserInstallDirs = fmap toFlag userInstallDirs, + savedGlobalInstallDirs = fmap toFlag globalInstallDirs, + savedUploadFlags = commandDefaultFlags uploadCommand, + savedReportFlags = commandDefaultFlags reportCommand + } + +-- | All config file fields. +-- +configFieldDescriptions :: [FieldDescr SavedConfig] +configFieldDescriptions = + + toSavedConfig liftGlobalFlag + (commandOptions globalCommand ParseArgs) + ["version", "numeric-version", "config-file"] [] + + ++ toSavedConfig liftConfigFlag + (configureOptions ParseArgs) + (["builddir", "configure-option"] ++ map fieldName installDirsFields) + + --FIXME: this is only here because viewAsFieldDescr gives us a parser + -- that only recognises 'ghc' etc, the case-sensitive flag names, not + -- what the normal case-insensitive parser gives us. + [simpleField "compiler" + (fromFlagOrDefault Disp.empty . fmap Text.disp) (optional Text.parse) + configHcFlavor (\v flags -> flags { configHcFlavor = v }) + ] + + ++ toSavedConfig liftConfigExFlag + (configureExOptions ParseArgs) + [] [] + + ++ toSavedConfig liftInstallFlag + (installOptions ParseArgs) + ["dry-run", "reinstall", "only"] [] + + ++ toSavedConfig liftUploadFlag + (commandOptions uploadCommand ParseArgs) + ["verbose", "check"] [] + + ++ toSavedConfig liftReportFlag + (commandOptions reportCommand ParseArgs) + ["verbose"] [] + + where + toSavedConfig lift options exclusions replacements = + [ lift (fromMaybe field replacement) + | opt <- options + , let field = viewAsFieldDescr opt + name = fieldName field + replacement = find ((== name) . fieldName) replacements + , name `notElem` exclusions ] + optional = Parse.option mempty . fmap toFlag + +-- TODO: next step, make the deprecated fields elicit a warning. +-- +deprecatedFieldDescriptions :: [FieldDescr SavedConfig] +deprecatedFieldDescriptions = + [ liftGlobalFlag $ + listField "repos" + (Disp.text . showRepo) parseRepo + globalRemoteRepos (\rs cfg -> cfg { globalRemoteRepos = rs }) + , liftGlobalFlag $ + simpleField "cachedir" + (Disp.text . fromFlagOrDefault "") (optional parseFilePathQ) + globalCacheDir (\d cfg -> cfg { globalCacheDir = d }) + , liftUploadFlag $ + simpleField "hackage-username" + (Disp.text . fromFlagOrDefault "" . fmap unUsername) + (optional (fmap Username parseTokenQ)) + uploadUsername (\d cfg -> cfg { uploadUsername = d }) + , liftUploadFlag $ + simpleField "hackage-password" + (Disp.text . fromFlagOrDefault "" . fmap unPassword) + (optional (fmap Password parseTokenQ)) + uploadPassword (\d cfg -> cfg { uploadPassword = d }) + ] + ++ map (modifyFieldName ("user-"++) . liftUserInstallDirs) installDirsFields + ++ map (modifyFieldName ("global-"++) . liftGlobalInstallDirs) installDirsFields + where + optional = Parse.option mempty . fmap toFlag + modifyFieldName :: (String -> String) -> FieldDescr a -> FieldDescr a + modifyFieldName f d = d { fieldName = f (fieldName d) } + +liftUserInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate)) + -> FieldDescr SavedConfig +liftUserInstallDirs = liftField + savedUserInstallDirs (\flags conf -> conf { savedUserInstallDirs = flags }) + +liftGlobalInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate)) + -> FieldDescr SavedConfig +liftGlobalInstallDirs = liftField + savedGlobalInstallDirs (\flags conf -> conf { savedGlobalInstallDirs = flags }) + +liftGlobalFlag :: FieldDescr GlobalFlags -> FieldDescr SavedConfig +liftGlobalFlag = liftField + savedGlobalFlags (\flags conf -> conf { savedGlobalFlags = flags }) + +liftConfigFlag :: FieldDescr ConfigFlags -> FieldDescr SavedConfig +liftConfigFlag = liftField + savedConfigureFlags (\flags conf -> conf { savedConfigureFlags = flags }) + +liftConfigExFlag :: FieldDescr ConfigExFlags -> FieldDescr SavedConfig +liftConfigExFlag = liftField + savedConfigureExFlags (\flags conf -> conf { savedConfigureExFlags = flags }) + +liftInstallFlag :: FieldDescr InstallFlags -> FieldDescr SavedConfig +liftInstallFlag = liftField + savedInstallFlags (\flags conf -> conf { savedInstallFlags = flags }) + +liftUploadFlag :: FieldDescr UploadFlags -> FieldDescr SavedConfig +liftUploadFlag = liftField + savedUploadFlags (\flags conf -> conf { savedUploadFlags = flags }) + +liftReportFlag :: FieldDescr ReportFlags -> FieldDescr SavedConfig +liftReportFlag = liftField + savedReportFlags (\flags conf -> conf { savedReportFlags = flags }) + +parseConfig :: SavedConfig -> String -> ParseResult SavedConfig +parseConfig initial = \str -> do + fields <- readFields str + let (knownSections, others) = partition isKnownSection fields + config <- parse others + let user0 = savedUserInstallDirs config + global0 = savedGlobalInstallDirs config + (user, global) <- foldM parseSections (user0, global0) knownSections + return config { + savedUserInstallDirs = user, + savedGlobalInstallDirs = global + } + + where + isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True + isKnownSection _ = False + + parse = parseFields (configFieldDescriptions + ++ deprecatedFieldDescriptions) initial + + parseSections accum@(u,g) (ParseUtils.Section _ "install-dirs" name fs) + | name' == "user" = do u' <- parseFields installDirsFields u fs + return (u', g) + | name' == "global" = do g' <- parseFields installDirsFields g fs + return (u, g') + | otherwise = do + warning "The install-paths section should be for 'user' or 'global'" + return accum + where name' = lowercase name + parseSections accum f = do + warning $ "Unrecognized stanza on line " ++ show (lineNo f) + return accum + +showConfig :: SavedConfig -> String +showConfig = showConfigWithComments mempty + +showConfigWithComments :: SavedConfig -> SavedConfig -> String +showConfigWithComments comment vals = Disp.render $ + ppFields configFieldDescriptions comment vals + $+$ Disp.text "" + $+$ installDirsSection "user" savedUserInstallDirs + $+$ Disp.text "" + $+$ installDirsSection "global" savedGlobalInstallDirs + where + installDirsSection name field = + ppSection "install-dirs" name installDirsFields + (field comment) (field 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 + diff --git a/Distribution/Client/Configure.hs b/Distribution/Client/Configure.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Configure.hs @@ -0,0 +1,191 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Configure +-- Copyright : (c) David Himmelstrup 2005, +-- Duncan Coutts 2005 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- High level interface to configuring a package. +----------------------------------------------------------------------------- +module Distribution.Client.Configure ( + configure, + ) where + +import Distribution.Client.Dependency +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.InstallPlan (InstallPlan) +import Distribution.Client.IndexUtils as IndexUtils + ( getAvailablePackages, getInstalledPackages ) +import Distribution.Client.Setup + ( ConfigExFlags(..), configureCommand, filterConfigureFlags ) +import Distribution.Client.Types as Available +import Distribution.Client.SetupWrapper + ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) + +import Distribution.Simple.Compiler + ( CompilerId(..), Compiler(compilerId) + , PackageDB(..), PackageDBStack ) +import Distribution.Simple.Program (ProgramConfiguration ) +import Distribution.Simple.Setup + ( ConfigFlags(..), toFlag, flagToMaybe, fromFlagOrDefault ) +import Distribution.Client.PackageIndex (PackageIndex) +import Distribution.Simple.Utils + ( defaultPackageDesc ) +import Distribution.Package + ( Package(..), packageName, Dependency(..), thisPackageVersion ) +import Distribution.PackageDescription.Parse + ( readPackageDescription ) +import Distribution.PackageDescription.Configuration + ( finalizePackageDescription ) +import Distribution.Version + ( anyVersion, thisVersion ) +import Distribution.Simple.Utils as Utils + ( notice, info, debug, die ) +import Distribution.System + ( Platform, buildPlatform ) +import Distribution.Verbosity as Verbosity + ( Verbosity ) + +import Data.Monoid (Monoid(..)) + +-- | Configure the package found in the local directory +configure :: Verbosity + -> PackageDBStack + -> [Repo] + -> Compiler + -> ProgramConfiguration + -> ConfigFlags + -> ConfigExFlags + -> [String] + -> IO () +configure verbosity packageDBs repos comp conf + configFlags configExFlags extraArgs = do + + installed <- getInstalledPackages verbosity comp packageDBs conf + available <- getAvailablePackages verbosity repos + + progress <- planLocalPackage verbosity comp configFlags configExFlags + installed available + + notice verbosity "Resolving dependencies..." + maybePlan <- foldProgress logMsg (return . Left) (return . Right) + progress + case maybePlan of + Left message -> do + info verbosity message + setupWrapper verbosity (setupScriptOptions installed) Nothing + configureCommand (const configFlags) extraArgs + + Right installPlan -> case InstallPlan.ready installPlan of + [pkg@(ConfiguredPackage (AvailablePackage _ _ (LocalUnpackedPackage _)) _ _)] -> + configurePackage verbosity + (InstallPlan.planPlatform installPlan) + (InstallPlan.planCompiler installPlan) + (setupScriptOptions installed) + configFlags pkg extraArgs + + _ -> die $ "internal error: configure install plan should have exactly " + ++ "one local ready package." + + where + setupScriptOptions index = SetupScriptOptions { + useCabalVersion = maybe anyVersion thisVersion + (flagToMaybe (configCabalVersion configExFlags)), + useCompiler = Just comp, + -- 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. + usePackageDB = if UserPackageDB `elem` packageDBs + then packageDBs + else packageDBs ++ [UserPackageDB], + usePackageIndex = if UserPackageDB `elem` packageDBs + then Just index + else Nothing, + useProgramConfig = conf, + useDistPref = fromFlagOrDefault + (useDistPref defaultSetupScriptOptions) + (configDistPref configFlags), + useLoggingHandle = Nothing, + useWorkingDir = Nothing + } + + logMsg message rest = debug verbosity message >> rest + +-- | Make an 'InstallPlan' for the unpacked package in the current directory, +-- and all its dependencies. +-- +planLocalPackage :: Verbosity -> Compiler + -> ConfigFlags -> ConfigExFlags + -> PackageIndex InstalledPackage + -> AvailablePackageDb + -> IO (Progress String String InstallPlan) +planLocalPackage verbosity comp configFlags configExFlags installed + (AvailablePackageDb _ availablePrefs) = do + pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity + + let -- We create a local package and ask to resolve a dependency on it + localPkg = AvailablePackage { + packageInfoId = packageId pkg, + Available.packageDescription = pkg, + packageSource = LocalUnpackedPackage "." + } + + resolverParams = + + addPreferences + -- preferences from the config file or command line + [ PackageVersionPreference name ver + | Dependency name ver <- configPreferences configExFlags ] + + . addConstraints + -- version constraints from the config file or command line + [ PackageVersionConstraint name ver + | Dependency name ver <- configConstraints configFlags ] + + . addConstraints + -- package flags from the config file or command line + [ PackageFlagsConstraint (packageName pkg) + (configConfigurationsFlags configFlags) ] + + $ standardInstallPolicy + installed + (AvailablePackageDb mempty availablePrefs) + [SpecificSourcePackage localPkg] + + return (resolveDependencies buildPlatform (compilerId comp) resolverParams) + + +-- | Call an installer for an 'AvailablePackage' but override the configure +-- flags with the ones given by the 'ConfiguredPackage'. In particular the +-- 'ConfiguredPackage' specifies an exact 'FlagAssignment' and exactly +-- versioned package dependencies. So we ignore any previous partial flag +-- assignment or dependency constraints and use the new ones. +-- +configurePackage :: Verbosity + -> Platform -> CompilerId + -> SetupScriptOptions + -> ConfigFlags + -> ConfiguredPackage + -> [String] + -> IO () +configurePackage verbosity platform comp scriptOptions configFlags + (ConfiguredPackage (AvailablePackage _ gpkg _) flags deps) extraArgs = + + setupWrapper verbosity + scriptOptions (Just pkg) configureCommand configureFlags extraArgs + + where + configureFlags = filterConfigureFlags configFlags { + configConfigurationsFlags = flags, + configConstraints = map thisPackageVersion deps, + configVerbosity = toFlag verbosity + } + + pkg = case finalizePackageDescription flags + (const True) + platform comp [] gpkg of + Left _ -> error "finalizePackageDescription ConfiguredPackage failed" + Right (desc, _) -> desc diff --git a/Distribution/Client/Dependency.hs b/Distribution/Client/Dependency.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency.hs @@ -0,0 +1,441 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Dependency +-- Copyright : (c) David Himmelstrup 2005, +-- Bjorn Bringert 2007 +-- Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Top level interface to dependency resolution. +----------------------------------------------------------------------------- +module Distribution.Client.Dependency ( + -- * The main package dependency resolver + resolveDependencies, + Progress(..), + foldProgress, + + -- * Alternate, simple resolver that does not do dependencies recursively + resolveWithoutDependencies, + + -- * Constructing resolver policies + DepResolverParams(..), + PackageConstraint(..), + PackagesPreferenceDefault(..), + PackagePreference(..), + InstalledPreference(..), + + -- ** Standard policy + standardInstallPolicy, + PackageSpecifier(..), + + -- ** Extra policy options + dontUpgradeBasePackage, + hideBrokenInstalledPackages, + upgradeDependencies, + reinstallTargets, + + -- ** Policy utils + addConstraints, + addPreferences, + setPreferenceDefault, + addAvailablePackages, + hideInstalledPackagesSpecific, + hideInstalledPackagesAllVersions, + ) where + +import Distribution.Client.Dependency.TopDown (topDownResolver) +import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Client.PackageIndex (PackageIndex) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.InstallPlan (InstallPlan) +import Distribution.Client.Types + ( AvailablePackageDb(AvailablePackageDb) + , AvailablePackage(..), InstalledPackage ) +import Distribution.Client.Dependency.Types + ( DependencyResolver, PackageConstraint(..) + , PackagePreferences(..), InstalledPreference(..) + , Progress(..), foldProgress ) +import Distribution.Client.Targets +import Distribution.Package + ( PackageName(..), PackageId, Package(..), packageVersion + , Dependency(Dependency)) +import Distribution.Version + ( VersionRange, anyVersion, withinRange, simplifyVersionRange ) +import Distribution.Compiler + ( CompilerId(..) ) +import Distribution.System + ( Platform ) +import Distribution.Simple.Utils (comparing) +import Distribution.Text + ( display ) + +import Data.List (maximumBy, foldl') +import Data.Maybe (fromMaybe, isJust) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Set (Set) + + +-- ------------------------------------------------------------ +-- * High level planner policy +-- ------------------------------------------------------------ + +-- | The set of parameters to the dependency resolver. These parameters are +-- relatively low level but many kinds of high level policies can be +-- implemented in terms of adjustments to the parameters. +-- +data DepResolverParams = DepResolverParams { + depResolverTargets :: [PackageName], + depResolverConstraints :: [PackageConstraint], + depResolverPreferences :: [PackagePreference], + depResolverPreferenceDefault :: PackagesPreferenceDefault, + depResolverInstalled :: PackageIndex InstalledPackage, + depResolverAvailable :: PackageIndex AvailablePackage + } + + +-- | Global policy for all packages to say if we prefer package versions that +-- are already installed locally or if we just prefer the latest available. +-- +data PackagesPreferenceDefault = + + -- | Always prefer the latest version irrespective of any existing + -- installed version. + -- + -- * This is the standard policy for upgrade. + -- + PreferAllLatest + + -- | Always prefer the installed versions over ones that would need to be + -- installed. Secondarily, prefer latest versions (eg the latest installed + -- version or if there are none then the latest available version). + | PreferAllInstalled + + -- | Prefer the latest version for packages that are explicitly requested + -- but prefers the installed version for any other packages. + -- + -- * This is the standard policy for install. + -- + | PreferLatestForSelected + + +-- | A package selection preference for a particular package. +-- +-- Preferences are soft constraints that the dependency resolver should try to +-- respect where possible. It is not specified if preferences on some packages +-- are more important than others. +-- +data PackagePreference = + + -- | A suggested constraint on the version number. + PackageVersionPreference PackageName VersionRange + + -- | If we prefer versions of packages that are already installed. + | PackageInstalledPreference PackageName InstalledPreference + +basicDepResolverParams :: PackageIndex InstalledPackage + -> PackageIndex AvailablePackage + -> DepResolverParams +basicDepResolverParams installed available = + DepResolverParams { + depResolverTargets = [], + depResolverConstraints = [], + depResolverPreferences = [], + depResolverPreferenceDefault = PreferLatestForSelected, + depResolverInstalled = installed, + depResolverAvailable = available + } + +addTargets :: [PackageName] + -> DepResolverParams -> DepResolverParams +addTargets extraTargets params = + params { + depResolverTargets = extraTargets ++ depResolverTargets params + } + +addConstraints :: [PackageConstraint] + -> DepResolverParams -> DepResolverParams +addConstraints extraConstraints params = + params { + depResolverConstraints = extraConstraints + ++ depResolverConstraints params + } + +addPreferences :: [PackagePreference] + -> DepResolverParams -> DepResolverParams +addPreferences extraPreferences params = + params { + depResolverPreferences = extraPreferences + ++ depResolverPreferences params + } + +setPreferenceDefault :: PackagesPreferenceDefault + -> DepResolverParams -> DepResolverParams +setPreferenceDefault preferenceDefault params = + params { + depResolverPreferenceDefault = preferenceDefault + } + +dontUpgradeBasePackage :: DepResolverParams -> DepResolverParams +dontUpgradeBasePackage params = + addConstraints extraConstraints params + where + extraConstraints = + [ PackageInstalledConstraint pkgname + | all (/=PackageName "base") (depResolverTargets params) + , pkgname <- [ PackageName "base", PackageName "ghc-prim" ] + , isInstalled pkgname ] + -- TODO: the top down resolver chokes on the base constraints + -- below when there are no targets and thus no dep on base. + -- Need to refactor contraints separate from needing packages. + isInstalled = not . null + . PackageIndex.lookupPackageName (depResolverInstalled params) + +addAvailablePackages :: [AvailablePackage] + -> DepResolverParams -> DepResolverParams +addAvailablePackages pkgs params = + params { + depResolverAvailable = foldl (flip PackageIndex.insert) + (depResolverAvailable params) pkgs + } + +hideInstalledPackagesSpecific :: [PackageId] + -> DepResolverParams -> DepResolverParams +hideInstalledPackagesSpecific pkgids params = + --TODO: this should work using exclude constraints instead + params { + depResolverInstalled = foldl' (flip PackageIndex.deletePackageId) + (depResolverInstalled params) pkgids + } + +hideInstalledPackagesAllVersions :: [PackageName] + -> DepResolverParams -> DepResolverParams +hideInstalledPackagesAllVersions pkgnames params = + --TODO: this should work using exclude constraints instead + params { + depResolverInstalled = + foldl' (flip PackageIndex.deletePackageName) + (depResolverInstalled params) pkgnames + } + + +hideBrokenInstalledPackages :: DepResolverParams -> DepResolverParams +hideBrokenInstalledPackages params = + hideInstalledPackagesSpecific pkgids params + where + pkgids = map packageId + . PackageIndex.reverseDependencyClosure (depResolverInstalled params) + . map (packageId . fst) + . PackageIndex.brokenPackages + $ depResolverInstalled params + + +upgradeDependencies :: DepResolverParams -> DepResolverParams +upgradeDependencies = setPreferenceDefault PreferAllLatest + + +reinstallTargets :: DepResolverParams -> DepResolverParams +reinstallTargets params = + hideInstalledPackagesAllVersions (depResolverTargets params) params + + +standardInstallPolicy :: PackageIndex InstalledPackage + -> AvailablePackageDb + -> [PackageSpecifier AvailablePackage] + -> DepResolverParams +standardInstallPolicy + installed (AvailablePackageDb available availablePrefs) pkgSpecifiers + + = addPreferences + [ PackageVersionPreference name ver + | (name, ver) <- Map.toList availablePrefs ] + + . addConstraints + (concatMap pkgSpecifierConstraints pkgSpecifiers) + + . addTargets + (map pkgSpecifierTarget pkgSpecifiers) + + . hideInstalledPackagesSpecific + [ packageId pkg | SpecificSourcePackage pkg <- pkgSpecifiers ] + + . addAvailablePackages + [ pkg | SpecificSourcePackage pkg <- pkgSpecifiers ] + + $ basicDepResolverParams + installed available + + +-- ------------------------------------------------------------ +-- * Interface to the standard resolver +-- ------------------------------------------------------------ + +defaultResolver :: DependencyResolver +defaultResolver = topDownResolver + +-- | Run the dependency solver. +-- +-- Since this is potentially an expensive operation, the result is wrapped in a +-- a 'Progress' structure that can be unfolded to provide progress information, +-- logging messages and the final result or an error. +-- +resolveDependencies :: Platform + -> CompilerId + -> DepResolverParams + -> Progress String String InstallPlan + + --TODO: is this needed here? see dontUpgradeBasePackage +resolveDependencies platform comp params + | null (depResolverTargets params) + = return (mkInstallPlan platform comp []) + +resolveDependencies platform comp params = + + fmap (mkInstallPlan platform comp) + $ defaultResolver platform comp installed available + preferences constraints targets + where + DepResolverParams + targets constraints + prefs defpref + installed available = dontUpgradeBasePackage + . hideBrokenInstalledPackages + $ params + + preferences = interpretPackagesPreference + (Set.fromList targets) defpref prefs + + +-- | Make an install plan from the output of the dep resolver. +-- It checks that the plan is valid, or it's an error in the dep resolver. +-- +mkInstallPlan :: Platform + -> CompilerId + -> [InstallPlan.PlanPackage] -> InstallPlan +mkInstallPlan platform comp pkgs = + case InstallPlan.new platform comp (PackageIndex.fromList pkgs) of + Right plan -> plan + Left problems -> error $ unlines $ + "internal error: could not construct a valid install plan." + : "The proposed (invalid) plan contained the following problems:" + : map InstallPlan.showPlanProblem problems + + +-- | Give an interpretation to the global 'PackagesPreference' as +-- specific per-package 'PackageVersionPreference'. +-- +interpretPackagesPreference :: Set PackageName + -> PackagesPreferenceDefault + -> [PackagePreference] + -> (PackageName -> PackagePreferences) +interpretPackagesPreference selected defaultPref prefs = + \pkgname -> PackagePreferences (versionPref pkgname) (installPref pkgname) + + where + versionPref pkgname = + fromMaybe anyVersion (Map.lookup pkgname versionPrefs) + versionPrefs = Map.fromList + [ (pkgname, pref) + | PackageVersionPreference pkgname pref <- prefs ] + + installPref pkgname = + fromMaybe (installPrefDefault pkgname) (Map.lookup pkgname installPrefs) + installPrefs = Map.fromList + [ (pkgname, pref) + | PackageInstalledPreference pkgname pref <- prefs ] + installPrefDefault = case defaultPref of + PreferAllLatest -> \_ -> PreferLatest + PreferAllInstalled -> \_ -> PreferInstalled + PreferLatestForSelected -> \pkgname -> + -- When you say cabal install foo, what you really mean is, prefer the + -- latest version of foo, but the installed version of everything else + if pkgname `Set.member` selected then PreferLatest + else PreferInstalled + +-- ------------------------------------------------------------ +-- * Simple resolver that ignores dependencies +-- ------------------------------------------------------------ + +-- | A simplistic method of resolving a list of target package names to +-- available packages. +-- +-- Specifically, it does not consider package dependencies at all. Unlike +-- 'resolveDependencies', no attempt is made to ensure that the selected +-- packages have dependencies that are satisfiable or consistent with +-- each other. +-- +-- It is suitable for tasks such as selecting packages to download for user +-- inspection. It is not suitable for selecting packages to install. +-- +-- Note: if no installed package index is available, it is ok to pass 'mempty'. +-- It simply means preferences for installed packages will be ignored. +-- +resolveWithoutDependencies :: DepResolverParams + -> Either [ResolveNoDepsError] [AvailablePackage] +resolveWithoutDependencies (DepResolverParams targets constraints + prefs defpref installed available) = + collectEithers (map selectPackage targets) + where + selectPackage :: PackageName -> Either ResolveNoDepsError AvailablePackage + selectPackage pkgname + | null choices = Left $! ResolveUnsatisfiable pkgname requiredVersions + | otherwise = Right $! maximumBy bestByPrefs choices + + where + -- Constraints + requiredVersions = packageConstraints pkgname + pkgDependency = Dependency pkgname requiredVersions + choices = PackageIndex.lookupDependency available pkgDependency + + -- Preferences + PackagePreferences preferredVersions preferInstalled + = packagePreferences pkgname + + bestByPrefs = comparing $ \pkg -> + (installPref pkg, versionPref pkg, packageVersion pkg) + installPref = case preferInstalled of + PreferLatest -> const False + PreferInstalled -> isJust . PackageIndex.lookupPackageId installed + . packageId + versionPref pkg = packageVersion pkg `withinRange` preferredVersions + + packageConstraints :: PackageName -> VersionRange + packageConstraints pkgname = + Map.findWithDefault anyVersion pkgname packageVersionConstraintMap + packageVersionConstraintMap = + Map.fromList [ (name, range) + | PackageVersionConstraint name range <- constraints ] + + packagePreferences :: PackageName -> PackagePreferences + packagePreferences = interpretPackagesPreference + (Set.fromList targets) defpref prefs + + +collectEithers :: [Either a b] -> Either [a] [b] +collectEithers = collect . partitionEithers + where + collect ([], xs) = Right xs + collect (errs,_) = Left errs + 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) + +-- | Errors for 'resolveWithoutDependencies'. +-- +data ResolveNoDepsError = + + -- | A package name which cannot be resolved to a specific package. + -- Also gives the constraint on the version and whether there was + -- a constraint on the package being installed. + ResolveUnsatisfiable PackageName VersionRange + +instance Show ResolveNoDepsError where + show (ResolveUnsatisfiable name ver) = + "There is no available version of " ++ display name + ++ " that satisfies " ++ display (simplifyVersionRange ver) diff --git a/Distribution/Client/Dependency/Modular.hs b/Distribution/Client/Dependency/Modular.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/Modular.hs @@ -0,0 +1,58 @@ +module Distribution.Client.Dependency.Modular + ( modularResolver, SolverConfig(..)) where + +-- Here, we try to map between the external cabal-install solver +-- interface and the internal interface that the solver actually +-- expects. There are a number of type conversions to perform: we +-- have to convert the package indices to the uniform index used +-- by the solver; we also have to convert the initial constraints; +-- and finally, we have to convert back the resulting install +-- plan. + +import Data.Map as M + ( fromListWith ) +import Distribution.Client.Dependency.Modular.Assignment + ( Assignment, toCPs ) +import Distribution.Client.Dependency.Modular.Dependency + ( RevDepMap ) +import Distribution.Client.Dependency.Modular.ConfiguredConversion + ( convCP ) +import Distribution.Client.Dependency.Modular.IndexConversion + ( convPIs ) +import Distribution.Client.Dependency.Modular.Log + ( logToProgress ) +import Distribution.Client.Dependency.Modular.Package + ( PN ) +import Distribution.Client.Dependency.Modular.Solver + ( SolverConfig(..), solve ) +import Distribution.Client.Dependency.Types + ( DependencyResolver, PackageConstraint(..) ) +import Distribution.Client.InstallPlan + ( PlanPackage ) +import Distribution.System + ( Platform(..) ) + +-- | Ties the two worlds together: classic cabal-install vs. the modular +-- solver. Performs the necessary translations before and after. +modularResolver :: SolverConfig -> DependencyResolver +modularResolver sc (Platform arch os) cid iidx sidx pprefs pcs pns = + fmap (uncurry postprocess) $ -- convert install plan + logToProgress (maxBackjumps sc) $ -- convert log format into progress format + solve sc idx pprefs gcs pns + where + -- Indices have to be converted into solver-specific uniform index. + idx = convPIs os arch cid (shadowPkgs sc) iidx sidx + -- Constraints have to be converted into a finite map indexed by PN. + gcs = M.fromListWith (++) (map (\ pc -> (pcName pc, [pc])) pcs) + + -- Results have to be converted into an install plan. + postprocess :: Assignment -> RevDepMap -> [PlanPackage] + postprocess a rdm = map (convCP iidx sidx) (toCPs a rdm) + + -- Helper function to extract the PN from a constraint. + pcName :: PackageConstraint -> PN + pcName (PackageConstraintVersion pn _) = pn + pcName (PackageConstraintInstalled pn ) = pn + pcName (PackageConstraintSource pn ) = pn + pcName (PackageConstraintFlags pn _) = pn + pcName (PackageConstraintStanzas pn _) = pn diff --git a/Distribution/Client/Dependency/Modular/Assignment.hs b/Distribution/Client/Dependency/Modular/Assignment.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/Modular/Assignment.hs @@ -0,0 +1,146 @@ +module Distribution.Client.Dependency.Modular.Assignment where + +import Control.Applicative +import Control.Monad +import Data.Array as A +import Data.List as L +import Data.Map as M +import Data.Maybe +import Data.Graph +import Prelude hiding (pi) + +import Distribution.PackageDescription (FlagAssignment) -- from Cabal +import Distribution.Client.Types (OptionalStanza) + +import Distribution.Client.Dependency.Modular.Configured +import Distribution.Client.Dependency.Modular.Dependency +import Distribution.Client.Dependency.Modular.Flag +import Distribution.Client.Dependency.Modular.Index +import Distribution.Client.Dependency.Modular.Package +import Distribution.Client.Dependency.Modular.Version + +-- | A (partial) package assignment. Qualified package names +-- are associated with instances. +type PAssignment = Map QPN I + +-- | A (partial) package preassignment. Qualified package names +-- are associated with constrained instances. Constrained instances +-- record constraints about the instances that can still be chosen, +-- and in the extreme case fix a concrete instance. +type PPreAssignment = Map QPN (CI QPN) +type FAssignment = Map QFN Bool +type SAssignment = Map QSN Bool + +-- | A (partial) assignment of variables. +data Assignment = A PAssignment FAssignment SAssignment + deriving (Show, Eq) + +-- | A preassignment comprises knowledge about variables, but not +-- necessarily fixed values. +data PreAssignment = PA PPreAssignment FAssignment SAssignment + +-- | Extend a package preassignment. +-- +-- Either returns a witness of the conflict that would arise during the merge, +-- or the successfully extended assignment. +extend :: Var QPN -> PPreAssignment -> [Dep QPN] -> Either (ConflictSet QPN, [Dep QPN]) PPreAssignment +extend var pa qa = foldM (\ a (Dep qpn ci) -> + let ci' = M.findWithDefault (Constrained []) qpn a + in case (\ x -> M.insert qpn x a) <$> merge ci' ci of + Left (c, (d, d')) -> Left (c, L.map (Dep qpn) (simplify (P qpn) d d')) + Right x -> Right x) + pa qa + where + -- We're trying to remove trivial elements of the conflict. If we're just + -- making a choice pkg == instance, and pkg => pkg == instance is a part + -- of the conflict, then this info is clear from the context and does not + -- have to be repeated. + simplify v (Fixed _ (Goal var' _)) c | v == var && var' == var = [c] + simplify v c (Fixed _ (Goal var' _)) | v == var && var' == var = [c] + simplify _ c d = [c, d] + +-- | Delivers an ordered list of fully configured packages. +-- +-- TODO: This function is (sort of) ok. However, there's an open bug +-- w.r.t. unqualification. There might be several different instances +-- of one package version chosen by the solver, which will lead to +-- clashes. +toCPs :: Assignment -> RevDepMap -> [CP QPN] +toCPs (A pa fa sa) rdm = + let + -- get hold of the graph + g :: Graph + vm :: Vertex -> ((), QPN, [QPN]) + cvm :: QPN -> Maybe Vertex + -- Note that the RevDepMap contains duplicate dependencies. Therefore the nub. + (g, vm, cvm) = graphFromEdges (L.map (\ (x, xs) -> ((), x, nub xs)) + (M.toList rdm)) + tg :: Graph + tg = transposeG g + -- Topsort the dependency graph, yielding a list of pkgs in the right order. + -- The graph will still contain all the installed packages, and it might + -- contain duplicates, because several variables might actually resolve to + -- the same package in the presence of qualified package names. + ps :: [PI QPN] + ps = L.map ((\ (_, x, _) -> PI x (pa M.! x)) . vm) $ + topSort g + -- Determine the flags per package, by walking over and regrouping the + -- complete flag assignment by package. + fapp :: Map QPN FlagAssignment + fapp = M.fromListWith (++) $ + L.map (\ ((FN (PI qpn _) fn), b) -> (qpn, [(fn, b)])) $ + M.toList $ + fa + -- Stanzas per package. + sapp :: Map QPN [OptionalStanza] + sapp = M.fromListWith (++) $ + L.map (\ ((SN (PI qpn _) sn), b) -> (qpn, if b then [sn] else [])) $ + M.toList $ + sa + -- Dependencies per package. + depp :: QPN -> [PI QPN] + depp qpn = let v :: Vertex + v = fromJust (cvm qpn) + dvs :: [Vertex] + dvs = tg A.! v + in L.map (\ dv -> case vm dv of (_, x, _) -> PI x (pa M.! x)) dvs + in + L.map (\ pi@(PI qpn _) -> CP pi + (M.findWithDefault [] qpn fapp) + (M.findWithDefault [] qpn sapp) + (depp qpn)) + ps + +-- | Finalize an assignment and a reverse dependency map. +-- +-- This is preliminary, and geared towards output right now. +finalize :: Index -> Assignment -> RevDepMap -> IO () +finalize idx (A pa fa _) rdm = + let + -- get hold of the graph + g :: Graph + vm :: Vertex -> ((), QPN, [QPN]) + (g, vm) = graphFromEdges' (L.map (\ (x, xs) -> ((), x, xs)) (M.toList rdm)) + -- topsort the dependency graph, yielding a list of pkgs in the right order + f :: [PI QPN] + f = L.filter (not . instPI) (L.map ((\ (_, x, _) -> PI x (pa M.! x)) . vm) (topSort g)) + fapp :: Map QPN [(QFN, Bool)] -- flags per package + fapp = M.fromListWith (++) $ + L.map (\ (qfn@(FN (PI qpn _) _), b) -> (qpn, [(qfn, b)])) $ M.toList $ fa + -- print one instance + ppi pi@(PI qpn _) = showPI pi ++ status pi ++ " " ++ pflags (M.findWithDefault [] qpn fapp) + -- print install status + status :: PI QPN -> String + status (PI (Q _ pn) _) = + case insts of + [] -> " (new)" + vs -> " (" ++ intercalate ", " (L.map showVer vs) ++ ")" + where insts = L.map (\ (I v _) -> v) $ L.filter isInstalled $ + M.keys (M.findWithDefault M.empty pn idx) + isInstalled (I _ (Inst _ )) = True + isInstalled _ = False + -- print flag assignment + pflags = unwords . L.map (uncurry showFBool) + in + -- show packages with associated flag assignments + putStr (unlines (L.map ppi f)) diff --git a/Distribution/Client/Dependency/Modular/Builder.hs b/Distribution/Client/Dependency/Modular/Builder.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/Modular/Builder.hs @@ -0,0 +1,143 @@ +module Distribution.Client.Dependency.Modular.Builder where + +-- Building the search tree. +-- +-- In this phase, we build a search tree that is too large, i.e, it contains +-- invalid solutions. We keep track of the open goals at each point. We +-- nondeterministically pick an open goal (via a goal choice node), create +-- subtrees according to the index and the available solutions, and extend the +-- set of open goals by superficially looking at the dependencies recorded in +-- the index. +-- +-- For each goal, we keep track of all the *reasons* why it is being +-- introduced. These are for debugging and error messages, mainly. A little bit +-- of care has to be taken due to the way we treat flags. If a package has +-- flag-guarded dependencies, we cannot introduce them immediately. Instead, we +-- store the entire dependency. + +import Control.Monad.Reader hiding (sequence, mapM) +import Data.List as L +import Data.Map as M +import Prelude hiding (sequence, mapM) + +import Distribution.Client.Dependency.Modular.Dependency +import Distribution.Client.Dependency.Modular.Flag +import Distribution.Client.Dependency.Modular.Index +import Distribution.Client.Dependency.Modular.Package +import Distribution.Client.Dependency.Modular.PSQ as P +import Distribution.Client.Dependency.Modular.Tree + +-- | The state needed during the build phase of the search tree. +data BuildState = BS { + index :: Index, -- ^ information about packages and their dependencies + scope :: Scope, -- ^ information about encapsulations + rdeps :: RevDepMap, -- ^ set of all package goals, completed and open, with reverse dependencies + open :: PSQ OpenGoal (), -- ^ set of still open goals (flag and package goals) + next :: BuildType -- ^ kind of node to generate next +} + +-- | Extend the set of open goals with the new goals listed. +-- +-- We also adjust the map of overall goals, and keep track of the +-- reverse dependencies of each of the goals. +extendOpen :: QPN -> [OpenGoal] -> BuildState -> BuildState +extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs + where + 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 + go g o (ng@(OpenGoal (Simple (Dep qpn _)) _gr) : ngs) + | qpn == qpn' = go g o ngs + -- we ignore self-dependencies at this point; TODO: more care may be needed + | qpn `M.member` g = go (M.adjust (qpn':) qpn g) o ngs + | otherwise = go (M.insert qpn [qpn'] g) (cons ng () o) ngs + -- code above is correct; insert/adjust have different arg order + +-- | Update the current scope by taking into account the encapsulations that +-- are defined for the current package. +establishScope :: QPN -> Encaps -> BuildState -> BuildState +establishScope (Q pp pn) ecs s = + s { scope = L.foldl (\ m e -> M.insert e pp' m) (scope s) ecs } + where + pp' = pn : pp -- new path + +-- | 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 -> FlagDefaults -> + BuildState -> BuildState +scopedExtendOpen qpn i gr fdeps fdefs s = extendOpen qpn gs s + where + sc = scope s + qfdeps = L.map (fmap (qualify sc)) fdeps -- qualify all the package names + 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 + +build :: BuildState -> Tree (QGoalReasons, Scope) +build = ana go + where + go :: BuildState -> TreeF (QGoalReasons, 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 + -- it from the queue of open goals. + go bs@(BS { rdeps = rds, open = gs, next = Goals }) + | P.null gs = DoneF rds + | otherwise = GoalChoiceF (P.mapWithKey (\ g (_sc, gs') -> bs { next = OneGoal g, open = gs' }) + (P.splits gs)) + + -- If we have already picked a goal, then the choice depends on the kind + -- of goal. + -- + -- For a package, we look up the instances available in the global info, + -- and then handle each instance in turn. + go bs@(BS { index = idx, scope = sc, next = OneGoal (OpenGoal (Simple (Dep qpn@(Q _ pn) _)) gr) }) = + case M.lookup pn idx of + Nothing -> FailF (toConflictSet (Goal (P qpn) gr)) (BuildFailureNotInIndex pn) + Just pis -> PChoiceF qpn (gr, sc) (P.fromList (L.map (\ (i, info) -> + (i, bs { next = Instance qpn i info gr })) + (M.toList pis))) + -- TODO: data structure conversion is rather ugly here + + -- For a flag, we create only two subtrees, and we create them in the order + -- that is indicated by the flag default. + -- + -- TODO: Should we include the flag default in the tree? + go bs@(BS { scope = sc, next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) b t f) gr) }) = + FChoiceF qfn (gr, sc) trivial (P.fromList (reorder b + [(True, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn True : gr)) t) bs) { next = Goals }), + (False, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn False : gr)) f) bs) { next = Goals })])) + where + reorder True = id + reorder False = reverse + trivial = L.null t && L.null f + + go bs@(BS { scope = sc, next = OneGoal (OpenGoal (Stanza qsn@(SN (PI qpn _) _) t) gr) }) = + SChoiceF qsn (gr, sc) trivial (P.fromList + [(False, bs { next = Goals }), + (True, (extendOpen qpn (L.map (flip OpenGoal (SDependency qsn : gr)) t) bs) { next = Goals })]) + where + trivial = L.null t + + -- For a particular instance, we change the state: we update the scope, + -- and furthermore we update the set of goals. + -- + -- TODO: We could inline this above. + go bs@(BS { next = Instance qpn i (PInfo fdeps fdefs ecs _) gr }) = + go ((establishScope qpn ecs + (scopedExtendOpen qpn i (PDependency (PI qpn i) : gr) fdeps fdefs bs)) + { next = Goals }) + +-- | 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 idx ind igs = + build (BS idx sc + (M.fromList (L.map (\ qpn -> (qpn, [])) qpns)) + (P.fromList (L.map (\ qpn -> (OpenGoal (Simple (Dep qpn (Constrained []))) [UserGoal], ())) qpns)) + Goals) + where + sc | ind = makeIndependent igs + | otherwise = emptyScope + qpns = L.map (qualify sc) igs diff --git a/Distribution/Client/Dependency/Modular/Configured.hs b/Distribution/Client/Dependency/Modular/Configured.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/Modular/Configured.hs @@ -0,0 +1,10 @@ +module Distribution.Client.Dependency.Modular.Configured where + +import Distribution.PackageDescription (FlagAssignment) -- from Cabal +import Distribution.Client.Types (OptionalStanza) + +import Distribution.Client.Dependency.Modular.Package + +-- | A configured package is a package instance together with +-- a flag assignment and complete dependencies. +data CP qpn = CP (PI qpn) FlagAssignment [OptionalStanza] [PI qpn] diff --git a/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs b/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs @@ -0,0 +1,40 @@ +module Distribution.Client.Dependency.Modular.ConfiguredConversion where + +import Data.Maybe +import Prelude hiding (pi) + +import Distribution.Client.InstallPlan +import Distribution.Client.Types +import Distribution.Compiler +import qualified Distribution.Client.PackageIndex as CI +import qualified Distribution.Simple.PackageIndex as SI +import Distribution.System + +import Distribution.Client.Dependency.Modular.Configured +import Distribution.Client.Dependency.Modular.Package + +mkPlan :: Platform -> CompilerId -> + SI.PackageIndex -> CI.PackageIndex SourcePackage -> + [CP QPN] -> Either [PlanProblem] InstallPlan +mkPlan plat comp iidx sidx cps = + new plat comp (CI.fromList (map (convCP iidx sidx) cps)) + +convCP :: SI.PackageIndex -> CI.PackageIndex SourcePackage -> + CP QPN -> PlanPackage +convCP iidx sidx (CP qpi fa es ds) = + case convPI qpi of + Left pi -> PreExisting $ InstalledPackage + (fromJust $ SI.lookupInstalledPackageId iidx pi) + (map convPI' ds) + Right pi -> Configured $ ConfiguredPackage + (fromJust $ CI.lookupPackageId sidx pi) + fa + es + (map convPI' ds) + +convPI :: PI QPN -> Either InstalledPackageId PackageId +convPI (PI _ (I _ (Inst pi))) = Left pi +convPI qpi = Right $ convPI' qpi + +convPI' :: PI QPN -> PackageId +convPI' (PI (Q _ pn) (I v _)) = PackageIdentifier pn v diff --git a/Distribution/Client/Dependency/Modular/Dependency.hs b/Distribution/Client/Dependency/Modular/Dependency.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/Modular/Dependency.hs @@ -0,0 +1,194 @@ +module Distribution.Client.Dependency.Modular.Dependency where + +import Prelude hiding (pi) + +import Data.List as L +import Data.Map as M +import Data.Set as S + +import Distribution.Client.Dependency.Modular.Flag +import Distribution.Client.Dependency.Modular.Package +import Distribution.Client.Dependency.Modular.Version + +-- | The type of variables that play a role in the solver. +-- Note that the tree currently does not use this type directly, +-- and rather has separate tree nodes for the different types of +-- variables. This fits better with the fact that in most cases, +-- these have to be treated differently. +-- +-- TODO: This isn't the ideal location to declare the type, +-- but we need them for constrained instances. +data Var qpn = P qpn | F (FN qpn) | S (SN qpn) + deriving (Eq, Ord, Show) + +showVar :: Var QPN -> String +showVar (P qpn) = showQPN qpn +showVar (F qfn) = showQFN qfn +showVar (S qsn) = showQSN qsn + +instance Functor Var where + fmap f (P n) = P (f n) + fmap f (F fn) = F (fmap f fn) + fmap f (S sn) = S (fmap f sn) + +type ConflictSet qpn = Set (Var qpn) + +showCS :: ConflictSet QPN -> String +showCS = intercalate ", " . L.map showVar . S.toList + +-- | Constrained instance. If the choice has already been made, this is +-- a fixed instance, and we record the package name for which the choice +-- is for convenience. Otherwise, it is a list of version ranges paired with +-- the goals / variables that introduced them. +data CI qpn = Fixed I (Goal qpn) | Constrained [VROrigin qpn] + deriving (Eq, Show) + +instance Functor CI where + fmap f (Fixed i g) = Fixed i (fmap f g) + fmap f (Constrained vrs) = Constrained (L.map (\ (x, y) -> (x, fmap f y)) vrs) + +instance ResetGoal CI where + resetGoal g (Fixed i _) = Fixed i g + resetGoal g (Constrained vrs) = Constrained (L.map (\ (x, y) -> (x, resetGoal g y)) vrs) + +type VROrigin qpn = (VR, Goal qpn) + +-- | Helper function to collapse a list of version ranges with origins into +-- a single, simplified, version range. +collapse :: [VROrigin qpn] -> VR +collapse = simplifyVR . L.foldr (.&&.) anyVR . L.map fst + +showCI :: CI QPN -> String +showCI (Fixed i _) = "==" ++ showI i +showCI (Constrained vr) = showVR (collapse vr) + +-- | Merge constrained instances. We currently adopt a lazy strategy for +-- merging, i.e., we only perform actual checking if one of the two choices +-- is fixed. If the merge fails, we return a conflict set indicating the +-- variables responsible for the failure, as well as the two conflicting +-- fragments. +-- +-- Note that while there may be more than one conflicting pair of version +-- ranges, we only return the first we find. +-- +-- TODO: Different pairs might have different conflict sets. We're +-- obviously interested to return a conflict that has a "better" conflict +-- set in the sense the it contains variables that allow us to backjump +-- further. We might apply some heuristics here, such as to change the +-- order in which we check the constraints. +merge :: Ord qpn => CI qpn -> CI qpn -> Either (ConflictSet qpn, (CI qpn, CI qpn)) (CI qpn) +merge c@(Fixed i g1) d@(Fixed j g2) + | i == j = Right c + | otherwise = Left (S.union (toConflictSet g1) (toConflictSet g2), (c, d)) +merge c@(Fixed (I v _) g1) (Constrained rs) = go rs -- I tried "reverse rs" here, but it seems to slow things down ... + where + go [] = Right c + go (d@(vr, g2) : vrs) + | checkVR vr v = go vrs + | otherwise = Left (S.union (toConflictSet g1) (toConflictSet g2), (c, Constrained [d])) +merge c@(Constrained _) d@(Fixed _ _) = merge d c +merge (Constrained rs) (Constrained ss) = Right (Constrained (rs ++ ss)) + + +type FlaggedDeps qpn = [FlaggedDep qpn] + +-- | Flagged dependencies can either be plain dependency constraints, +-- or flag-dependent dependency trees. +data FlaggedDep qpn = + Flagged (FN qpn) FDefault (TrueFlaggedDeps qpn) (FalseFlaggedDeps qpn) + | Stanza (SN qpn) (TrueFlaggedDeps qpn) + | Simple (Dep qpn) + deriving (Eq, Show) + +instance Functor FlaggedDep where + fmap f (Flagged x y tt ff) = Flagged (fmap f x) y + (fmap (fmap f) tt) (fmap (fmap f) ff) + fmap f (Stanza x tt) = Stanza (fmap f x) (fmap (fmap f) tt) + fmap f (Simple d) = Simple (fmap f d) + +type TrueFlaggedDeps qpn = FlaggedDeps qpn +type FalseFlaggedDeps qpn = FlaggedDeps qpn + +-- | A dependency (constraint) associates a package name with a +-- constrained instance. +data Dep qpn = Dep qpn (CI qpn) + deriving (Eq, Show) + +showDep :: Dep QPN -> String +showDep (Dep qpn (Fixed i (Goal v _)) ) = + (if P qpn /= v then showVar v ++ " => " else "") ++ + showQPN qpn ++ "==" ++ showI i +showDep (Dep qpn (Constrained [(vr, Goal v _)])) = + showVar v ++ " => " ++ showQPN qpn ++ showVR vr +showDep (Dep qpn ci ) = + showQPN qpn ++ showCI ci + +instance Functor Dep where + fmap f (Dep x y) = Dep (f x) (fmap f y) + +instance ResetGoal Dep where + resetGoal g (Dep qpn ci) = Dep qpn (resetGoal g ci) + +-- | A map containing reverse dependencies between qualified +-- package names. +type RevDepMap = Map QPN [QPN] + +-- | Goals are solver variables paired with information about +-- why they have been introduced. +data Goal qpn = Goal (Var qpn) (GoalReasons qpn) + deriving (Eq, Show) + +instance Functor Goal where + fmap f (Goal v gr) = Goal (fmap f v) (fmap (fmap f) gr) + +class ResetGoal f where + resetGoal :: Goal qpn -> f qpn -> f qpn + +instance ResetGoal Goal where + resetGoal = const + +-- | For open goals as they occur during the build phase, we need to store +-- additional information about flags. +data OpenGoal = OpenGoal (FlaggedDep QPN) QGoalReasons + deriving (Eq, Show) + +-- | Reasons why a goal can be added to a goal set. +data GoalReason qpn = + UserGoal + | PDependency (PI qpn) + | FDependency (FN qpn) Bool + | SDependency (SN qpn) + deriving (Eq, Show) + +instance Functor GoalReason where + fmap _ UserGoal = UserGoal + fmap f (PDependency pi) = PDependency (fmap f pi) + fmap f (FDependency fn b) = FDependency (fmap f fn) b + fmap f (SDependency sn) = SDependency (fmap f sn) + +-- | The first element is the immediate reason. The rest are the reasons +-- for the reasons ... +type GoalReasons qpn = [GoalReason qpn] + +type QGoalReasons = GoalReasons QPN + +goalReasonToVars :: GoalReason qpn -> ConflictSet qpn +goalReasonToVars UserGoal = S.empty +goalReasonToVars (PDependency (PI qpn _)) = S.singleton (P qpn) +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 + +-- | Closes a goal, i.e., removes all the extraneous information that we +-- need only during the build phase. +close :: OpenGoal -> Goal QPN +close (OpenGoal (Simple (Dep qpn _)) gr) = Goal (P qpn) gr +close (OpenGoal (Flagged qfn _ _ _ ) gr) = Goal (F qfn) gr +close (OpenGoal (Stanza qsn _) gr) = Goal (S qsn) gr + +-- | 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) diff --git a/Distribution/Client/Dependency/Modular/Explore.hs b/Distribution/Client/Dependency/Modular/Explore.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/Modular/Explore.hs @@ -0,0 +1,148 @@ +module Distribution.Client.Dependency.Modular.Explore where + +import Control.Applicative as A +import Data.Foldable +import Data.List as L +import Data.Map as M +import Data.Set as S + +import Distribution.Client.Dependency.Modular.Assignment +import Distribution.Client.Dependency.Modular.Dependency +import Distribution.Client.Dependency.Modular.Log +import Distribution.Client.Dependency.Modular.Message +import Distribution.Client.Dependency.Modular.Package +import Distribution.Client.Dependency.Modular.PSQ as P +import Distribution.Client.Dependency.Modular.Tree + +-- | Backjumping. +-- +-- A tree traversal that tries to propagate conflict sets +-- up the tree from the leaves, and thereby cut branches. +-- All the tricky things are done in the function 'combine'. +backjump :: Tree a -> Tree (Maybe (ConflictSet QPN)) +backjump = snd . cata go + where + go (FailF c fr) = (Just c, Fail c fr) + go (DoneF rdm ) = (Nothing, Done rdm) + go (PChoiceF qpn _ ts) = (c, PChoice qpn c (P.fromList ts')) + where + ~(c, ts') = combine (P qpn) (P.toList ts) S.empty + go (FChoiceF qfn _ b ts) = (c, FChoice qfn c b (P.fromList ts')) + where + ~(c, ts') = combine (F qfn) (P.toList ts) S.empty + go (SChoiceF qsn _ b ts) = (c, SChoice qsn c b (P.fromList ts')) + where + ~(c, ts') = combine (S qsn) (P.toList ts) S.empty + go (GoalChoiceF ts) = (c, GoalChoice (P.fromList ts')) + where + ~(cs, ts') = unzip $ L.map (\ (k, (x, v)) -> (x, (k, v))) $ P.toList ts + c = case cs of [] -> Nothing + d : _ -> d + +-- | The 'combine' function is at the heart of backjumping. It takes +-- the variable we're currently considering, and a list of children +-- annotated with their respective conflict sets, and an accumulator +-- for the result conflict set. It returns a combined conflict set +-- for the parent node, and a (potentially shortened) list of children +-- with the annotations removed. +-- +-- It is *essential* that we produce the results as early as possible. +-- In particular, we have to produce the list of children prior to +-- traversing the entire list -- otherwise we lose the desired behaviour +-- of being able to traverse the tree from left to right incrementally. +-- +-- We can shorten the list of children if we find an individual conflict +-- set that does not contain the current variable. In this case, we can +-- just lift the conflict set to the current level, because the current +-- level cannot possibly have contributed to this conflict, so no other +-- choice at the current level would avoid the conflict. +-- +-- If any of the children might contain a successful solution +-- (indicated by Nothing), then Nothing will be the combined +-- conflict set. If all children contain conflict sets, we can +-- take the union as the combined conflict set. +combine :: Var QPN -> [(a, (Maybe (ConflictSet QPN), b))] -> + ConflictSet QPN -> (Maybe (ConflictSet QPN), [(a, b)]) +combine _ [] c = (Just c, []) +combine var ((k, ( d, v)) : xs) c = (\ ~(e, ys) -> (e, (k, v) : ys)) $ + case d of + Just e | not (var `S.member` e) -> (Just e, []) + | otherwise -> combine var xs (e `S.union` c) + Nothing -> (Nothing, snd $ combine var xs S.empty) + +-- | Naive backtracking exploration of the search tree. This will yield correct +-- assignments only once the tree itself is validated. +explore :: Alternative m => Tree a -> (Assignment -> m (Assignment, RevDepMap)) +explore = cata go + where + go (FailF _ _) _ = A.empty + go (DoneF rdm) a = pure (a, rdm) + 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 + 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 + 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 + 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 = cata go + where + go (FailF c fr) _ = failWith (Failure c fr) + go (DoneF rdm) a = succeedWith Success (a, rdm) + go (PChoiceF qpn c ts) (A pa fa sa) = + backjumpInfo c $ + asum $ -- try children in order, + P.mapWithKey -- when descending ... + (\ k r -> tryWith (TryP (PI qpn k)) $ -- log and ... + r (A (M.insert qpn k pa) fa sa)) -- record the pkg choice + ts + go (FChoiceF qfn c _ ts) (A pa fa sa) = + backjumpInfo c $ + asum $ -- try children in order, + P.mapWithKey -- when descending ... + (\ k r -> tryWith (TryF qfn k) $ -- log and ... + r (A pa (M.insert qfn k fa) sa)) -- record the pkg choice + ts + go (SChoiceF qsn c _ ts) (A pa fa sa) = + backjumpInfo c $ + asum $ -- try children in order, + P.mapWithKey -- when descending ... + (\ k r -> tryWith (TryS qsn k) $ -- log and ... + r (A pa fa (M.insert qsn k sa))) -- record the pkg choice + ts + go (GoalChoiceF ts) a = + casePSQ ts + (failWith (Failure S.empty EmptyGoalChoice)) -- empty goal choice is an internal error + (\ k v _xs -> continueWith (Next (close k)) (v a)) -- commit to the first goal choice + +-- | Add in information about pruned trees. +-- +-- TODO: This isn't quite optimal, because we do not merely report the shape of the +-- tree, but rather make assumptions about where that shape originated from. It'd be +-- better if the pruning itself would leave information that we could pick up at this +-- point. +backjumpInfo :: Maybe (ConflictSet QPN) -> Log Message a -> Log Message a +backjumpInfo c m = m <|> case c of -- important to produce 'm' before matching on 'c'! + Nothing -> A.empty + Just cs -> failWith (Failure cs Backjump) + +-- | Interface. +exploreTree :: Alternative m => Tree a -> m (Assignment, RevDepMap) +exploreTree t = explore t (A M.empty M.empty M.empty) + +-- | Interface. +exploreTreeLog :: Tree (Maybe (ConflictSet QPN)) -> Log Message (Assignment, RevDepMap) +exploreTreeLog t = exploreLog t (A M.empty M.empty M.empty) diff --git a/Distribution/Client/Dependency/Modular/Flag.hs b/Distribution/Client/Dependency/Modular/Flag.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/Modular/Flag.hs @@ -0,0 +1,69 @@ +module Distribution.Client.Dependency.Modular.Flag where + +import Data.Map as M +import Prelude hiding (pi) + +import Distribution.PackageDescription hiding (Flag) -- from Cabal + +import Distribution.Client.Dependency.Modular.Package +import Distribution.Client.Types (OptionalStanza(..)) + +-- | Flag name. Consists of a package instance and the flag identifier itself. +data FN qpn = FN (PI qpn) Flag + deriving (Eq, Ord, Show) + +-- | Extract the package name from a flag name. +getPN :: FN qpn -> qpn +getPN (FN (PI qpn _) _) = qpn + +instance Functor FN where + fmap f (FN x y) = FN (fmap f x) y + +-- | Flag identifier. Just a string. +type Flag = FlagName + +unFlag :: Flag -> String +unFlag (FlagName fn) = fn + +-- | Flag default. Just a bool. +type FDefault = Bool + +-- | Flag defaults. +type FlagDefaults = Map Flag FDefault + +-- | Qualified flag name. +type QFN = FN QPN + +-- | Stanza name. Paired with a package name, much like a flag. +data SN qpn = SN (PI qpn) OptionalStanza + deriving (Eq, Ord, Show) + +instance Functor SN where + fmap f (SN x y) = SN (fmap f x) y + +-- | Qualified stanza name. +type QSN = SN QPN + +unStanza :: OptionalStanza -> String +unStanza TestStanzas = "test" +unStanza BenchStanzas = "bench" + +showQFNBool :: QFN -> Bool -> String +showQFNBool qfn@(FN pi _f) b = showPI pi ++ ":" ++ showFBool qfn b + +showQSNBool :: QSN -> Bool -> String +showQSNBool qsn@(SN pi _f) b = showPI pi ++ ":" ++ showSBool qsn b + +showFBool :: FN qpn -> Bool -> String +showFBool (FN _ f) True = "+" ++ unFlag f +showFBool (FN _ f) False = "-" ++ unFlag f + +showSBool :: SN qpn -> Bool -> String +showSBool (SN _ s) True = "*" ++ unStanza s +showSBool (SN _ s) False = "!" ++ unStanza s + +showQFN :: QFN -> String +showQFN (FN pi f) = showPI pi ++ ":" ++ unFlag f + +showQSN :: QSN -> String +showQSN (SN pi f) = showPI pi ++ ":" ++ unStanza f diff --git a/Distribution/Client/Dependency/Modular/Index.hs b/Distribution/Client/Dependency/Modular/Index.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/Modular/Index.hs @@ -0,0 +1,33 @@ +module Distribution.Client.Dependency.Modular.Index where + +import Data.List as L +import Data.Map as M +import Prelude hiding (pi) + +import Distribution.Client.Dependency.Modular.Dependency +import Distribution.Client.Dependency.Modular.Flag +import Distribution.Client.Dependency.Modular.Package +import Distribution.Client.Dependency.Modular.Tree + +-- | An index contains information about package instances. This is a nested +-- dictionary. Package names are mapped to instances, which in turn is mapped +-- to info. +type Index = Map PN (Map I PInfo) + +-- | Info associated with a package instance. +-- Currently, dependencies, flags, encapsulations and failure reasons. +-- Packages that have a failure reason recorded for them are disabled +-- globally, for reasons external to the solver. We currently use this +-- for shadowing which essentially is a GHC limitation, and for +-- installed packages that are broken. +data PInfo = PInfo (FlaggedDeps PN) FlagDefaults Encaps (Maybe FailReason) + deriving (Show) + +-- | Encapsulations. A list of package names. +type Encaps = [PN] + +mkIndex :: [(PN, I, PInfo)] -> Index +mkIndex xs = M.map M.fromList (groupMap (L.map (\ (pn, i, pi) -> (pn, (i, pi))) xs)) + +groupMap :: Ord a => [(a, b)] -> Map a [b] +groupMap xs = M.fromListWith (flip (++)) (L.map (\ (x, y) -> (x, [y])) xs) diff --git a/Distribution/Client/Dependency/Modular/IndexConversion.hs b/Distribution/Client/Dependency/Modular/IndexConversion.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/Modular/IndexConversion.hs @@ -0,0 +1,185 @@ +module Distribution.Client.Dependency.Modular.IndexConversion where + +import Data.List as L +import Data.Map as M +import Data.Maybe +import Prelude hiding (pi) + +import qualified Distribution.Client.PackageIndex as CI +import Distribution.Client.Types +import Distribution.Compiler +import Distribution.InstalledPackageInfo as IPI +import Distribution.Package -- from Cabal +import Distribution.PackageDescription as PD -- from Cabal +import qualified Distribution.Simple.PackageIndex as SI +import Distribution.Simple.Utils (equating) +import Distribution.System + +import Distribution.Client.Dependency.Modular.Dependency as D +import Distribution.Client.Dependency.Modular.Flag as F +import Distribution.Client.Dependency.Modular.Index +import Distribution.Client.Dependency.Modular.Package +import Distribution.Client.Dependency.Modular.Tree +import Distribution.Client.Dependency.Modular.Version + +-- | Convert both the installed package index and the source package +-- index into one uniform solver index. +-- +-- We use 'allPackagesByName' for the installed package index because +-- that returns us several instances of the same package and version +-- in order of preference. This allows us in principle to "shadow" +-- packages if there are several installed packages of the same version. +-- There are currently some shortcomings in both GHC and Cabal in +-- resolving these situations. However, the right thing to do is to +-- fix the problem there, so for now, shadowing is only activated if +-- explicitly requested. +convPIs :: OS -> Arch -> CompilerId -> Bool -> + SI.PackageIndex -> CI.PackageIndex SourcePackage -> Index +convPIs os arch cid sip iidx sidx = + mkIndex (convIPI' sip iidx ++ convSPI' os arch cid sidx) + +-- | Convert a Cabal installed package index to the simpler, +-- more uniform index format of the solver. +convIPI' :: Bool -> SI.PackageIndex -> [(PN, I, PInfo)] +convIPI' sip idx = combine (convIP idx) . versioned . SI.allPackagesByName $ idx + where + -- group installed packages by version + versioned = L.map (groupBy (equating packageVersion)) + -- apply shadowing whenever there are multple installed packages with + -- the same version + combine f pkgs = [ g (f p) | pbn <- pkgs, pbv <- pbn, + (g, p) <- zip (id : repeat shadow) pbv ] + -- shadowing is recorded in the package info + shadow (pn, i, PInfo fdeps fds encs _) | sip = (pn, i, PInfo fdeps fds encs (Just Shadowed)) + shadow x = x + +convIPI :: Bool -> SI.PackageIndex -> Index +convIPI sip = mkIndex . convIPI' sip + +-- | Convert a single installed package into the solver-specific format. +convIP :: SI.PackageIndex -> InstalledPackageInfo -> (PN, I, PInfo) +convIP idx ipi = + let ipid = installedPackageId ipi + i = I (pkgVersion (sourcePackageId ipi)) (Inst ipid) + pn = pkgName (sourcePackageId ipi) + in case mapM (convIPId pn idx) (IPI.depends ipi) of + Nothing -> (pn, i, PInfo [] M.empty [] (Just Broken)) + Just fds -> (pn, i, PInfo fds M.empty [] Nothing) +-- TODO: Installed packages should also store their encapsulations! + +-- | Convert dependencies specified by an installed package id into +-- flagged dependencies of the solver. +-- +-- May return Nothing if the package can't be found in the index. That +-- indicates that the original package having this dependency is broken +-- and should be ignored. +convIPId :: PN -> SI.PackageIndex -> InstalledPackageId -> Maybe (FlaggedDep PN) +convIPId pn' idx ipid = + case SI.lookupInstalledPackageId idx ipid of + Nothing -> Nothing + Just ipi -> let i = I (pkgVersion (sourcePackageId ipi)) (Inst ipid) + pn = pkgName (sourcePackageId ipi) + in Just (D.Simple (Dep pn (Fixed i (Goal (P pn') [])))) + +-- | Convert a cabal-install source package index to the simpler, +-- more uniform index format of the solver. +convSPI' :: OS -> Arch -> CompilerId -> + CI.PackageIndex SourcePackage -> [(PN, I, PInfo)] +convSPI' os arch cid = L.map (convSP os arch cid) . CI.allPackages + +convSPI :: OS -> Arch -> CompilerId -> + CI.PackageIndex SourcePackage -> Index +convSPI os arch cid = mkIndex . convSPI' os arch cid + +-- | Convert a single source package into the solver-specific format. +convSP :: OS -> Arch -> CompilerId -> SourcePackage -> (PN, I, PInfo) +convSP os arch cid (SourcePackage (PackageIdentifier pn pv) gpd _pl) = + let i = I pv InRepo + in (pn, i, convGPD os arch cid (PI pn i) gpd) + +-- We do not use 'flattenPackageDescription' or 'finalizePackageDescription' +-- from 'Distribution.PackageDescription.Configuration' here, because we +-- want to keep the condition tree, but simplify much of the test. + +-- | Convert a generic package description to a solver-specific 'PInfo'. +-- +-- TODO: We currently just take all dependencies from all specified library, +-- executable and test components. This does not quite seem fair. +convGPD :: OS -> Arch -> CompilerId -> + PI PN -> GenericPackageDescription -> PInfo +convGPD os arch cid pi + (GenericPackageDescription _ flags libs exes tests benchs) = + let + fds = flagDefaults flags + in + 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)) + (concatMap (convCondTree os arch cid pi fds (const True) . snd) tests)) ++ + (prefix (Stanza (SN pi BenchStanzas)) + (concatMap (convCondTree os arch cid pi fds (const True) . snd) benchs))) + fds + [] -- TODO: add encaps + Nothing + +prefix :: (FlaggedDeps qpn -> FlaggedDep qpn) -> FlaggedDeps qpn -> FlaggedDeps qpn +prefix _ [] = [] +prefix f fds = [f fds] + +-- | Convert flag information. +flagDefaults :: [PD.Flag] -> FlagDefaults +flagDefaults = M.fromList . L.map (\ (MkFlag fn _ b _) -> (fn, b)) + +-- | Convert condition trees to flagged dependencies. +convCondTree :: OS -> Arch -> CompilerId -> PI PN -> FlagDefaults -> + (a -> Bool) -> -- how to detect if a branch is active + CondTree ConfVar [Dependency] a -> FlaggedDeps PN +convCondTree os arch cid pi@(PI pn _) fds p (CondNode info ds branches) + | p info = L.map (D.Simple . convDep pn) ds -- unconditional dependencies + ++ concatMap (convBranch os arch cid pi fds p) branches + | otherwise = [] + +-- | Branch interpreter. +-- +-- Here, we try to simplify one of Cabal's condition tree branches into the +-- solver's flagged dependency format, which is weaker. Condition trees can +-- contain complex logical expression composed from flag choices and special +-- flags (such as architecture, or compiler flavour). We try to evaluate the +-- special flags and subsequently simplify to a tree that only depends on +-- simple flag choices. +convBranch :: OS -> Arch -> CompilerId -> + PI PN -> FlagDefaults -> + (a -> Bool) -> -- how to detect if a branch is active + (Condition ConfVar, + CondTree ConfVar [Dependency] a, + Maybe (CondTree ConfVar [Dependency] a)) -> FlaggedDeps PN +convBranch os arch cid@(CompilerId cf cv) pi fds p (c', t', mf') = + go c' ( convCondTree os arch cid pi fds p t') + (maybe [] (convCondTree os arch cid pi fds p) mf') + where + go :: Condition ConfVar -> + FlaggedDeps PN -> FlaggedDeps PN -> FlaggedDeps PN + go (Lit True) t _ = t + go (Lit False) _ f = f + go (CNot c) t f = go c f t + go (CAnd c d) t f = go c (go d t f) f + go (COr c d) t f = go c t (go d t f) + go (Var (Flag fn)) t f = [Flagged (FN pi fn) (fds ! fn) t f] + go (Var (OS os')) t f + | os == os' = t + | otherwise = f + go (Var (Arch arch')) t f + | arch == arch' = t + | otherwise = f + go (Var (Impl cf' cvr')) t f + | cf == cf' && checkVR cvr' cv = t + | otherwise = f + +-- | Convert a Cabal dependency to a solver-specific dependency. +convDep :: PN -> Dependency -> Dep PN +convDep pn' (Dependency pn vr) = Dep pn (Constrained [(vr, Goal (P pn') [])]) + +-- | Convert a Cabal package identifier to a solver-specific dependency. +convPI :: PN -> PackageIdentifier -> Dep PN +convPI pn' (PackageIdentifier pn v) = Dep pn (Constrained [(eqVR v, Goal (P pn') [])]) diff --git a/Distribution/Client/Dependency/Modular/Log.hs b/Distribution/Client/Dependency/Modular/Log.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/Modular/Log.hs @@ -0,0 +1,96 @@ +module Distribution.Client.Dependency.Modular.Log where + +import Control.Applicative +import Data.List as L +import Data.Set as S + +import Distribution.Client.Dependency.Types -- from Cabal + +import Distribution.Client.Dependency.Modular.Dependency +import Distribution.Client.Dependency.Modular.Message +import Distribution.Client.Dependency.Modular.Package +import Distribution.Client.Dependency.Modular.Tree (FailReason(..)) + +-- | The 'Log' datatype. +-- +-- Represents the progress of a computation lazily. +-- +-- Parameterized over the type of actual messages and the final result. +type Log m a = Progress m () a + +runLog :: Log m a -> ([m], Maybe a) +runLog (Done x) = ([], Just x) +runLog (Fail _) = ([], Nothing) +runLog (Step m p) = let + (ms, r) = runLog p + in + (m : ms, r) + +-- | Postprocesses a log file. Takes as an argument a limit on allowed backjumps. +-- If the limit is 'Nothing', then infinitely many backjumps are allowed. If the +-- limit is 'Just 0', backtracking is completely disabled. +logToProgress :: Maybe Int -> Log Message a -> Progress String String a +logToProgress mbj l = let + (ms, s) = runLog l + (es, e) = proc 0 ms -- catch first error (always) + (ns, t) = case mbj of + Nothing -> (ms, Nothing) + Just n -> proc n ms + -- prefer first error over later error + r = case t of + Nothing -> case s of + Nothing -> e + Just _ -> Nothing + Just _ -> e + in go es -- trace for first error + (showMessages (const True) True ns) -- shortened run + r s + where + proc :: Int -> [Message] -> ([Message], Maybe (ConflictSet QPN)) + proc _ [] = ([], Nothing) + proc n ( Failure cs Backjump : xs@(Leave : Failure cs' Backjump : _)) + | cs == cs' = proc n xs -- repeated backjumps count as one + proc 0 ( Failure cs Backjump : _ ) = ([], Just cs) + proc n (x@(Failure _ Backjump) : xs) = (\ ~(ys, r) -> (x : ys, r)) (proc (n - 1) xs) + proc n (x : xs) = (\ ~(ys, r) -> (x : ys, r)) (proc n xs) + + -- 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 (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 + +logToProgress' :: Log Message a -> Progress String String a +logToProgress' l = let + (ms, r) = runLog l + xs = showMessages (const True) True ms + in go xs r + where + go [x] Nothing = Fail x + go [] Nothing = Fail "" + go [] (Just r) = Done r + go (x:xs) r = Step x (go xs r) + + +runLogIO :: Log Message a -> IO (Maybe a) +runLogIO x = + do + let (ms, r) = runLog x + putStr (unlines $ showMessages (const True) True ms) + return r + +failWith :: m -> Log m a +failWith m = Step m (Fail ()) + +succeedWith :: m -> a -> Log m a +succeedWith m x = Step m (Done x) + +continueWith :: m -> Log m a -> Log m a +continueWith = Step + +tryWith :: Message -> Log Message a -> Log Message a +tryWith m x = Step m (Step Enter x) <|> failWith Leave diff --git a/Distribution/Client/Dependency/Modular/Message.hs b/Distribution/Client/Dependency/Modular/Message.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/Modular/Message.hs @@ -0,0 +1,97 @@ +module Distribution.Client.Dependency.Modular.Message where + +import qualified Data.List as L +import Prelude hiding (pi) + +import Distribution.Text -- from Cabal + +import Distribution.Client.Dependency.Modular.Dependency +import Distribution.Client.Dependency.Modular.Flag +import Distribution.Client.Dependency.Modular.Package +import Distribution.Client.Dependency.Modular.Tree + +data Message = + Enter -- ^ increase indentation level + | Leave -- ^ decrease indentation level + | TryP (PI QPN) + | TryF QFN Bool + | TryS QSN Bool + | Next (Goal QPN) + | Success + | Failure (ConflictSet QPN) FailReason + +-- | Transforms the structured message type to actual messages (strings). +-- +-- Takes an additional relevance predicate. The predicate gets a stack of goal +-- variables and can decide whether messages regarding these goals are relevant. +-- You can plug in 'const True' if you're interested in a full trace. If you +-- want a slice of the trace concerning a particular conflict set, then plug in +-- a predicate returning 'True' on the empty stack and if the head is in the +-- conflict set. +-- +-- The second argument indicates if the level numbers should be shown. This is +-- recommended for any trace that involves backtracking, because only the level +-- numbers will allow to keep track of backjumps. +showMessages :: ([Var QPN] -> Bool) -> Bool -> [Message] -> [String] +showMessages p sl = go [] 0 + where + go :: [Var QPN] -> Int -> [Message] -> [String] + go _ _ [] = [] + -- complex patterns + go v l (TryP (PI qpn i) : Enter : Failure c fr : Leave : ms) = goPReject v l qpn [i] c fr ms + go v l (TryF qfn b : Enter : Failure c fr : Leave : ms) = (atLevel (F qfn : v) l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go v l ms) + go v l (TryS qsn b : Enter : Failure c fr : Leave : ms) = (atLevel (S qsn : v) l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go v l ms) + go v l (Next (Goal (P qpn) gr) : TryP pi : ms@(Enter : Next _ : _)) = (atLevel (P qpn : v) l $ "trying: " ++ showPI pi ++ showGRs gr) (go (P qpn : v) l ms) + go v l (Failure c Backjump : ms@(Leave : Failure c' Backjump : _)) | c == c' = go v l ms + -- standard display + go v l (Enter : ms) = go v (l+1) ms + go v l (Leave : ms) = go (drop 1 v) (l-1) ms + go v l (TryP pi@(PI qpn _) : ms) = (atLevel (P qpn : v) l $ "trying: " ++ showPI pi) (go (P qpn : v) l ms) + go v l (TryF qfn b : ms) = (atLevel (F qfn : v) l $ "trying: " ++ showQFNBool qfn b) (go (F qfn : v) l ms) + go v l (TryS qsn b : ms) = (atLevel (S qsn : v) l $ "trying: " ++ showQSNBool qsn b) (go (S qsn : v) l ms) + go v l (Next (Goal (P qpn) gr) : ms) = (atLevel (P qpn : v) l $ "next goal: " ++ showQPN qpn ++ showGRs gr) (go v l ms) + go v l (Next _ : ms) = go v l ms -- ignore flag goals in the log + go v l (Success : ms) = (atLevel v l $ "done") (go v l ms) + go v l (Failure c fr : ms) = (atLevel v l $ "fail" ++ showFR c fr) (go v l ms) + + -- special handler for many subsequent package rejections + goPReject :: [Var QPN] -> Int -> QPN -> [I] -> ConflictSet QPN -> FailReason -> [Message] -> [String] + goPReject v l qpn is c fr (TryP (PI qpn' i) : Enter : Failure _ fr' : Leave : ms) | qpn == qpn' && fr == fr' = goPReject v l qpn (i : is) c fr ms + goPReject v l qpn is c fr ms = (atLevel (P qpn : v) l $ "rejecting: " ++ showQPN qpn ++ "-" ++ L.intercalate ", " (map showI (reverse is)) ++ showFR c fr) (go v l ms) + + -- write a message, but only if it's relevant; we can also enable or disable the display of the current level + atLevel v l x xs + | sl && p v = let s = show l + in ("[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ x) : xs + | p v = x : xs + | otherwise = xs + +showGRs :: QGoalReasons -> String +showGRs (gr : _) = showGR gr +showGRs [] = "" + +showGR :: GoalReason QPN -> String +showGR UserGoal = " (user goal)" +showGR (PDependency pi) = " (dependency of " ++ showPI pi ++ ")" +showGR (FDependency qfn b) = " (dependency of " ++ showQFNBool qfn b ++ ")" +showGR (SDependency qsn) = " (dependency of " ++ showQSNBool qsn True ++ ")" + +showFR :: ConflictSet QPN -> FailReason -> String +showFR _ InconsistentInitialConstraints = " (inconsistent initial constraints)" +showFR _ (Conflicting ds) = " (conflict: " ++ L.intercalate ", " (map showDep ds) ++ ")" +showFR _ CannotInstall = " (only already installed instances can be used)" +showFR _ CannotReinstall = " (avoiding to reinstall a package with same version but new dependencies)" +showFR _ Shadowed = " (shadowed by another installed package with same version)" +showFR _ Broken = " (package is broken)" +showFR _ (GlobalConstraintVersion vr) = " (global constraint requires " ++ display vr ++ ")" +showFR _ GlobalConstraintInstalled = " (global constraint requires installed instance)" +showFR _ GlobalConstraintSource = " (global constraint requires source instance)" +showFR _ GlobalConstraintFlag = " (global constraint requires opposite flag selection)" +showFR _ (BuildFailureNotInIndex pn) = " (unknown package: " ++ display pn ++ ")" +showFR c Backjump = " (backjumping, conflict set: " ++ showCS c ++ ")" +-- The following are internal failures. They should not occur. In the +-- interest of not crashing unnecessarily, we still just print an error +-- message though. +showFR _ (MalformedFlagChoice qfn) = " (INTERNAL ERROR: MALFORMED FLAG CHOICE: " ++ showQFN qfn ++ ")" +showFR _ (MalformedStanzaChoice qsn) = " (INTERNAL ERROR: MALFORMED STANZA CHOICE: " ++ showQSN qsn ++ ")" +showFR _ EmptyGoalChoice = " (INTERNAL ERROR: EMPTY GOAL CHOICE)" diff --git a/Distribution/Client/Dependency/Modular/PSQ.hs b/Distribution/Client/Dependency/Modular/PSQ.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/Modular/PSQ.hs @@ -0,0 +1,102 @@ +module Distribution.Client.Dependency.Modular.PSQ where + +-- Priority search queues. +-- +-- 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. + +import Control.Applicative +import Data.Foldable +import Data.Function +import Data.List as S hiding (foldr) +import Data.Traversable +import Prelude hiding (foldr) + +newtype PSQ k v = PSQ [(k, v)] + deriving (Eq, Show) + +instance Functor (PSQ k) where + fmap f (PSQ xs) = PSQ (fmap (\ (k, v) -> (k, f v)) xs) + +instance Foldable (PSQ k) where + foldr op e (PSQ xs) = foldr op e (fmap snd xs) + +instance Traversable (PSQ k) where + traverse f (PSQ xs) = PSQ <$> traverse (\ (k, v) -> (\ x -> (k, x)) <$> f v) xs + +keys :: PSQ k v -> [k] +keys (PSQ xs) = fmap fst xs + +lookup :: Eq k => k -> PSQ k v -> Maybe v +lookup k (PSQ xs) = S.lookup k xs + +map :: (v1 -> v2) -> PSQ k v1 -> PSQ k v2 +map f (PSQ xs) = PSQ (fmap (\ (k, v) -> (k, f v)) xs) + +mapKeys :: (k1 -> k2) -> PSQ k1 v -> PSQ k2 v +mapKeys f (PSQ xs) = PSQ (fmap (\ (k, v) -> (f k, v)) xs) + +mapWithKey :: (k -> a -> b) -> PSQ k a -> PSQ k b +mapWithKey f (PSQ xs) = PSQ (fmap (\ (k, v) -> (k, f k v)) xs) + +mapWithKeyState :: (s -> k -> a -> (b, s)) -> PSQ k a -> s -> PSQ k b +mapWithKeyState p (PSQ xs) s0 = + PSQ (foldr (\ (k, v) r s -> case p s k v of + (w, n) -> (k, w) : (r n)) + (const []) xs s0) + +delete :: Eq k => k -> PSQ k a -> PSQ k a +delete k (PSQ xs) = PSQ (snd (partition ((== k) . fst) xs)) + +fromList :: [(k, a)] -> PSQ k a +fromList = PSQ + +cons :: k -> a -> PSQ k a -> PSQ k a +cons k x (PSQ xs) = PSQ ((k, x) : xs) + +snoc :: PSQ k a -> k -> a -> PSQ k a +snoc (PSQ xs) k x = PSQ (xs ++ [(k, x)]) + +casePSQ :: PSQ k a -> r -> (k -> a -> PSQ k a -> r) -> r +casePSQ (PSQ xs) n c = + case xs of + [] -> n + (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))) + +sortBy :: (a -> a -> Ordering) -> PSQ k a -> PSQ k a +sortBy cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` snd) xs) + +sortByKeys :: (k -> k -> Ordering) -> PSQ k a -> PSQ k a +sortByKeys cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` fst) xs) + +filterKeys :: (k -> Bool) -> PSQ k a -> PSQ k a +filterKeys p (PSQ xs) = PSQ (S.filter (p . fst) xs) + +filter :: (a -> Bool) -> PSQ k a -> PSQ k a +filter p (PSQ xs) = PSQ (S.filter (p . snd) xs) + +length :: PSQ k a -> Int +length (PSQ xs) = S.length xs + +-- | "Lazy length". +-- +-- Only approximates the length, but doesn't force the list. +llength :: PSQ k a -> Int +llength (PSQ []) = 0 +llength (PSQ (_:[])) = 1 +llength (PSQ (_:_:[])) = 2 +llength (PSQ _) = 3 + +null :: PSQ k a -> Bool +null (PSQ xs) = S.null xs + +toList :: PSQ k a -> [(k, a)] +toList (PSQ xs) = xs diff --git a/Distribution/Client/Dependency/Modular/Package.hs b/Distribution/Client/Dependency/Modular/Package.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/Modular/Package.hs @@ -0,0 +1,113 @@ +module Distribution.Client.Dependency.Modular.Package + (module Distribution.Client.Dependency.Modular.Package, + module Distribution.Package) where + +import Data.List as L +import Data.Map as M + +import Distribution.Package -- from Cabal +import Distribution.Text -- from Cabal + +import Distribution.Client.Dependency.Modular.Version + +-- | A package name. +type PN = PackageName + +-- | Unpacking a package name. +unPN :: PN -> String +unPN (PackageName pn) = pn + +-- | Package version. A package name plus a version number. +type PV = PackageId + +-- | Qualified package version. +type QPV = Q PV + +-- | Package id. Currently just a black-box string. +type PId = InstalledPackageId + +-- | Location. Info about whether a package is installed or not, and where +-- exactly it is located. For installed packages, uniquely identifies the +-- package instance via its 'PId'. +-- +-- TODO: More information is needed about the repo. +data Loc = Inst PId | InRepo + deriving (Eq, Ord, Show) + +-- | Instance. A version number and a location. +data I = I Ver Loc + deriving (Eq, Ord, Show) + +-- | String representation of an instance. +showI :: I -> String +showI (I v InRepo) = showVer v +showI (I v (Inst (InstalledPackageId i))) = showVer v ++ "/installed" ++ shortId i + where + -- A hack to extract the beginning of the package ABI hash + shortId = snip (splitAt 4) (++ "...") . + snip ((\ (x, y) -> (reverse x, y)) . break (=='-') . reverse) ('-':) + snip p f xs = case p xs of + (ys, zs) -> (if L.null zs then id else f) ys + +-- | Package instance. A package name and an instance. +data PI qpn = PI qpn I + deriving (Eq, Ord, Show) + +-- | String representation of a package instance. +showPI :: PI QPN -> String +showPI (PI qpn i) = showQPN qpn ++ "-" ++ showI i + +-- | Checks if a package instance corresponds to an installed package. +instPI :: PI qpn -> Bool +instPI (PI _ (I _ (Inst _))) = True +instPI _ = False + +instI :: I -> Bool +instI (I _ (Inst _)) = True +instI _ = False + +instance Functor PI where + fmap f (PI x y) = PI (f x) y + +-- | Package path. (Stored in "reverse" order.) +type PP = [PN] + +-- | String representation of a package path. +showPP :: PP -> String +showPP = intercalate "." . L.map display . reverse + + +-- | A qualified entity. Pairs a package path with the entity. +data Q a = Q PP a + deriving (Eq, Ord, Show) + +-- | Standard string representation of a qualified entity. +showQ :: (a -> String) -> (Q a -> String) +showQ showa (Q [] x) = showa x +showQ showa (Q pp x) = showPP pp ++ "." ++ showa x + +-- | Qualified package name. +type QPN = Q PN + +-- | String representation of a qualified package path. +showQPN :: QPN -> String +showQPN = showQ display + +-- | The scope associates every package with a path. The convention is that packages +-- not in the data structure have an empty path associated with them. +type Scope = Map PN PP + +-- | An empty scope structure, for initialization. +emptyScope :: Scope +emptyScope = M.empty + +-- | Create artificial parents for each of the package names, making +-- them all independent. +makeIndependent :: [PN] -> Scope +makeIndependent ps = L.foldl (\ sc (n, p) -> M.insert p [PackageName (show n)] sc) emptyScope (zip ([0..] :: [Int]) ps) + +qualify :: Scope -> PN -> QPN +qualify sc pn = Q (findWithDefault [] pn sc) pn + +unQualify :: Q a -> a +unQualify (Q _ x) = x diff --git a/Distribution/Client/Dependency/Modular/Preference.hs b/Distribution/Client/Dependency/Modular/Preference.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/Modular/Preference.hs @@ -0,0 +1,258 @@ +module Distribution.Client.Dependency.Modular.Preference where + +-- Reordering or pruning the tree in order to prefer or make certain choices. + +import qualified Data.List as L +import qualified Data.Map as M +import Data.Monoid +import Data.Ord + +import Distribution.Client.Dependency.Types + ( PackageConstraint(..), PackagePreferences(..), InstalledPreference(..) ) +import Distribution.Client.Types + ( OptionalStanza(..) ) + +import Distribution.Client.Dependency.Modular.Dependency +import Distribution.Client.Dependency.Modular.Flag +import Distribution.Client.Dependency.Modular.Package +import Distribution.Client.Dependency.Modular.PSQ as P +import Distribution.Client.Dependency.Modular.Tree +import Distribution.Client.Dependency.Modular.Version + +-- | Generic abstraction for strategies that just rearrange the package order. +-- Only packages that match the given predicate are reordered. +packageOrderFor :: (PN -> Bool) -> (PN -> I -> I -> Ordering) -> Tree a -> Tree a +packageOrderFor p cmp = trav go + where + go (PChoiceF v@(Q _ pn) r cs) + | p pn = PChoiceF v r (P.sortByKeys (flip (cmp pn)) cs) + | otherwise = PChoiceF v r cs + go x = x + +-- | Ordering that treats preferred versions as greater than non-preferred +-- versions. +preferredVersionsOrdering :: VR -> Ver -> Ver -> Ordering +preferredVersionsOrdering vr v1 v2 = + compare (checkVR vr v1) (checkVR vr v2) + +-- | Traversal that tries to establish package preferences (not constraints). +-- Works by reordering choice nodes. +preferPackagePreferences :: (PN -> PackagePreferences) -> Tree a -> Tree a +preferPackagePreferences pcs = packageOrderFor (const True) preference + where + preference pn i1@(I v1 _) i2@(I v2 _) = + let PackagePreferences vr ipref = pcs pn + in preferredVersionsOrdering vr v1 v2 `mappend` -- combines lexically + locationsOrdering ipref i1 i2 + + -- Note that we always rank installed before uninstalled, and later + -- versions before earlier, but we can change the priority of the + -- two orderings. + locationsOrdering PreferInstalled v1 v2 = + preferInstalledOrdering v1 v2 `mappend` preferLatestOrdering v1 v2 + locationsOrdering PreferLatest v1 v2 = + preferLatestOrdering v1 v2 `mappend` preferInstalledOrdering v1 v2 + +-- | Ordering that treats installed instances as greater than uninstalled ones. +preferInstalledOrdering :: I -> I -> Ordering +preferInstalledOrdering (I _ (Inst _)) (I _ (Inst _)) = EQ +preferInstalledOrdering (I _ (Inst _)) _ = GT +preferInstalledOrdering _ (I _ (Inst _)) = LT +preferInstalledOrdering _ _ = EQ + +-- | Compare instances by their version numbers. +preferLatestOrdering :: I -> I -> Ordering +preferLatestOrdering (I v1 _) (I v2 _) = compare v1 v2 + +-- | Helper function that tries to enforce a single package constraint on a +-- given instance for a P-node. Translates the constraint into a +-- tree-transformer that either leaves the subtree untouched, or replaces it +-- with an appropriate failure node. +processPackageConstraintP :: ConflictSet QPN -> I -> PackageConstraint -> Tree a -> Tree a +processPackageConstraintP c (I v _) (PackageConstraintVersion _ vr) r + | checkVR vr v = r + | otherwise = Fail c (GlobalConstraintVersion vr) +processPackageConstraintP c i (PackageConstraintInstalled _) r + | instI i = r + | otherwise = Fail c GlobalConstraintInstalled +processPackageConstraintP c i (PackageConstraintSource _) r + | not (instI i) = r + | otherwise = Fail c GlobalConstraintSource +processPackageConstraintP _ _ _ r = r + +-- | Helper function that tries to enforce a single package constraint on a +-- given flag setting for an F-node. Translates the constraint into a +-- tree-transformer that either leaves the subtree untouched, or replaces it +-- with an appropriate failure node. +processPackageConstraintF :: Flag -> ConflictSet QPN -> Bool -> PackageConstraint -> Tree a -> Tree a +processPackageConstraintF f c b' (PackageConstraintFlags _ fa) r = + case L.lookup f fa of + Nothing -> r + Just b | b == b' -> r + | otherwise -> Fail c GlobalConstraintFlag +processPackageConstraintF _ _ _ _ r = r + +-- | Helper function that tries to enforce a single package constraint on a +-- given flag setting for an F-node. Translates the constraint into a +-- tree-transformer that either leaves the subtree untouched, or replaces it +-- with an appropriate failure node. +processPackageConstraintS :: OptionalStanza -> ConflictSet QPN -> Bool -> PackageConstraint -> Tree a -> Tree a +processPackageConstraintS s c b' (PackageConstraintStanzas _ ss) r = + if not b' && s `elem` ss then Fail c GlobalConstraintFlag + else r +processPackageConstraintS _ _ _ _ r = r + +-- | 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 pcs = trav go + where + go (PChoiceF qpn@(Q _ pn) gr ts) = + let c = toConflictSet (Goal (P qpn) gr) + -- compose the transformation functions for each of the relevant constraint + g = \ i -> foldl (\ h pc -> h . processPackageConstraintP c i pc) id + (M.findWithDefault [] pn pcs) + in PChoiceF qpn gr (P.mapWithKey g ts) + go (FChoiceF qfn@(FN (PI (Q _ pn) _) f) gr tr ts) = + let c = toConflictSet (Goal (F qfn) gr) + -- compose the transformation functions for each of the relevant constraint + g = \ b -> foldl (\ h pc -> h . processPackageConstraintF f c b pc) id + (M.findWithDefault [] pn pcs) + in FChoiceF qfn gr tr (P.mapWithKey g ts) + go (SChoiceF qsn@(SN (PI (Q _ pn) _) f) gr tr ts) = + let c = toConflictSet (Goal (S qsn) gr) + -- compose the transformation functions for each of the relevant constraint + g = \ b -> foldl (\ h pc -> h . processPackageConstraintS f c b pc) id + (M.findWithDefault [] pn pcs) + in SChoiceF qsn gr tr (P.mapWithKey g ts) + go x = x + +-- | Prefer installed packages over non-installed packages, generally. +-- All installed packages or non-installed packages are treated as +-- equivalent. +preferInstalled :: Tree a -> Tree a +preferInstalled = packageOrderFor (const True) (const preferInstalledOrdering) + +-- | Prefer packages with higher version numbers over packages with +-- lower version numbers, for certain packages. +preferLatestFor :: (PN -> Bool) -> Tree a -> Tree a +preferLatestFor p = packageOrderFor p (const preferLatestOrdering) + +-- | Prefer packages with higher version numbers over packages with +-- lower version numbers, for all packages. +preferLatest :: Tree a -> Tree a +preferLatest = preferLatestFor (const True) + +-- | Require installed packages. +requireInstalled :: (PN -> Bool) -> Tree (QGoalReasons, a) -> Tree (QGoalReasons, a) +requireInstalled p = trav go + where + go (PChoiceF v@(Q _ pn) i@(gr, _) cs) + | p pn = PChoiceF v i (P.mapWithKey installed cs) + | otherwise = PChoiceF v i cs + where + installed (I _ (Inst _)) x = x + installed _ _ = Fail (toConflictSet (Goal (P v) gr)) CannotInstall + go x = x + +-- | Avoid reinstalls. +-- +-- This is a tricky strategy. If a package version is installed already and the +-- same version is available from a repo, the repo version will never be chosen. +-- This would result in a reinstall (either destructively, or potentially, +-- shadowing). The old instance won't be visible or even present anymore, but +-- other packages might have depended on it. +-- +-- TODO: It would be better to actually check the reverse dependencies of installed +-- packages. If they're not depended on, then reinstalling should be fine. Even if +-- 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 p = trav go + where + go (PChoiceF qpn@(Q _ pn) i@(gr, _) cs) + | p pn = PChoiceF qpn i disableReinstalls + | otherwise = PChoiceF qpn i cs + where + disableReinstalls = + let installed = [ v | (I v (Inst _), _) <- toList cs ] + in P.mapWithKey (notReinstall installed) cs + + notReinstall vs (I v InRepo) _ + | v `elem` vs = Fail (toConflictSet (Goal (P qpn) gr)) CannotReinstall + notReinstall _ _ x = x + go x = x + +-- | Always choose the first goal in the list next, abandoning all +-- other choices. +-- +-- This is unnecessary for the default search strategy, because +-- it descends only into the first goal choice anyway, +-- but may still make sense to just reduce the tree size a bit. +firstGoal :: Tree a -> Tree a +firstGoal = trav go + where + go (GoalChoiceF xs) = casePSQ xs (GoalChoiceF xs) (\ _ t _ -> out t) + go x = x + -- Note that we keep empty choice nodes, because they mean success. + +-- | Transformation that tries to make a decision on base as early as +-- possible. In nearly all cases, there's a single choice for the base +-- package. Also, fixing base early should lead to better error messages. +preferBaseGoalChoice :: Tree a -> Tree a +preferBaseGoalChoice = trav go + where + go (GoalChoiceF xs) = GoalChoiceF (P.sortByKeys preferBase xs) + go x = x + + preferBase :: OpenGoal -> OpenGoal -> Ordering + preferBase (OpenGoal (Simple (Dep (Q [] pn) _)) _) _ | unPN pn == "base" = LT + preferBase _ (OpenGoal (Simple (Dep (Q [] pn) _)) _) | unPN pn == "base" = GT + preferBase _ _ = EQ + +-- | Transformation that sorts choice nodes so that +-- child nodes with a small branching degree are preferred. As a +-- special case, choices with 0 branches will be preferred (as they +-- are immediately considered inconsistent), and choices with 1 +-- branch will also be preferred (as they don't involve choice). +preferEasyGoalChoices :: Tree a -> Tree a +preferEasyGoalChoices = trav go + where + go (GoalChoiceF xs) = GoalChoiceF (P.sortBy (comparing choices) xs) + go x = x + +-- | Transformation that tries to avoid making inconsequential +-- flag choices early. +deferDefaultFlagChoices :: Tree a -> Tree a +deferDefaultFlagChoices = trav go + where + go (GoalChoiceF xs) = GoalChoiceF (P.sortBy defer xs) + go x = x + + defer :: Tree a -> Tree a -> Ordering + defer (FChoice _ _ True _) _ = GT + defer _ (FChoice _ _ True _) = LT + defer _ _ = EQ + +-- | Variant of 'preferEasyGoalChoices'. +-- +-- Only approximates the number of choices in the branches. Less accurate, +-- more efficient. +lpreferEasyGoalChoices :: Tree a -> Tree a +lpreferEasyGoalChoices = trav go + where + go (GoalChoiceF xs) = GoalChoiceF (P.sortBy (comparing lchoices) xs) + go x = x + +-- | Variant of 'preferEasyGoalChoices'. +-- +-- I first thought that using a paramorphism might be faster here, +-- but it doesn't seem to make any difference. +preferEasyGoalChoices' :: Tree a -> Tree a +preferEasyGoalChoices' = para (inn . go) + where + go (GoalChoiceF xs) = GoalChoiceF (P.map fst (P.sortBy (comparing (choices . snd)) xs)) + go x = fmap fst x + diff --git a/Distribution/Client/Dependency/Modular/Solver.hs b/Distribution/Client/Dependency/Modular/Solver.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/Modular/Solver.hs @@ -0,0 +1,52 @@ +module Distribution.Client.Dependency.Modular.Solver where + +import Data.Map as M + +import Distribution.Client.Dependency.Types + +import Distribution.Client.Dependency.Modular.Assignment +import Distribution.Client.Dependency.Modular.Builder +import Distribution.Client.Dependency.Modular.Dependency +import Distribution.Client.Dependency.Modular.Explore +import Distribution.Client.Dependency.Modular.Index +import Distribution.Client.Dependency.Modular.Log +import Distribution.Client.Dependency.Modular.Message +import Distribution.Client.Dependency.Modular.Package +import qualified Distribution.Client.Dependency.Modular.Preference as P +import Distribution.Client.Dependency.Modular.Validate + +-- | Various options for the modular solver. +data SolverConfig = SolverConfig { + preferEasyGoalChoices :: Bool, + independentGoals :: Bool, + avoidReinstalls :: Bool, + shadowPkgs :: Bool, + maxBackjumps :: Maybe Int +} + +solve :: SolverConfig -> -- solver parameters + Index -> -- all available packages as an index + (PN -> PackagePreferences) -> -- preferences + Map PN [PackageConstraint] -> -- global constraints + [PN] -> -- global goals + Log Message (Assignment, RevDepMap) +solve sc idx userPrefs userConstraints userGoals = + explorePhase $ + heuristicsPhase $ + preferencesPhase $ + validationPhase $ + prunePhase $ + buildPhase + where + explorePhase = exploreTreeLog . backjump + heuristicsPhase = if preferEasyGoalChoices sc + then P.preferBaseGoalChoice . P.deferDefaultFlagChoices . P.lpreferEasyGoalChoices + else P.preferBaseGoalChoice + preferencesPhase = P.preferPackagePreferences userPrefs + validationPhase = P.enforcePackageConstraints userConstraints . + validateTree idx + prunePhase = (if avoidReinstalls sc then P.avoidReinstalls (const True) else id) . + -- packages that can never be "upgraded": + P.requireInstalled (`elem` [PackageName "base", + PackageName "ghc-prim"]) + buildPhase = buildTree idx (independentGoals sc) userGoals diff --git a/Distribution/Client/Dependency/Modular/Tree.hs b/Distribution/Client/Dependency/Modular/Tree.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/Modular/Tree.hs @@ -0,0 +1,146 @@ +module Distribution.Client.Dependency.Modular.Tree where + +import Control.Applicative +import Control.Monad hiding (mapM) +import Data.Foldable +import Data.Traversable +import Prelude hiding (foldr, mapM) + +import Distribution.Client.Dependency.Modular.Dependency +import Distribution.Client.Dependency.Modular.Flag +import Distribution.Client.Dependency.Modular.Package +import Distribution.Client.Dependency.Modular.PSQ as P +import Distribution.Client.Dependency.Modular.Version + +-- | Type of the search tree. Inlining the choice nodes for now. +data Tree a = + PChoice QPN a (PSQ I (Tree a)) + | FChoice QFN a Bool (PSQ Bool (Tree a)) -- Bool indicates whether it's trivial + | SChoice QSN a Bool (PSQ Bool (Tree a)) -- Bool indicates whether it's trivial + | GoalChoice (PSQ OpenGoal (Tree a)) -- PSQ should never be empty + | Done RevDepMap + | Fail (ConflictSet QPN) FailReason + deriving (Eq, Show) + -- Above, a choice is called trivial if it clearly does not matter. The + -- special case of triviality we actually consider is if there are no new + -- dependencies introduced by this node. + +instance Functor Tree where + fmap f (PChoice qpn i xs) = PChoice qpn (f i) (fmap (fmap f) xs) + fmap f (FChoice qfn i b xs) = FChoice qfn (f i) b (fmap (fmap f) xs) + fmap f (SChoice qsn i b xs) = SChoice qsn (f i) b (fmap (fmap f) xs) + fmap f (GoalChoice xs) = GoalChoice (fmap (fmap f) xs) + fmap _f (Done rdm ) = Done rdm + fmap _f (Fail cs fr ) = Fail cs fr + +data FailReason = InconsistentInitialConstraints + | Conflicting [Dep QPN] + | CannotInstall + | CannotReinstall + | Shadowed + | Broken + | GlobalConstraintVersion VR + | GlobalConstraintInstalled + | GlobalConstraintSource + | GlobalConstraintFlag + | BuildFailureNotInIndex PN + | MalformedFlagChoice QFN + | MalformedStanzaChoice QSN + | EmptyGoalChoice + | Backjump + deriving (Eq, Show) + +-- | Functor for the tree type. +data TreeF a b = + PChoiceF QPN a (PSQ I b) + | FChoiceF QFN a Bool (PSQ Bool b) + | SChoiceF QSN a Bool (PSQ Bool b) + | GoalChoiceF (PSQ OpenGoal b) + | DoneF RevDepMap + | FailF (ConflictSet QPN) FailReason + +out :: Tree a -> TreeF a (Tree a) +out (PChoice p i ts) = PChoiceF p i ts +out (FChoice p i b ts) = FChoiceF p i b ts +out (SChoice p i b ts) = SChoiceF p i b ts +out (GoalChoice ts) = GoalChoiceF ts +out (Done x ) = DoneF x +out (Fail c x ) = FailF c x + +inn :: TreeF a (Tree a) -> Tree a +inn (PChoiceF p i ts) = PChoice p i ts +inn (FChoiceF p i b ts) = FChoice p i b ts +inn (SChoiceF p i b ts) = SChoice p i b ts +inn (GoalChoiceF ts) = GoalChoice ts +inn (DoneF x ) = Done x +inn (FailF c x ) = Fail c x + +instance Functor (TreeF a) where + fmap f (PChoiceF p i ts) = PChoiceF p i (fmap f ts) + fmap f (FChoiceF p i b ts) = FChoiceF p i b (fmap f ts) + fmap f (SChoiceF p i b ts) = SChoiceF p i b (fmap f ts) + fmap f (GoalChoiceF ts) = GoalChoiceF (fmap f ts) + fmap _ (DoneF x ) = DoneF x + fmap _ (FailF c x ) = FailF c x + +instance Foldable (TreeF a) where + foldr op e (PChoiceF _ _ ts) = foldr op e ts + foldr op e (FChoiceF _ _ _ ts) = foldr op e ts + foldr op e (SChoiceF _ _ _ ts) = foldr op e ts + foldr op e (GoalChoiceF ts) = foldr op e ts + foldr _ e (DoneF _ ) = e + foldr _ e (FailF _ _ ) = e + +instance Traversable (TreeF a) where + traverse f (PChoiceF p i ts) = PChoiceF <$> pure p <*> pure i <*> traverse f ts + traverse f (FChoiceF p i b ts) = FChoiceF <$> pure p <*> pure i <*> pure b <*> traverse f ts + traverse f (SChoiceF p i b ts) = SChoiceF <$> pure p <*> pure i <*> pure b <*> traverse f ts + traverse f (GoalChoiceF ts) = GoalChoiceF <$> traverse f ts + traverse _ (DoneF x ) = DoneF <$> pure x + traverse _ (FailF c x ) = FailF <$> pure c <*> pure x + +-- | Determines whether a tree is active, i.e., isn't a failure node. +active :: Tree a -> Bool +active (Fail _ _) = False +active _ = True + +-- | Determines how many active choices are available in a node. Note that we +-- count goal choices as having one choice, always. +choices :: Tree a -> Int +choices (PChoice _ _ ts) = P.length (P.filter active ts) +choices (FChoice _ _ _ ts) = P.length (P.filter active ts) +choices (SChoice _ _ _ ts) = P.length (P.filter active ts) +choices (GoalChoice _ ) = 1 +choices (Done _ ) = 1 +choices (Fail _ _ ) = 0 + +-- | Variant of 'choices' that only approximates the number of choices, +-- using 'llength'. +lchoices :: Tree a -> Int +lchoices (PChoice _ _ ts) = P.llength (P.filter active ts) +lchoices (FChoice _ _ _ ts) = P.llength (P.filter active ts) +lchoices (SChoice _ _ _ ts) = P.llength (P.filter active ts) +lchoices (GoalChoice _ ) = 1 +lchoices (Done _ ) = 1 +lchoices (Fail _ _ ) = 0 + +-- | Catamorphism on trees. +cata :: (TreeF a b -> b) -> Tree a -> b +cata phi x = (phi . fmap (cata phi) . out) x + +trav :: (TreeF a (Tree b) -> TreeF b (Tree b)) -> Tree a -> Tree b +trav psi x = cata (inn . psi) x + +-- | Paramorphism on trees. +para :: (TreeF a (b, Tree a) -> b) -> Tree a -> b +para phi = phi . fmap (\ x -> (para phi x, x)) . out + +cataM :: Monad m => (TreeF a b -> m b) -> Tree a -> m b +cataM phi = phi <=< mapM (cataM phi) <=< return . out + +-- | Anamorphism on trees. +ana :: (b -> TreeF a b) -> b -> Tree a +ana psi = inn . fmap (ana psi) . psi + +anaM :: Monad m => (b -> m (TreeF a b)) -> b -> m (Tree a) +anaM psi = return . inn <=< mapM (anaM psi) <=< psi diff --git a/Distribution/Client/Dependency/Modular/Validate.hs b/Distribution/Client/Dependency/Modular/Validate.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/Modular/Validate.hs @@ -0,0 +1,232 @@ +module Distribution.Client.Dependency.Modular.Validate where + +-- Validation of the tree. +-- +-- The task here is to make sure all constraints hold. After validation, any +-- assignment returned by exploration of the tree should be a complete valid +-- assignment, i.e., actually constitute a solution. + +import Control.Applicative +import Control.Monad.Reader hiding (sequence) +import Data.List as L +import Data.Map as M +import Data.Traversable +import Prelude hiding (sequence) + +import Distribution.Client.Dependency.Modular.Assignment +import Distribution.Client.Dependency.Modular.Dependency +import Distribution.Client.Dependency.Modular.Flag +import Distribution.Client.Dependency.Modular.Index +import Distribution.Client.Dependency.Modular.Package +import Distribution.Client.Dependency.Modular.PSQ as P +import Distribution.Client.Dependency.Modular.Tree + +-- In practice, most constraints are implication constraints (IF we have made +-- a number of choices, THEN we also have to ensure that). We call constraints +-- that for which the precondiditions are fulfilled ACTIVE. We maintain a set +-- of currently active constraints that we pass down the node. +-- +-- We aim at detecting inconsistent states as early as possible. +-- +-- Whenever we make a choice, there are two things that need to happen: +-- +-- (1) We must check that the choice is consistent with the currently +-- active constraints. +-- +-- (2) The choice increases the set of active constraints. For the new +-- active constraints, we must check that they are consistent with +-- the current state. +-- +-- We can actually merge (1) and (2) by saying the the current choice is +-- a new active constraint, fixing the choice. +-- +-- If a test fails, we have detected an inconsistent state. We can +-- disable the current subtree and do not have to traverse it any further. +-- +-- We need a good way to represent the current state, i.e., the current +-- set of active constraints. Since the main situation where we have to +-- search in it is (1), it seems best to store the state by package: for +-- every package, we store which versions are still allowed. If for any +-- package, we have inconsistent active constraints, we can also stop. +-- This is a particular way to read task (2): +-- +-- (2, weak) We only check if the new constraints are consistent with +-- the choices we've already made, and add them to the active set. +-- +-- (2, strong) We check if the new constraints are consistent with the +-- choices we've already made, and the constraints we already have. +-- +-- It currently seems as if we're implementing the weak variant. However, +-- when used together with 'preferEasyGoalChoices', we will find an +-- inconsistent state in the very next step. +-- +-- What do we do about flags? +-- +-- Like for packages, we store the flag choices we have already made. +-- Now, regarding (1), we only have to test whether we've decided the +-- current flag before. Regarding (2), the interesting bit is in discovering +-- the new active constraints. To this end, we look up the constraints for +-- the package the flag belongs to, and traverse its flagged dependencies. +-- Wherever we find the flag in question, we start recording dependencies +-- underneath as new active dependencies. If we encounter other flags, we +-- check if we've chosen them already and either proceed or stop. + +-- | The state needed during validation. +data ValidateState = VS { + index :: Index, + saved :: Map QPN (FlaggedDeps QPN), -- saved, scoped, dependencies + pa :: PreAssignment +} + +type Validate = Reader ValidateState + +validate :: Tree (QGoalReasons, Scope) -> Validate (Tree QGoalReasons) +validate = cata go + where + go :: TreeF (QGoalReasons, Scope) (Validate (Tree QGoalReasons)) -> Validate (Tree QGoalReasons) + + go (PChoiceF qpn (gr, sc) ts) = PChoice qpn gr <$> sequence (P.mapWithKey (goP qpn gr sc) ts) + go (FChoiceF qfn (gr, _sc) b ts) = + do + -- Flag choices may occur repeatedly (because they can introduce new constraints + -- in various places). However, subsequent choices must be consistent. We thereby + -- collapse repeated flag choice nodes. + PA _ pfa _ <- asks pa -- obtain current flag-preassignment + case M.lookup qfn pfa of + Just rb -> -- flag has already been assigned; collapse choice to the correct branch + case P.lookup rb ts of + Just t -> goF qfn gr rb t + Nothing -> return $ Fail (toConflictSet (Goal (F qfn) gr)) (MalformedFlagChoice qfn) + Nothing -> -- flag choice is new, follow both branches + FChoice qfn gr b <$> sequence (P.mapWithKey (goF qfn gr) ts) + go (SChoiceF qsn (gr, _sc) b ts) = + do + -- Optional stanza choices are very similar to flag choices. + PA _ _ psa <- asks pa -- obtain current stanza-preassignment + case M.lookup qsn psa of + Just rb -> -- stanza choice has already been made; collapse choice to the correct branch + case P.lookup rb ts of + Just t -> goS qsn gr rb t + Nothing -> return $ Fail (toConflictSet (Goal (S qsn) gr)) (MalformedStanzaChoice qsn) + Nothing -> -- stanza choice is new, follow both branches + SChoice qsn gr b <$> sequence (P.mapWithKey (goS qsn gr) ts) + + -- We don't need to do anything for goal choices or failure nodes. + go (GoalChoiceF ts) = GoalChoice <$> sequence ts + go (DoneF rdm ) = pure (Done rdm) + 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@(Q _pp pn) gr sc i r = do + PA ppa pfa psa <- asks pa -- obtain current preassignment + idx <- asks index -- obtain the index + svd <- asks saved -- obtain saved dependencies + let (PInfo deps _ _ mfr) = idx ! pn ! i -- obtain dependencies and index-dictated exclusions introduced by the choice + let qdeps = L.map (fmap (qualify sc)) deps -- qualify the deps in the current scope + -- the new active constraints are given by the instance we have chosen, + -- plus the dependency information we have for that instance + let goal = Goal (P qpn) gr + let newactives = Dep qpn (Fixed i goal) : L.map (resetGoal goal) (extractDeps pfa psa qdeps) + -- We now try to extend the partial assignment with the new active constraints. + let mnppa = extend (P qpn) ppa newactives + -- In case we continue, we save the scoped dependencies + let nsvd = M.insert qpn qdeps svd + case mfr of + Just fr -> -- The index marks this as an invalid choice. We can stop. + return (Fail (toConflictSet goal) fr) + _ -> case mnppa of + Left (c, d) -> -- We have an inconsistency. We can stop. + return (Fail c (Conflicting d)) + Right nppa -> -- We have an updated partial assignment for the recursive validation. + 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@(FN (PI qpn _i) _f) gr b r = do + PA ppa pfa psa <- asks pa -- obtain current preassignment + svd <- asks saved -- obtain saved dependencies + -- Note that there should be saved dependencies for the package in question, + -- because while building, we do not choose flags before we see the packages + -- that define them. + let qdeps = svd ! qpn + -- We take the *saved* dependencies, because these have been qualified in the + -- correct scope. + -- + -- Extend the flag assignment + let npfa = M.insert qfn b pfa + -- We now try to get the new active dependencies we might learn about because + -- we have chosen a new flag. + let newactives = extractNewDeps (F qfn) gr b npfa psa qdeps + -- As in the package case, we try to extend the partial assignment. + case extend (F qfn) ppa newactives of + Left (c, d) -> return (Fail c (Conflicting d)) -- inconsistency found + 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@(SN (PI qpn _i) _f) gr b r = do + PA ppa pfa psa <- asks pa -- obtain current preassignment + svd <- asks saved -- obtain saved dependencies + -- Note that there should be saved dependencies for the package in question, + -- because while building, we do not choose flags before we see the packages + -- that define them. + let qdeps = svd ! qpn + -- We take the *saved* dependencies, because these have been qualified in the + -- correct scope. + -- + -- Extend the flag assignment + let npsa = M.insert qsn b psa + -- We now try to get the new active dependencies we might learn about because + -- we have chosen a new flag. + let newactives = extractNewDeps (S qsn) gr b pfa npsa qdeps + -- As in the package case, we try to extend the partial assignment. + case extend (S qsn) ppa newactives of + Left (c, d) -> return (Fail c (Conflicting d)) -- inconsistency found + Right nppa -> local (\ s -> s { pa = PA nppa pfa npsa }) r + +-- | We try to extract as many concrete dependencies from the given flagged +-- dependencies as possible. We make use of all the flag knowledge we have +-- already acquired. +extractDeps :: FAssignment -> SAssignment -> FlaggedDeps QPN -> [Dep QPN] +extractDeps fa sa deps = do + d <- deps + case d of + Simple sd -> return sd + Flagged qfn _ td fd -> case M.lookup qfn fa of + Nothing -> mzero + Just True -> extractDeps fa sa td + Just False -> extractDeps fa sa fd + Stanza qsn td -> case M.lookup qsn sa of + Nothing -> mzero + Just True -> extractDeps fa sa td + Just False -> [] + +-- | 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 v gr b fa sa = go + where + go deps = do + d <- deps + case d of + Simple _ -> mzero + Flagged qfn' _ td fd + | v == F qfn' -> L.map (resetGoal (Goal v gr)) $ + if b then extractDeps fa sa td else extractDeps fa sa fd + | otherwise -> case M.lookup qfn' fa of + Nothing -> mzero + Just True -> go td + Just False -> go fd + Stanza qsn' td + | v == S qsn' -> L.map (resetGoal (Goal v gr)) $ + if b then extractDeps fa sa td else [] + | otherwise -> case M.lookup qsn' sa of + Nothing -> mzero + Just True -> go td + Just False -> [] + +-- | Interface. +validateTree :: Index -> Tree (QGoalReasons, Scope) -> Tree QGoalReasons +validateTree idx t = runReader (validate t) (VS idx M.empty (PA M.empty M.empty M.empty)) diff --git a/Distribution/Client/Dependency/Modular/Version.hs b/Distribution/Client/Dependency/Modular/Version.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/Modular/Version.hs @@ -0,0 +1,43 @@ +module Distribution.Client.Dependency.Modular.Version where + +import qualified Distribution.Version as CV -- from Cabal +import Distribution.Text -- from Cabal + +-- | Preliminary type for versions. +type Ver = CV.Version + +-- | String representation of a version. +showVer :: Ver -> String +showVer = display + +-- | Version range. Consists of a lower and upper bound. +type VR = CV.VersionRange + +-- | String representation of a version range. +showVR :: VR -> String +showVR = display + +-- | Unconstrained version range. +anyVR :: VR +anyVR = CV.anyVersion + +-- | Version range fixing a single version. +eqVR :: Ver -> VR +eqVR = CV.thisVersion + +-- | Intersect two version ranges. +(.&&.) :: VR -> VR -> VR +(.&&.) = CV.intersectVersionRanges + +-- | Simplify a version range. +simplifyVR :: VR -> VR +simplifyVR = CV.simplifyVersionRange + +-- | Checking a version against a version range. +checkVR :: VR -> Ver -> Bool +checkVR = flip CV.withinRange + +-- | Make a version number. +mkV :: [Int] -> Ver +mkV xs = CV.Version xs [] + diff --git a/Distribution/Client/Dependency/TopDown.hs b/Distribution/Client/Dependency/TopDown.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/TopDown.hs @@ -0,0 +1,776 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Dependency.Types +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Common types for dependency resolution. +----------------------------------------------------------------------------- +module Distribution.Client.Dependency.TopDown ( + topDownResolver + ) where + +import Distribution.Client.Dependency.TopDown.Types +import qualified Distribution.Client.Dependency.TopDown.Constraints as Constraints +import Distribution.Client.Dependency.TopDown.Constraints + ( Satisfiable(..) ) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.InstallPlan + ( PlanPackage(..) ) +import Distribution.Client.Types + ( AvailablePackage(..), ConfiguredPackage(..), InstalledPackage(..) ) +import Distribution.Client.Dependency.Types + ( DependencyResolver, PackageConstraint(..) + , PackagePreferences(..), InstalledPreference(..) + , Progress(..), foldProgress ) + +import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Client.PackageIndex (PackageIndex) +import Distribution.Package + ( PackageName(..), PackageIdentifier, Package(packageId), packageVersion, packageName + , Dependency(Dependency), thisPackageVersion, notThisPackageVersion + , PackageFixedDeps(depends) ) +import Distribution.PackageDescription + ( PackageDescription(buildDepends) ) +import Distribution.Client.PackageUtils + ( externalBuildDepends ) +import Distribution.PackageDescription.Configuration + ( finalizePackageDescription, flattenPackageDescription ) +import Distribution.Version + ( VersionRange, anyVersion, withinRange, simplifyVersionRange + , UpperBound(..), asVersionIntervals ) +import Distribution.Compiler + ( CompilerId ) +import Distribution.System + ( Platform ) +import Distribution.Simple.Utils + ( equating, comparing ) +import Distribution.Text + ( display ) + +import Data.List + ( foldl', maximumBy, minimumBy, nub, sort, groupBy ) +import Data.Maybe + ( fromJust, fromMaybe, catMaybes ) +import Data.Monoid + ( Monoid(mempty) ) +import Control.Monad + ( guard ) +import qualified Data.Set as Set +import Data.Set (Set) +import qualified Data.Map as Map +import qualified Data.Graph as Graph +import qualified Data.Array as Array +import Control.Exception + ( assert ) + +-- ------------------------------------------------------------ +-- * Search state types +-- ------------------------------------------------------------ + +type Constraints = Constraints.Constraints + InstalledPackageEx UnconfiguredPackage ExclusionReason +type SelectedPackages = PackageIndex SelectedPackage + +-- ------------------------------------------------------------ +-- * The search tree type +-- ------------------------------------------------------------ + +data SearchSpace inherited pkg + = ChoiceNode inherited [[(pkg, SearchSpace inherited pkg)]] + | Failure Failure + +-- ------------------------------------------------------------ +-- * Traverse a search tree +-- ------------------------------------------------------------ + +explore :: (PackageName -> PackagePreferences) + -> SearchSpace (SelectedPackages, Constraints, SelectionChanges) + SelectablePackage + -> Progress Log Failure (SelectedPackages, Constraints) + +explore _ (Failure failure) = Fail failure +explore _ (ChoiceNode (s,c,_) []) = Done (s,c) +explore pref (ChoiceNode _ choices) = + case [ choice | [choice] <- choices ] of + ((_, node'):_) -> Step (logInfo node') (explore pref node') + [] -> Step (logInfo node') (explore pref node') + where + choice = minimumBy (comparing topSortNumber) choices + pkgname = packageName . fst . head $ choice + (_, node') = maximumBy (bestByPref pkgname) choice + where + topSortNumber choice = case fst (head choice) of + InstalledOnly (InstalledPackageEx _ i _) -> i + AvailableOnly (UnconfiguredPackage _ i _) -> i + InstalledAndAvailable _ (UnconfiguredPackage _ i _) -> i + + bestByPref pkgname = case packageInstalledPreference of + PreferLatest -> + comparing (\(p,_) -> ( isPreferred p, packageId p)) + PreferInstalled -> + comparing (\(p,_) -> (isInstalled p, isPreferred p, packageId p)) + where + isInstalled (AvailableOnly _) = False + isInstalled _ = True + isPreferred p = packageVersion p `withinRange` preferredVersions + (PackagePreferences preferredVersions packageInstalledPreference) + = pref pkgname + + logInfo node = Select selected discarded + where (selected, discarded) = case node of + Failure _ -> ([], []) + ChoiceNode (_,_,changes) _ -> changes + +-- ------------------------------------------------------------ +-- * Generate a search tree +-- ------------------------------------------------------------ + +type ConfigurePackage = PackageIndex SelectablePackage + -> SelectablePackage + -> Either [Dependency] SelectedPackage + +-- | (packages selected, packages discarded) +type SelectionChanges = ([SelectedPackage], [PackageIdentifier]) + +searchSpace :: ConfigurePackage + -> Constraints + -> SelectedPackages + -> SelectionChanges + -> Set PackageName + -> SearchSpace (SelectedPackages, Constraints, SelectionChanges) + SelectablePackage +searchSpace configure constraints selected changes next = + ChoiceNode (selected, constraints, changes) + [ [ (pkg, select name pkg) + | pkg <- PackageIndex.lookupPackageName available name ] + | name <- Set.elems next ] + where + available = Constraints.choices constraints + + select name pkg = case configure available pkg of + Left missing -> Failure $ ConfigureFailed pkg + [ (dep, Constraints.conflicting constraints dep) + | dep <- missing ] + Right pkg' -> case constrainDeps pkg' newDeps constraints [] of + Left failure -> Failure failure + Right (constraints', newDiscarded) -> + searchSpace configure + constraints' selected' (newSelected, newDiscarded) next' + where + selected' = foldl' (flip PackageIndex.insert) selected newSelected + newSelected = + case Constraints.isPaired constraints (packageId pkg) of + Nothing -> [pkg'] + Just pkgid' -> [pkg', pkg''] + where + Just pkg'' = fmap (\(InstalledOnly p) -> InstalledOnly p) + (PackageIndex.lookupPackageId available pkgid') + + newPkgs = [ name' + | dep <- newDeps + , let (Dependency name' _) = untagDependency dep + , null (PackageIndex.lookupPackageName selected' name') ] + newDeps = concatMap packageConstraints newSelected + next' = Set.delete name + $ foldl' (flip Set.insert) next newPkgs + +packageConstraints :: SelectedPackage -> [TaggedDependency] +packageConstraints = either installedConstraints availableConstraints + . preferAvailable + where + preferAvailable (InstalledOnly pkg) = Left pkg + preferAvailable (AvailableOnly pkg) = Right pkg + preferAvailable (InstalledAndAvailable _ pkg) = Right pkg + installedConstraints (InstalledPackageEx _ _ deps) = + [ TaggedDependency InstalledConstraint (thisPackageVersion dep) + | dep <- deps ] + availableConstraints (SemiConfiguredPackage _ _ deps) = + [ TaggedDependency NoInstalledConstraint dep | dep <- deps ] + +constrainDeps :: SelectedPackage -> [TaggedDependency] -> Constraints + -> [PackageIdentifier] + -> Either Failure (Constraints, [PackageIdentifier]) +constrainDeps pkg [] cs discard = + case addPackageSelectConstraint (packageId pkg) cs of + Satisfiable cs' discard' -> Right (cs', discard' ++ discard) + _ -> impossible +constrainDeps pkg (dep:deps) cs discard = + case addPackageDependencyConstraint (packageId pkg) dep cs of + Satisfiable cs' discard' -> constrainDeps pkg deps cs' (discard' ++ discard) + Unsatisfiable -> impossible + ConflictsWith conflicts -> + Left (DependencyConflict pkg dep conflicts) + +-- ------------------------------------------------------------ +-- * The main algorithm +-- ------------------------------------------------------------ + +search :: ConfigurePackage + -> (PackageName -> PackagePreferences) + -> Constraints + -> Set PackageName + -> Progress Log Failure (SelectedPackages, Constraints) +search configure pref constraints = + explore pref . searchSpace configure constraints mempty ([], []) + +-- ------------------------------------------------------------ +-- * The top level resolver +-- ------------------------------------------------------------ + +-- | The main exported resolver, with string logging and failure types to fit +-- the standard 'DependencyResolver' interface. +-- +topDownResolver :: DependencyResolver +topDownResolver = ((((((mapMessages .).).).).).) . topDownResolver' + where + mapMessages :: Progress Log Failure a -> Progress String String a + mapMessages = foldProgress (Step . showLog) (Fail . showFailure) Done + +-- | The native resolver with detailed structured logging and failure types. +-- +topDownResolver' :: Platform -> CompilerId + -> PackageIndex InstalledPackage + -> PackageIndex AvailablePackage + -> (PackageName -> PackagePreferences) + -> [PackageConstraint] + -> [PackageName] + -> Progress Log Failure [PlanPackage] +topDownResolver' platform comp installed available + preferences constraints targets = + fmap (uncurry finalise) + . (\cs -> search configure preferences cs initialPkgNames) + =<< addTopLevelConstraints constraints constraintSet + + where + configure = configurePackage platform comp + constraintSet :: Constraints + constraintSet = Constraints.empty + (annotateInstalledPackages topSortNumber installed') + (annotateAvailablePackages constraints topSortNumber available') + (installed', available') = selectNeededSubset installed available + initialPkgNames + topSortNumber = topologicalSortNumbering installed' available' + + initialPkgNames = Set.fromList targets + + finalise selected' constraints' = + PackageIndex.allPackages + . fst . improvePlan installed' constraints' + . PackageIndex.fromList + $ finaliseSelectedPackages preferences selected' constraints' + +addTopLevelConstraints :: [PackageConstraint] -> Constraints + -> Progress a Failure Constraints +addTopLevelConstraints [] cs = Done cs +addTopLevelConstraints (PackageFlagsConstraint _ _ :deps) cs = + addTopLevelConstraints deps cs + +addTopLevelConstraints (PackageVersionConstraint pkg ver:deps) cs = + case addTopLevelVersionConstraint pkg ver cs of + Satisfiable cs' _ -> + addTopLevelConstraints deps cs' + + Unsatisfiable -> + Fail (TopLevelVersionConstraintUnsatisfiable pkg ver) + + ConflictsWith conflicts -> + Fail (TopLevelVersionConstraintConflict pkg ver conflicts) + +addTopLevelConstraints (PackageInstalledConstraint pkg:deps) cs = + case addTopLevelInstalledConstraint pkg cs of + Satisfiable cs' _ -> addTopLevelConstraints deps cs' + + Unsatisfiable -> + Fail (TopLevelInstallConstraintUnsatisfiable pkg) + + ConflictsWith conflicts -> + Fail (TopLevelInstallConstraintConflict pkg conflicts) + +configurePackage :: Platform -> CompilerId -> ConfigurePackage +configurePackage platform comp available spkg = case spkg of + InstalledOnly ipkg -> Right (InstalledOnly ipkg) + AvailableOnly apkg -> fmap AvailableOnly (configure apkg) + InstalledAndAvailable ipkg apkg -> fmap (InstalledAndAvailable ipkg) + (configure apkg) + where + configure (UnconfiguredPackage apkg@(AvailablePackage _ p _) _ flags) = + case finalizePackageDescription flags dependencySatisfiable + platform comp [] p of + Left missing -> Left missing + Right (pkg, flags') -> Right $ + SemiConfiguredPackage apkg flags' (externalBuildDepends pkg) + + dependencySatisfiable = not . null . PackageIndex.lookupDependency available + +-- | Annotate each installed packages with its set of transative dependencies +-- and its topological sort number. +-- +annotateInstalledPackages :: (PackageName -> TopologicalSortNumber) + -> PackageIndex InstalledPackage + -> PackageIndex InstalledPackageEx +annotateInstalledPackages dfsNumber installed = PackageIndex.fromList + [ InstalledPackageEx pkg (dfsNumber (packageName pkg)) (transitiveDepends pkg) + | pkg <- PackageIndex.allPackages installed ] + where + transitiveDepends :: InstalledPackage -> [PackageIdentifier] + transitiveDepends = map (packageId . toPkg) . tail . Graph.reachable graph + . fromJust . toVertex . packageId + (graph, toPkg, toVertex) = PackageIndex.dependencyGraph installed + + +-- | Annotate each available packages with its topological sort number and any +-- user-supplied partial flag assignment. +-- +annotateAvailablePackages :: [PackageConstraint] + -> (PackageName -> TopologicalSortNumber) + -> PackageIndex AvailablePackage + -> PackageIndex UnconfiguredPackage +annotateAvailablePackages constraints dfsNumber available = PackageIndex.fromList + [ UnconfiguredPackage pkg (dfsNumber name) (flagsFor name) + | pkg <- PackageIndex.allPackages available + , let name = packageName pkg ] + where + flagsFor = fromMaybe [] . flip Map.lookup flagsMap + flagsMap = Map.fromList + [ (name, flags) + | PackageFlagsConstraint name flags <- constraints ] + +-- | One of the heuristics we use when guessing which path to take in the +-- search space is an ordering on the choices we make. It's generally better +-- to make decisions about packages higer in the dep graph first since they +-- place constraints on packages lower in the dep graph. +-- +-- To pick them in that order we annotate each package with its topological +-- sort number. So if package A depends on package B then package A will have +-- a lower topological sort number than B and we'll make a choice about which +-- version of A to pick before we make a choice about B (unless there is only +-- one possible choice for B in which case we pick that immediately). +-- +-- To construct these topological sort numbers we combine and flatten the +-- installed and available package sets. We consider only dependencies between +-- named packages, not including versions and for not-yet-configured packages +-- we look at all the possible dependencies, not just those under any single +-- flag assignment. This means we can actually get impossible combinations of +-- edges and even cycles, but that doesn't really matter here, it's only a +-- heuristic. +-- +topologicalSortNumbering :: PackageIndex InstalledPackage + -> PackageIndex AvailablePackage + -> (PackageName -> TopologicalSortNumber) +topologicalSortNumbering installed available = + \pkgname -> let Just vertex = toVertex pkgname + in topologicalSortNumbers Array.! vertex + where + topologicalSortNumbers = Array.array (Array.bounds graph) + (zip (Graph.topSort graph) [0..]) + (graph, _, toVertex) = Graph.graphFromEdges $ + [ ((), packageName pkg, nub deps) + | pkgs@(pkg:_) <- PackageIndex.allPackagesByName installed + , let deps = [ packageName dep + | pkg' <- pkgs + , dep <- depends pkg' ] ] + ++ [ ((), packageName pkg, nub deps) + | pkgs@(pkg:_) <- PackageIndex.allPackagesByName available + , let deps = [ depName + | AvailablePackage _ pkg' _ <- pkgs + , Dependency depName _ <- + buildDepends (flattenPackageDescription pkg') ] ] + +-- | We don't need the entire index (which is rather large and costly if we +-- force it by examining the whole thing). So trace out the maximul subset of +-- each index that we could possibly ever need. Do this by flattening packages +-- and looking at the names of all possible dependencies. +-- +selectNeededSubset :: PackageIndex InstalledPackage + -> PackageIndex AvailablePackage + -> Set PackageName + -> (PackageIndex InstalledPackage + ,PackageIndex AvailablePackage) +selectNeededSubset installed available = select mempty mempty + where + select :: PackageIndex InstalledPackage + -> PackageIndex AvailablePackage + -> Set PackageName + -> (PackageIndex InstalledPackage + ,PackageIndex AvailablePackage) + select installed' available' remaining + | Set.null remaining = (installed', available') + | otherwise = select installed'' available'' remaining'' + where + (next, remaining') = Set.deleteFindMin remaining + moreInstalled = PackageIndex.lookupPackageName installed next + moreAvailable = PackageIndex.lookupPackageName available next + moreRemaining = -- we filter out packages already included in the indexes + -- this avoids an infinite loop if a package depends on itself + -- like base-3.0.3.0 with base-4.0.0.0 + filter notAlreadyIncluded + $ [ packageName dep + | pkg <- moreInstalled + , dep <- depends pkg ] + ++ [ name + | AvailablePackage _ pkg _ <- moreAvailable + , Dependency name _ <- + buildDepends (flattenPackageDescription pkg) ] + installed'' = foldl' (flip PackageIndex.insert) installed' moreInstalled + available'' = foldl' (flip PackageIndex.insert) available' moreAvailable + remaining'' = foldl' (flip Set.insert) remaining' moreRemaining + notAlreadyIncluded name = null (PackageIndex.lookupPackageName installed' name) + && null (PackageIndex.lookupPackageName available' name) + +-- ------------------------------------------------------------ +-- * Post processing the solution +-- ------------------------------------------------------------ + +finaliseSelectedPackages :: (PackageName -> PackagePreferences) + -> SelectedPackages + -> Constraints + -> [PlanPackage] +finaliseSelectedPackages pref selected constraints = + map finaliseSelected (PackageIndex.allPackages selected) + where + remainingChoices = Constraints.choices constraints + finaliseSelected (InstalledOnly ipkg ) = finaliseInstalled ipkg + finaliseSelected (AvailableOnly apkg) = finaliseAvailable Nothing apkg + finaliseSelected (InstalledAndAvailable ipkg apkg) = + case PackageIndex.lookupPackageId remainingChoices (packageId ipkg) of + Nothing -> impossible --picked package not in constraints + Just (AvailableOnly _) -> impossible --to constrain to avail only + Just (InstalledOnly _) -> finaliseInstalled ipkg + Just (InstalledAndAvailable _ _) -> finaliseAvailable (Just ipkg) apkg + + finaliseInstalled (InstalledPackageEx pkg _ _) = InstallPlan.PreExisting pkg + finaliseAvailable mipkg (SemiConfiguredPackage pkg flags deps) = + InstallPlan.Configured (ConfiguredPackage pkg flags deps') + where + deps' = map (packageId . pickRemaining mipkg) deps + + pickRemaining mipkg dep@(Dependency _name versionRange) = + case PackageIndex.lookupDependency remainingChoices dep of + [] -> impossible + [pkg'] -> pkg' + remaining -> assert (checkIsPaired remaining) + $ maximumBy bestByPref remaining + where + -- We order candidate packages to pick for a dependency by these + -- three factors. The last factor is just highest version wins. + bestByPref = + comparing (\p -> (isCurrent p, isPreferred p, packageVersion p)) + -- Is the package already used by the installed version of this + -- package? If so we should pick that first. This stops us from doing + -- silly things like deciding to rebuild haskell98 against base 3. + isCurrent = case mipkg :: Maybe InstalledPackageEx of + Nothing -> \_ -> False + Just ipkg -> \p -> packageId p `elem` depends ipkg + -- If there is no upper bound on the version range then we apply a + -- preferred version according to the hackage or user's suggested + -- version constraints. TODO: distinguish hacks from prefs + bounded = boundedAbove versionRange + isPreferred p + | bounded = True -- any constant will do + | otherwise = packageVersion p `withinRange` preferredVersions + where (PackagePreferences preferredVersions _) = pref (packageName p) + + boundedAbove :: VersionRange -> Bool + boundedAbove vr = case asVersionIntervals vr of + [] -> True -- this is the inconsistent version range. + intervals -> case last intervals of + (_, UpperBound _ _) -> True + (_, NoUpperBound ) -> False + + -- We really only expect to find more than one choice remaining when + -- we're finalising a dependency on a paired package. + checkIsPaired [p1, p2] = + case Constraints.isPaired constraints (packageId p1) of + Just p2' -> packageId p2' == packageId p2 + Nothing -> False + checkIsPaired _ = False + +-- | Improve an existing installation plan by, where possible, swapping +-- packages we plan to install with ones that are already installed. +-- This may add additional constraints due to the dependencies of installed +-- packages on other installed packages. +-- +improvePlan :: PackageIndex InstalledPackage + -> Constraints + -> PackageIndex PlanPackage + -> (PackageIndex PlanPackage, Constraints) +improvePlan installed constraints0 selected0 = + foldl' improve (selected0, constraints0) (reverseTopologicalOrder selected0) + where + improve (selected, constraints) = fromMaybe (selected, constraints) + . improvePkg selected constraints + + -- The idea is to improve the plan by swapping a configured package for + -- an equivalent installed one. For a particular package the condition is + -- that the package be in a configured state, that a the same version be + -- already installed with the exact same dependencies and all the packages + -- in the plan that it depends on are in the installed state + improvePkg selected constraints pkgid = do + Configured pkg <- PackageIndex.lookupPackageId selected pkgid + ipkg <- PackageIndex.lookupPackageId installed pkgid + guard $ all (isInstalled selected) (depends pkg) + tryInstalled selected constraints [ipkg] + + isInstalled selected pkgid = + case PackageIndex.lookupPackageId selected pkgid of + Just (PreExisting _) -> True + _ -> False + + tryInstalled :: PackageIndex PlanPackage -> Constraints + -> [InstalledPackage] + -> Maybe (PackageIndex PlanPackage, Constraints) + tryInstalled selected constraints [] = Just (selected, constraints) + tryInstalled selected constraints (pkg:pkgs) = + case constraintsOk (packageId pkg) (depends pkg) constraints of + Nothing -> Nothing + Just constraints' -> tryInstalled selected' constraints' pkgs' + where + selected' = PackageIndex.insert (PreExisting pkg) selected + pkgs' = catMaybes (map notSelected (depends pkg)) ++ pkgs + notSelected pkgid = + case (PackageIndex.lookupPackageId installed pkgid + ,PackageIndex.lookupPackageId selected pkgid) of + (Just pkg', Nothing) -> Just pkg' + _ -> Nothing + + constraintsOk _ [] constraints = Just constraints + constraintsOk pkgid (pkgid':pkgids) constraints = + case addPackageDependencyConstraint pkgid dep constraints of + Satisfiable constraints' _ -> constraintsOk pkgid pkgids constraints' + _ -> Nothing + where + dep = TaggedDependency InstalledConstraint (thisPackageVersion pkgid') + + reverseTopologicalOrder :: PackageFixedDeps pkg + => PackageIndex pkg -> [PackageIdentifier] + reverseTopologicalOrder index = map (packageId . toPkg) + . Graph.topSort + . Graph.transposeG + $ graph + where (graph, toPkg, _) = PackageIndex.dependencyGraph index + +-- ------------------------------------------------------------ +-- * Adding and recording constraints +-- ------------------------------------------------------------ + +addPackageSelectConstraint :: PackageIdentifier -> Constraints + -> Satisfiable Constraints + [PackageIdentifier] ExclusionReason +addPackageSelectConstraint pkgid constraints = + Constraints.constrain dep reason constraints + where + dep = TaggedDependency NoInstalledConstraint (thisPackageVersion pkgid) + reason = SelectedOther pkgid + +addPackageExcludeConstraint :: PackageIdentifier -> Constraints + -> Satisfiable Constraints + [PackageIdentifier] ExclusionReason +addPackageExcludeConstraint pkgid constraints = + Constraints.constrain dep reason constraints + where + dep = TaggedDependency NoInstalledConstraint + (notThisPackageVersion pkgid) + reason = ExcludedByConfigureFail + +addPackageDependencyConstraint :: PackageIdentifier -> TaggedDependency -> Constraints + -> Satisfiable Constraints + [PackageIdentifier] ExclusionReason +addPackageDependencyConstraint pkgid dep constraints = + Constraints.constrain dep reason constraints + where + reason = ExcludedByPackageDependency pkgid dep + +addTopLevelVersionConstraint :: PackageName -> VersionRange + -> Constraints + -> Satisfiable Constraints + [PackageIdentifier] ExclusionReason +addTopLevelVersionConstraint pkg ver constraints = + Constraints.constrain taggedDep reason constraints + where + dep = Dependency pkg ver + taggedDep = TaggedDependency NoInstalledConstraint dep + reason = ExcludedByTopLevelDependency dep + +addTopLevelInstalledConstraint :: PackageName + -> Constraints + -> Satisfiable Constraints + [PackageIdentifier] ExclusionReason +addTopLevelInstalledConstraint pkg constraints = + Constraints.constrain taggedDep reason constraints + where + dep = Dependency pkg anyVersion + taggedDep = TaggedDependency InstalledConstraint dep + reason = ExcludedByTopLevelDependency dep + +-- ------------------------------------------------------------ +-- * Reasons for constraints +-- ------------------------------------------------------------ + +-- | For every constraint we record we also record the reason that constraint +-- is needed. So if we end up failing due to conflicting constraints then we +-- can give an explnanation as to what was conflicting and why. +-- +data ExclusionReason = + + -- | We selected this other version of the package. That means we exclude + -- all the other versions. + SelectedOther PackageIdentifier + + -- | We excluded this version of the package because it failed to + -- configure probably because of unsatisfiable deps. + | ExcludedByConfigureFail + + -- | We excluded this version of the package because another package that + -- we selected imposed a dependency which this package did not satisfy. + | ExcludedByPackageDependency PackageIdentifier TaggedDependency + + -- | We excluded this version of the package because it did not satisfy + -- a dependency given as an original top level input. + -- + | ExcludedByTopLevelDependency Dependency + +-- | Given an excluded package and the reason it was excluded, produce a human +-- readable explanation. +-- +showExclusionReason :: PackageIdentifier -> ExclusionReason -> String +showExclusionReason pkgid (SelectedOther pkgid') = + display pkgid ++ " was excluded because " ++ + display pkgid' ++ " was selected instead" +showExclusionReason pkgid ExcludedByConfigureFail = + display pkgid ++ " was excluded because it could not be configured" +showExclusionReason pkgid (ExcludedByPackageDependency pkgid' dep) = + display pkgid ++ " was excluded because " ++ + display pkgid' ++ " requires " ++ displayDep (untagDependency dep) +showExclusionReason pkgid (ExcludedByTopLevelDependency dep) = + display pkgid ++ " was excluded because of the top level dependency " ++ + displayDep dep + + +-- ------------------------------------------------------------ +-- * Logging progress and failures +-- ------------------------------------------------------------ + +data Log = Select [SelectedPackage] [PackageIdentifier] +data Failure + = ConfigureFailed + SelectablePackage + [(Dependency, [(PackageIdentifier, [ExclusionReason])])] + | DependencyConflict + SelectedPackage TaggedDependency + [(PackageIdentifier, [ExclusionReason])] + | TopLevelVersionConstraintConflict + PackageName VersionRange + [(PackageIdentifier, [ExclusionReason])] + | TopLevelVersionConstraintUnsatisfiable + PackageName VersionRange + | TopLevelInstallConstraintConflict + PackageName + [(PackageIdentifier, [ExclusionReason])] + | TopLevelInstallConstraintUnsatisfiable + PackageName + +showLog :: Log -> String +showLog (Select selected discarded) = case (selectedMsg, discardedMsg) of + ("", y) -> y + (x, "") -> x + (x, y) -> x ++ " and " ++ y + + where + selectedMsg = "selecting " ++ case selected of + [] -> "" + [s] -> display (packageId s) ++ " " ++ kind s + (s:ss) -> listOf id + $ (display (packageId s) ++ " " ++ kind s) + : [ display (packageVersion s') ++ " " ++ kind s' + | s' <- ss ] + + kind (InstalledOnly _) = "(installed)" + kind (AvailableOnly _) = "(hackage)" + kind (InstalledAndAvailable _ _) = "(installed or hackage)" + + discardedMsg = case discarded of + [] -> "" + _ -> "discarding " ++ listOf id + [ element + | (pkgid:pkgids) <- groupBy (equating packageName) (sort discarded) + , element <- display pkgid : map (display . packageVersion) pkgids ] + +showFailure :: Failure -> String +showFailure (ConfigureFailed pkg missingDeps) = + "cannot configure " ++ displayPkg pkg ++ ". It requires " + ++ listOf (displayDep . fst) missingDeps + ++ '\n' : unlines (map (uncurry whyNot) missingDeps) + + where + whyNot (Dependency name ver) [] = + "There is no available version of " ++ display name + ++ " that satisfies " ++ displayVer ver + + whyNot dep conflicts = + "For the dependency on " ++ displayDep dep + ++ " there are these packages: " ++ listOf display pkgs + ++ ". However none of them are available.\n" + ++ unlines [ showExclusionReason (packageId pkg') reason + | (pkg', reasons) <- conflicts, reason <- reasons ] + + where pkgs = map fst conflicts + +showFailure (DependencyConflict pkg (TaggedDependency _ dep) conflicts) = + "dependencies conflict: " + ++ displayPkg pkg ++ " requires " ++ displayDep dep ++ " however\n" + ++ unlines [ showExclusionReason (packageId pkg') reason + | (pkg', reasons) <- conflicts, reason <- reasons ] + +showFailure (TopLevelVersionConstraintConflict name ver conflicts) = + "constraints conflict: " + ++ "top level constraint " ++ displayDep (Dependency name ver) ++ " however\n" + ++ unlines [ showExclusionReason (packageId pkg') reason + | (pkg', reasons) <- conflicts, reason <- reasons ] + +showFailure (TopLevelVersionConstraintUnsatisfiable name ver) = + "There is no available version of " ++ display name + ++ " that satisfies " ++ displayVer ver + +showFailure (TopLevelInstallConstraintConflict name conflicts) = + "constraints conflict: " + ++ "top level constraint " ++ display name ++ "-installed however\n" + ++ unlines [ showExclusionReason (packageId pkg') reason + | (pkg', reasons) <- conflicts, reason <- reasons ] + +showFailure (TopLevelInstallConstraintUnsatisfiable name) = + "There is no installed version of " ++ display name + +displayVer :: VersionRange -> String +displayVer = display . simplifyVersionRange + +displayDep :: Dependency -> String +displayDep = display . simplifyDependency + +simplifyDependency :: Dependency -> Dependency +simplifyDependency (Dependency name range) = + Dependency name (simplifyVersionRange range) + +-- ------------------------------------------------------------ +-- * Utils +-- ------------------------------------------------------------ + +impossible :: a +impossible = internalError "impossible" + +internalError :: String -> a +internalError msg = error $ "internal error: " ++ msg + +displayPkg :: Package pkg => pkg -> String +displayPkg = display . packageId + +listOf :: (a -> String) -> [a] -> String +listOf _ [] = [] +listOf disp [x0] = disp x0 +listOf disp (x0:x1:xs) = disp x0 ++ go x1 xs + where go x [] = " and " ++ disp x + go x (x':xs') = ", " ++ disp x ++ go x' xs' diff --git a/Distribution/Client/Dependency/TopDown/Constraints.hs b/Distribution/Client/Dependency/TopDown/Constraints.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/TopDown/Constraints.hs @@ -0,0 +1,316 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Dependency.TopDown.Constraints +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : duncan@community.haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- A set of satisfiable dependencies (package version constraints). +----------------------------------------------------------------------------- +module Distribution.Client.Dependency.TopDown.Constraints ( + Constraints, + empty, + choices, + isPaired, + + constrain, + Satisfiable(..), + conflicting, + ) where + +import Distribution.Client.Dependency.TopDown.Types +import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Client.PackageIndex (PackageIndex) +import Distribution.Package + ( PackageName, PackageIdentifier(..) + , Package(packageId), packageName, packageVersion + , PackageFixedDeps(depends) + , Dependency(Dependency) ) +import Distribution.Version + ( Version, withinRange ) +import Distribution.Client.Utils + ( mergeBy, MergeResult(..) ) + +import Data.List + ( foldl' ) +import Data.Monoid + ( Monoid(mempty) ) +import Data.Maybe + ( catMaybes ) +import qualified Data.Map as Map +import Data.Map (Map) +import Control.Exception + ( assert ) + +-- | A set of constraints on package versions. For each package name we record +-- what other packages depends on it and what constraints they impose on the +-- version of the package. +-- +data (Package installed, Package available) + => Constraints installed available reason + = Constraints + + -- Remaining available choices + (PackageIndex (InstalledOrAvailable installed available)) + + -- Paired choices + (Map PackageName (Version, Version)) + + -- Choices that we have excluded for some reason + -- usually by applying constraints + (PackageIndex (ExcludedPackage PackageIdentifier reason)) + + -- Purely for the invariant, we keep a copy of the original index + (PackageIndex (InstalledOrAvailable installed available)) + + +data ExcludedPackage pkg reason + = ExcludedPackage pkg [reason] -- reasons for excluding just the available + [reason] -- reasons for excluding installed and avail + +instance Package pkg => Package (ExcludedPackage pkg reason) where + packageId (ExcludedPackage p _ _) = packageId p + +-- | There is a conservation of packages property. Packages are never gained or +-- lost, they just transfer from the remaining pot to the excluded pot. +-- +invariant :: (Package installed, Package available) + => Constraints installed available a -> Bool +invariant (Constraints available _ excluded original) = all check merged + where + merged = mergeBy (\a b -> packageId a `compare` mergedPackageId b) + (PackageIndex.allPackages original) + (mergeBy (\a b -> packageId a `compare` packageId b) + (PackageIndex.allPackages available) + (PackageIndex.allPackages excluded)) + where + mergedPackageId (OnlyInLeft p ) = packageId p + mergedPackageId (OnlyInRight p) = packageId p + mergedPackageId (InBoth p _) = packageId p + + check (InBoth (InstalledOnly _) cur) = case cur of + -- If the package was originally installed only then + -- now it's either still remaining as installed only + -- or it has been excluded in which case we excluded both + -- installed and available since it was only installed + OnlyInLeft (InstalledOnly _) -> True + OnlyInRight (ExcludedPackage _ [] (_:_)) -> True + _ -> False + + check (InBoth (AvailableOnly _) cur) = case cur of + -- If the package was originally available only then + -- now it's either still remaining as available only + -- or it has been excluded in which case we excluded both + -- installed and available since it was only available + OnlyInLeft (AvailableOnly _) -> True + OnlyInRight (ExcludedPackage _ [] (_:_)) -> True + _ -> True + + -- If the package was originally installed and available + -- then there are three cases. + check (InBoth (InstalledAndAvailable _ _) cur) = case cur of + -- We can have both remaining: + OnlyInLeft (InstalledAndAvailable _ _) -> True + -- both excluded, in particular it can have had the available excluded + -- and later had both excluded so we do not mind if the available excluded + -- is empty or non-empty. + OnlyInRight (ExcludedPackage _ _ (_:_)) -> True + -- the installed remaining and the available excluded: + InBoth (InstalledOnly _) (ExcludedPackage _ (_:_) []) -> True + _ -> False + + check _ = False + +-- | An update to the constraints can move packages between the two piles +-- but not gain or loose packages. +transitionsTo :: (Package installed, Package available) + => Constraints installed available a + -> Constraints installed available a -> Bool +transitionsTo constraints @(Constraints available _ excluded _) + constraints'@(Constraints available' _ excluded' _) = + invariant constraints && invariant constraints' + && null availableGained && null excludedLost + && map packageId availableLost == map packageId excludedGained + + where + availableLost = foldr lost [] availableChange where + lost (OnlyInLeft pkg) rest = pkg : rest + lost (InBoth (InstalledAndAvailable _ pkg) + (InstalledOnly _)) rest = AvailableOnly pkg : rest + lost _ rest = rest + availableGained = [ pkg | OnlyInRight pkg <- availableChange ] + excludedLost = [ pkg | OnlyInLeft pkg <- excludedChange ] + excludedGained = [ pkg | OnlyInRight pkg <- excludedChange ] + ++ [ pkg | InBoth (ExcludedPackage _ (_:_) []) + pkg@(ExcludedPackage _ (_:_) (_:_)) + <- excludedChange ] + availableChange = mergeBy (\a b -> packageId a `compare` packageId b) + (PackageIndex.allPackages available) + (PackageIndex.allPackages available') + excludedChange = mergeBy (\a b -> packageId a `compare` packageId b) + (PackageIndex.allPackages excluded) + (PackageIndex.allPackages excluded') + +-- | We construct 'Constraints' with an initial 'PackageIndex' of all the +-- packages available. +-- +empty :: (PackageFixedDeps installed, Package available) + => PackageIndex installed + -> PackageIndex available + -> Constraints installed available reason +empty installed available = Constraints pkgs pairs mempty pkgs + where + pkgs = PackageIndex.fromList + . map toInstalledOrAvailable + $ mergeBy (\a b -> packageId a `compare` packageId b) + (PackageIndex.allPackages installed) + (PackageIndex.allPackages available) + toInstalledOrAvailable (OnlyInLeft i ) = InstalledOnly i + toInstalledOrAvailable (OnlyInRight a) = AvailableOnly a + toInstalledOrAvailable (InBoth i a) = InstalledAndAvailable i a + + -- pick up cases like base-3 and 4 where one version depends on the other: + pairs = Map.fromList + [ (name, (packageVersion pkgid1, packageVersion pkgid2)) + | [pkg1, pkg2] <- PackageIndex.allPackagesByName installed + , let name = packageName pkg1 + pkgid1 = packageId pkg1 + pkgid2 = packageId pkg2 + , any ((pkgid1==) . packageId) (depends pkg2) + || any ((pkgid2==) . packageId) (depends pkg1) ] + +-- | The package choices that are still available. +-- +choices :: (Package installed, Package available) + => Constraints installed available reason + -> PackageIndex (InstalledOrAvailable installed available) +choices (Constraints available _ _ _) = available + +isPaired :: (Package installed, Package available) + => Constraints installed available reason + -> PackageIdentifier -> Maybe PackageIdentifier +isPaired (Constraints _ pairs _ _) (PackageIdentifier name version) = + case Map.lookup name pairs of + Just (v1, v2) + | version == v1 -> Just (PackageIdentifier name v2) + | version == v2 -> Just (PackageIdentifier name v1) + _ -> Nothing + +data Satisfiable constraints discarded reason + = Satisfiable constraints discarded + | Unsatisfiable + | ConflictsWith [(PackageIdentifier, [reason])] + +constrain :: (Package installed, Package available) + => TaggedDependency + -> reason + -> Constraints installed available reason + -> Satisfiable (Constraints installed available reason) + [PackageIdentifier] reason +constrain (TaggedDependency installedConstraint (Dependency name versionRange)) + reason constraints@(Constraints available paired excluded original) + + | not anyRemaining + = if null conflicts then Unsatisfiable + else ConflictsWith conflicts + + | otherwise + = let constraints' = Constraints available' paired excluded' original + in assert (constraints `transitionsTo` constraints') $ + Satisfiable constraints' (map packageId newExcluded) + + where + -- This tells us if any packages would remain at all for this package name if + -- we applied this constraint. This amounts to checking if any package + -- satisfies the given constraint, including version range and installation + -- status. + -- + anyRemaining = any satisfiesConstraint availableChoices + + conflicts = [ (packageId pkg, reasonsAvail ++ reasonsAll) + | ExcludedPackage pkg reasonsAvail reasonsAll <- excludedChoices + , satisfiesVersionConstraint pkg ] + + -- Applying this constraint may involve deleting some choices for this + -- package name, or restricting which install states are available. + available' = updateAvailable available + updateAvailable = flip (foldl' (flip update)) availableChoices where + update pkg | not (satisfiesVersionConstraint pkg) + = PackageIndex.deletePackageId (packageId pkg) + update _ | installedConstraint == NoInstalledConstraint + = id + update pkg = case pkg of + InstalledOnly _ -> id + AvailableOnly _ -> PackageIndex.deletePackageId (packageId pkg) + InstalledAndAvailable i _ -> PackageIndex.insert (InstalledOnly i) + + -- Applying the constraint means adding exclusions for the packages that + -- we're just freshly excluding, ie the ones we're removing from available. + excluded' = foldl' (flip PackageIndex.insert) excluded + (newExcluded ++ oldExcluded) + + newExcluded = catMaybes (map exclude availableChoices) where + exclude pkg + | not (satisfiesVersionConstraint pkg) + = Just (ExcludedPackage pkgid [] [reason]) + | installedConstraint == NoInstalledConstraint + = Nothing + | otherwise = case pkg of + InstalledOnly _ -> Nothing + AvailableOnly _ -> Just (ExcludedPackage pkgid [] [reason]) + InstalledAndAvailable _ _ -> + case PackageIndex.lookupPackageId excluded pkgid of + Just (ExcludedPackage _ avail both) + -> Just (ExcludedPackage pkgid (reason:avail) both) + Nothing -> Just (ExcludedPackage pkgid [reason] []) + where pkgid = packageId pkg + + -- Additionally we have to add extra exclusions for any already-excluded + -- packages that happen to be covered by the (inverse of the) constraint. + oldExcluded = catMaybes (map exclude excludedChoices) where + exclude (ExcludedPackage pkgid avail both) + -- if it doesn't satisfy the version constraint then we exclude the + -- package as a whole, the available or the installed instances or both. + | not (satisfiesVersionConstraint pkgid) + = Just (ExcludedPackage pkgid avail (reason:both)) + -- if on the other hand it does satisfy the constraint and we were also + -- constraining to just the installed version then we exclude just the + -- available instance. + | installedConstraint == InstalledConstraint + = Just (ExcludedPackage pkgid (reason:avail) both) + | otherwise = Nothing + + -- util definitions + availableChoices = PackageIndex.lookupPackageName available name + excludedChoices = PackageIndex.lookupPackageName excluded name + + satisfiesConstraint pkg = satisfiesVersionConstraint pkg + && satisfiesInstallStateConstraint pkg + + satisfiesVersionConstraint :: Package pkg => pkg -> Bool + satisfiesVersionConstraint = case Map.lookup name paired of + Nothing -> \pkg -> + packageVersion pkg `withinRange` versionRange + Just (v1, v2) -> \pkg -> case packageVersion pkg of + v | v == v1 + || v == v2 -> v1 `withinRange` versionRange + || v2 `withinRange` versionRange + | otherwise -> v `withinRange` versionRange + + satisfiesInstallStateConstraint = case installedConstraint of + NoInstalledConstraint -> \_ -> True + InstalledConstraint -> \pkg -> case pkg of + AvailableOnly _ -> False + _ -> True + +conflicting :: (Package installed, Package available) + => Constraints installed available reason + -> Dependency + -> [(PackageIdentifier, [reason])] +conflicting (Constraints _ _ excluded _) dep = + [ (pkgid, reasonsAvail ++ reasonsAll) --TODO + | ExcludedPackage pkgid reasonsAvail reasonsAll <- + PackageIndex.lookupDependency excluded dep ] diff --git a/Distribution/Client/Dependency/TopDown/Types.hs b/Distribution/Client/Dependency/TopDown/Types.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/TopDown/Types.hs @@ -0,0 +1,93 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Dependency.TopDown.Types +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Types for the top-down dependency resolver. +----------------------------------------------------------------------------- +module Distribution.Client.Dependency.TopDown.Types where + +import Distribution.Client.Types + ( AvailablePackage(..), InstalledPackage ) + +import Distribution.Package + ( PackageIdentifier, Dependency + , Package(packageId), PackageFixedDeps(depends) ) +import Distribution.PackageDescription + ( FlagAssignment ) + +-- ------------------------------------------------------------ +-- * The various kinds of packages +-- ------------------------------------------------------------ + +type SelectablePackage + = InstalledOrAvailable InstalledPackageEx UnconfiguredPackage + +type SelectedPackage + = InstalledOrAvailable InstalledPackageEx SemiConfiguredPackage + +data InstalledOrAvailable installed available + = InstalledOnly installed + | AvailableOnly available + | InstalledAndAvailable installed available + +type TopologicalSortNumber = Int + +data InstalledPackageEx + = InstalledPackageEx + InstalledPackage + !TopologicalSortNumber + [PackageIdentifier] -- transative closure of installed deps + +data UnconfiguredPackage + = UnconfiguredPackage + AvailablePackage + !TopologicalSortNumber + FlagAssignment + +data SemiConfiguredPackage + = SemiConfiguredPackage + AvailablePackage -- package info + FlagAssignment -- total flag assignment for the package + [Dependency] -- dependencies we end up with when we apply + -- the flag assignment + +instance Package InstalledPackageEx where + packageId (InstalledPackageEx p _ _) = packageId p + +instance PackageFixedDeps InstalledPackageEx where + depends (InstalledPackageEx _ _ deps) = deps + +instance Package UnconfiguredPackage where + packageId (UnconfiguredPackage p _ _) = packageId p + +instance Package SemiConfiguredPackage where + packageId (SemiConfiguredPackage p _ _) = packageId p + +instance (Package installed, Package available) + => Package (InstalledOrAvailable installed available) where + packageId (InstalledOnly p ) = packageId p + packageId (AvailableOnly p ) = packageId p + packageId (InstalledAndAvailable p _) = packageId p + +-- ------------------------------------------------------------ +-- * Tagged Dependency type +-- ------------------------------------------------------------ + +-- | Installed packages can only depend on other installed packages while +-- packages that are not yet installed but which we plan to install can depend +-- on installed or other not-yet-installed packages. +-- +-- This makes life more complex as we have to remember these constraints. +-- +data TaggedDependency = TaggedDependency InstalledConstraint Dependency +data InstalledConstraint = InstalledConstraint | NoInstalledConstraint + deriving Eq + +untagDependency :: TaggedDependency -> Dependency +untagDependency (TaggedDependency _ dep) = dep diff --git a/Distribution/Client/Dependency/Types.hs b/Distribution/Client/Dependency/Types.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/Types.hs @@ -0,0 +1,115 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Dependency.Types +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Common types for dependency resolution. +----------------------------------------------------------------------------- +module Distribution.Client.Dependency.Types ( + DependencyResolver, + + PackageConstraint(..), + PackagePreferences(..), + InstalledPreference(..), + + Progress(..), + foldProgress, + ) where + +import Distribution.Client.Types + ( AvailablePackage(..), InstalledPackage ) +import qualified Distribution.Client.InstallPlan as InstallPlan + +import Distribution.PackageDescription + ( FlagAssignment ) +import Distribution.Client.PackageIndex + ( PackageIndex ) +import Distribution.Package + ( PackageName ) +import Distribution.Version + ( VersionRange ) +import Distribution.Compiler + ( CompilerId ) +import Distribution.System + ( Platform ) + +import Prelude hiding (fail) + +-- | A dependency resolver is a function that works out an installation plan +-- given the set of installed and available packages and a set of deps to +-- solve for. +-- +-- The reason for this interface is because there are dozens of approaches to +-- solving the package dependency problem and we want to make it easy to swap +-- in alternatives. +-- +type DependencyResolver = Platform + -> CompilerId + -> PackageIndex InstalledPackage + -> PackageIndex AvailablePackage + -> (PackageName -> PackagePreferences) + -> [PackageConstraint] + -> [PackageName] + -> Progress String String [InstallPlan.PlanPackage] + +-- | Per-package constraints. Package constraints must be respected by the +-- solver. Multiple constraints for each package can be given, though obviously +-- it is possible to construct conflicting constraints (eg impossible version +-- range or inconsistent flag assignment). +-- +data PackageConstraint + = PackageVersionConstraint PackageName VersionRange + | PackageInstalledConstraint PackageName + | PackageFlagsConstraint PackageName FlagAssignment + deriving (Show,Eq) + +-- | A per-package preference on the version. It is a soft constraint that the +-- 'DependencyResolver' should try to respect where possible. It consists of +-- a 'InstalledPreference' which says if we prefer versions of packages +-- that are already installed. It also hase a 'PackageVersionPreference' which +-- is a suggested constraint on the version number. The resolver should try to +-- use package versions that satisfy the suggested version constraint. +-- +-- It is not specified if preferences on some packages are more important than +-- others. +-- +data PackagePreferences = PackagePreferences VersionRange InstalledPreference + +-- | Wether we prefer an installed version of a package or simply the latest +-- version. +-- +data InstalledPreference = PreferInstalled | PreferLatest + +-- | A type to represent the unfolding of an expensive long running +-- calculation that may fail. We may get intermediate steps before the final +-- retult which may be used to indicate progress and\/or logging messages. +-- +data Progress step fail done = Step step (Progress step fail done) + | 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. +-- +-- Eg to convert into a simple 'Either' result use: +-- +-- > foldProgress (flip const) Left Right +-- +foldProgress :: (step -> a -> a) -> (fail -> a) -> (done -> a) + -> Progress step fail done -> a +foldProgress step fail done = fold + where fold (Step s p) = step s (fold p) + fold (Fail f) = fail f + fold (Done r) = done r + +instance Functor (Progress step fail) where + fmap f = foldProgress Step Fail (Done . f) + +instance Monad (Progress step fail) where + return a = Done a + p >>= f = foldProgress Step Fail f p diff --git a/Distribution/Client/Fetch.hs b/Distribution/Client/Fetch.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Fetch.hs @@ -0,0 +1,171 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Fetch +-- Copyright : (c) David Himmelstrup 2005 +-- Duncan Coutts 2011 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- The cabal fetch command +----------------------------------------------------------------------------- +module Distribution.Client.Fetch ( + fetch, + ) where + +import Distribution.Client.Types +import Distribution.Client.Targets +import Distribution.Client.FetchUtils hiding (fetchPackage) +import Distribution.Client.Dependency +import Distribution.Client.PackageIndex (PackageIndex) +import Distribution.Client.IndexUtils as IndexUtils + ( getAvailablePackages, getInstalledPackages ) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.Setup + ( GlobalFlags(..), FetchFlags(..) ) + +import Distribution.Package + ( packageId ) +import Distribution.Simple.Compiler + ( Compiler(compilerId), PackageDBStack ) +import Distribution.Simple.Program + ( ProgramConfiguration ) +import Distribution.Simple.Setup + ( fromFlag ) +import Distribution.Simple.Utils + ( die, notice, debug ) +import Distribution.System + ( buildPlatform ) +import Distribution.Text + ( display ) +import Distribution.Verbosity + ( Verbosity ) + +import Control.Monad + ( filterM ) + +-- ------------------------------------------------------------ +-- * The fetch command +-- ------------------------------------------------------------ + +--TODO: +-- * add fetch -o support +-- * support tarball URLs via ad-hoc download cache (or in -o mode?) +-- * suggest using --no-deps, unpack or fetch -o if deps cannot be satisfied +-- * Port various flags from install: +-- * --updage-dependencies +-- * --constraint and --preference +-- * --only-dependencies, but note it conflicts with --no-deps + + +-- | Fetch a list of packages and their dependencies. +-- +fetch :: Verbosity + -> PackageDBStack + -> [Repo] + -> Compiler + -> ProgramConfiguration + -> GlobalFlags + -> FetchFlags + -> [UserTarget] + -> IO () +fetch verbosity _ _ _ _ _ _ [] = + notice verbosity "No packages requested. Nothing to do." + +fetch verbosity packageDBs repos comp conf + globalFlags fetchFlags userTargets = do + + mapM_ checkTarget userTargets + + installed <- getInstalledPackages verbosity comp packageDBs conf + availableDb <- getAvailablePackages verbosity repos + + pkgSpecifiers <- resolveUserTargets verbosity + globalFlags (packageIndex availableDb) userTargets + + pkgs <- planPackages + verbosity comp fetchFlags + installed availableDb pkgSpecifiers + + pkgs' <- filterM (fmap not . isFetched . packageSource) pkgs + if null pkgs' + --TODO: when we add support for remote tarballs then this message + -- will need to be changed because for remote tarballs we fetch them + -- at the earlier phase. + then notice verbosity $ "No packages need to be fetched. " + ++ "All the requested packages are already local " + ++ "or cached locally." + else if dryRun + then notice verbosity $ unlines $ + "The following packages would be fetched:" + : map (display . packageId) pkgs' + + else mapM_ (fetchPackage verbosity . packageSource) pkgs' + + where + dryRun = fromFlag (fetchDryRun fetchFlags) + +planPackages :: Verbosity + -> Compiler + -> FetchFlags + -> PackageIndex InstalledPackage + -> AvailablePackageDb + -> [PackageSpecifier AvailablePackage] + -> IO [AvailablePackage] +planPackages verbosity comp fetchFlags + installed availableDb pkgSpecifiers + + | includeDependencies = do + notice verbosity "Resolving dependencies..." + installPlan <- foldProgress logMsg die return $ + resolveDependencies + buildPlatform (compilerId comp) + resolverParams + + -- The packages we want to fetch are those packages the 'InstallPlan' + -- that are in the 'InstallPlan.Configured' state. + return + [ pkg + | (InstallPlan.Configured (InstallPlan.ConfiguredPackage pkg _ _)) + <- InstallPlan.toList installPlan ] + + | otherwise = + either (die . unlines . map show) return $ + resolveWithoutDependencies resolverParams + + where + resolverParams = + + -- Reinstall the targets given on the command line so that the dep + -- resolver will decide that they need fetching, even if they're + -- already installed. Sicne we want to get the source packages of + -- things we might have installed (but not have the sources for). + reinstallTargets + + $ standardInstallPolicy installed availableDb pkgSpecifiers + + includeDependencies = fromFlag (fetchDeps fetchFlags) + logMsg message rest = debug verbosity message >> rest + + +checkTarget :: UserTarget -> IO () +checkTarget target = case target of + UserTargetRemoteTarball _uri + -> die $ "The 'fetch' command does not yet support remote tarballs. " + ++ "In the meantime you can use the 'unpack' commands." + _ -> return () + +fetchPackage :: Verbosity -> PackageLocation a -> IO () +fetchPackage verbosity pkgsrc = case pkgsrc of + LocalUnpackedPackage _dir -> return () + LocalTarballPackage _file -> return () + + RemoteTarballPackage _uri _ -> + die $ "The 'fetch' command does not yet support remote tarballs. " + ++ "In the meantime you can use the 'unpack' commands." + + RepoTarballPackage repo pkgid _ -> do + _ <- fetchRepoTarball verbosity repo pkgid + return () diff --git a/Distribution/Client/FetchUtils.hs b/Distribution/Client/FetchUtils.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/FetchUtils.hs @@ -0,0 +1,193 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.FetchUtils +-- Copyright : (c) David Himmelstrup 2005 +-- Duncan Coutts 2011 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Functions for fetching packages +----------------------------------------------------------------------------- +module Distribution.Client.FetchUtils ( + + -- * fetching packages + fetchPackage, + isFetched, + checkFetched, + + -- ** specifically for repo packages + fetchRepoTarball, + + -- * fetching other things + downloadIndex, + ) where + +import Distribution.Client.Types +import Distribution.Client.HttpUtils + ( downloadURI, isOldHackageURI ) + +import Distribution.Package + ( PackageId, packageName, packageVersion ) +import Distribution.Simple.Utils + ( notice, info, setupMessage ) +import Distribution.Text + ( display ) +import Distribution.Verbosity + ( Verbosity ) + +import Data.Maybe +import System.Directory + ( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory ) +import System.IO + ( openTempFile, hClose ) +import System.FilePath + ( (), (<.>) ) +import qualified System.FilePath.Posix as FilePath.Posix + ( combine, joinPath ) +import Network.URI + ( URI(uriPath) ) + +-- ------------------------------------------------------------ +-- * Actually fetch things +-- ------------------------------------------------------------ + +-- | Returns @True@ if the package has already been fetched +-- or does not need fetching. +-- +isFetched :: PackageLocation (Maybe FilePath) -> IO Bool +isFetched loc = case loc of + LocalUnpackedPackage _dir -> return True + LocalTarballPackage _file -> return True + RemoteTarballPackage _uri local -> return (isJust local) + RepoTarballPackage repo pkgid _ -> doesFileExist (packageFile repo pkgid) + + +checkFetched :: PackageLocation (Maybe FilePath) + -> IO (Maybe (PackageLocation FilePath)) +checkFetched loc = case loc of + LocalUnpackedPackage dir -> + return (Just $ LocalUnpackedPackage dir) + LocalTarballPackage file -> + return (Just $ LocalTarballPackage file) + RemoteTarballPackage uri (Just file) -> + return (Just $ RemoteTarballPackage uri file) + RepoTarballPackage repo pkgid (Just file) -> + return (Just $ RepoTarballPackage repo pkgid file) + + RemoteTarballPackage _uri Nothing -> return Nothing + RepoTarballPackage repo pkgid Nothing -> do + let file = packageFile repo pkgid + exists <- doesFileExist file + if exists + then return (Just $ RepoTarballPackage repo pkgid file) + else return Nothing + + +-- | Fetch a package if we don't have it already. +-- +fetchPackage :: Verbosity + -> PackageLocation (Maybe FilePath) + -> IO (PackageLocation FilePath) +fetchPackage verbosity loc = case loc of + LocalUnpackedPackage dir -> + return (LocalUnpackedPackage dir) + LocalTarballPackage file -> + return (LocalTarballPackage file) + RemoteTarballPackage uri (Just file) -> + return (RemoteTarballPackage uri file) + RepoTarballPackage repo pkgid (Just file) -> + return (RepoTarballPackage repo pkgid file) + + RemoteTarballPackage uri Nothing -> do + path <- downloadTarballPackage uri + return (RemoteTarballPackage uri path) + RepoTarballPackage repo pkgid Nothing -> do + local <- fetchRepoTarball verbosity repo pkgid + return (RepoTarballPackage repo pkgid local) + where + downloadTarballPackage uri = do + notice verbosity ("Downloading " ++ show uri) + tmpdir <- getTemporaryDirectory + (path, hnd) <- openTempFile tmpdir "cabal-.tar.gz" + hClose hnd + downloadURI verbosity uri path + return path + + +-- | Fetch a repo package if we don't have it already. +-- +fetchRepoTarball :: Verbosity -> Repo -> PackageId -> IO FilePath +fetchRepoTarball verbosity repo pkgid = do + fetched <- doesFileExist (packageFile repo pkgid) + if fetched + then do info verbosity $ display pkgid ++ " has already been downloaded." + return (packageFile repo pkgid) + else do setupMessage verbosity "Downloading" pkgid + downloadRepoPackage + where + downloadRepoPackage = case repoKind repo of + Right LocalRepo -> return (packageFile repo pkgid) + + Left remoteRepo -> do + let uri = packageURI remoteRepo pkgid + dir = packageDir repo pkgid + path = packageFile repo pkgid + createDirectoryIfMissing True dir + downloadURI verbosity uri path + return path + +-- | Downloads an index file to [config-dir/packages/serv-id]. +-- +downloadIndex :: Verbosity -> RemoteRepo -> FilePath -> IO FilePath +downloadIndex verbosity repo cacheDir = do + let uri = (remoteRepoURI repo) { + uriPath = uriPath (remoteRepoURI repo) + `FilePath.Posix.combine` "00-index.tar.gz" + } + path = cacheDir "00-index" <.> "tar.gz" + createDirectoryIfMissing True cacheDir + downloadURI verbosity uri path + return path + + +-- ------------------------------------------------------------ +-- * Path utilities +-- ------------------------------------------------------------ + +-- | Generate the full path to the locally cached copy of +-- the tarball for a given @PackageIdentifer@. +-- +packageFile :: Repo -> PackageId -> FilePath +packageFile repo pkgid = packageDir repo pkgid + display pkgid + <.> "tar.gz" + +-- | Generate the full path to the directory where the local cached copy of +-- the tarball for a given @PackageIdentifer@ is stored. +-- +packageDir :: Repo -> PackageId -> FilePath +packageDir repo pkgid = repoLocalDir repo + display (packageName pkgid) + display (packageVersion pkgid) + +-- | Generate the URI of the tarball for a given package. +-- +packageURI :: RemoteRepo -> PackageId -> URI +packageURI repo pkgid | isOldHackageURI (remoteRepoURI repo) = + (remoteRepoURI repo) { + uriPath = FilePath.Posix.joinPath + [uriPath (remoteRepoURI repo) + ,display (packageName pkgid) + ,display (packageVersion pkgid) + ,display pkgid <.> "tar.gz"] + } +packageURI repo pkgid = + (remoteRepoURI repo) { + uriPath = FilePath.Posix.joinPath + [uriPath (remoteRepoURI repo) + ,"package" + ,display pkgid <.> "tar.gz"] + } diff --git a/Distribution/Client/GZipUtils.hs b/Distribution/Client/GZipUtils.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/GZipUtils.hs @@ -0,0 +1,44 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.GZipUtils +-- Copyright : (c) Dmitry Astapov 2010 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Provides a convenience functions for working with files that may or may not +-- be zipped. +----------------------------------------------------------------------------- +module Distribution.Client.GZipUtils ( + maybeDecompress, + ) where + +import qualified Data.ByteString.Lazy.Internal as BS (ByteString(..)) +import Data.ByteString.Lazy (ByteString) +import Codec.Compression.GZip +import Codec.Compression.Zlib.Internal + +-- | Attempts to decompress the `bytes' under the assumption that +-- "data format" error at the very beginning of the stream means +-- that it is already decompressed. Caller should make sanity checks +-- to verify that it is not, in fact, garbage. +-- +-- 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 + where + -- DataError at the beginning of the stream probably means that stream is not compressed. + -- Returning it as-is. + -- TODO: alternatively, we might consider looking for the two magic bytes + -- at the beginning of the gzip header. + foldStream (StreamError DataError _) = bytes + foldStream somethingElse = doFold somethingElse + + doFold StreamEnd = BS.Empty + doFold (StreamChunk bs stream) = BS.Chunk bs (doFold stream) + doFold (StreamError _ msg) = error $ "Codec.Compression.Zlib: " ++ msg diff --git a/Distribution/Client/Haddock.hs b/Distribution/Client/Haddock.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Haddock.hs @@ -0,0 +1,105 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Haddock +-- Copyright : (c) Andrea Vezzosi 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Interfacing with Haddock +-- +----------------------------------------------------------------------------- +module Distribution.Client.Haddock + ( + regenerateHaddockIndex + ) + where + +import Data.Maybe (listToMaybe) +import Data.List (maximumBy) +import Control.Monad (guard) +import System.Directory (createDirectoryIfMissing, doesFileExist, + renameFile) +import System.FilePath ((), splitFileName) +import Distribution.Package (Package(..)) +import Distribution.Simple.Program (haddockProgram, ProgramConfiguration + , rawSystemProgram, requireProgramVersion) +import Distribution.Version (Version(Version), orLaterVersion) +import Distribution.Verbosity (Verbosity) +import Distribution.Text (display) +import Distribution.Client.PackageIndex(PackageIndex, allPackages, + allPackagesByName, fromList) +import Distribution.Simple.Utils + ( comparing, intercalate, debug + , installDirectoryContents, withTempDirectory ) +import Distribution.InstalledPackageInfo as InstalledPackageInfo + ( InstalledPackageInfo + , InstalledPackageInfo_(haddockHTMLs, haddockInterfaces, exposed) ) +import Distribution.Client.Types + ( InstalledPackage(..) ) + +regenerateHaddockIndex :: Verbosity -> PackageIndex InstalledPackage -> ProgramConfiguration -> FilePath -> IO () +regenerateHaddockIndex verbosity pkgs conf index = do + (paths,warns) <- haddockPackagePaths pkgs' + case warns of + Nothing -> return () + Just m -> debug verbosity m + + (confHaddock, _, _) <- + requireProgramVersion verbosity haddockProgram + (orLaterVersion (Version [0,6] [])) conf + + createDirectoryIfMissing True destDir + + withTempDirectory verbosity destDir "tmphaddock" $ \tempDir -> do + + let flags = [ "--gen-contents" + , "--gen-index" + , "--odir=" ++ tempDir + , "--title=Haskell modules on this system" ] + ++ [ "--read-interface=" ++ html ++ "," ++ interface + | (interface, html) <- paths ] + rawSystemProgram verbosity confHaddock flags + renameFile (tempDir "index.html") (tempDir destFile) + installDirectoryContents verbosity tempDir destDir + + where + (destDir,destFile) = splitFileName index + pkgs' = map (maximumBy $ comparing packageId) + . allPackagesByName + . fromList + . filter exposed + . map (\(InstalledPackage pkg _) -> pkg) + . allPackages + $ pkgs + +haddockPackagePaths :: [InstalledPackageInfo] + -> IO ([(FilePath, FilePath)], Maybe String) +haddockPackagePaths pkgs = do + interfaces <- sequence + [ case interfaceAndHtmlPath pkg of + Just (interface, html) -> do + exists <- doesFileExist interface + if exists + then return (pkgid, Just (interface, html)) + else return (pkgid, Nothing) + Nothing -> return (pkgid, Nothing) + | pkg <- pkgs, let pkgid = packageId pkg ] + + let missing = [ pkgid | (pkgid, Nothing) <- interfaces ] + + warning = "The documentation for the following packages are not " + ++ "installed. No links will be generated to these packages: " + ++ intercalate ", " (map display missing) + + flags = [ x | (_, Just x) <- interfaces ] + + return (flags, if null missing then Nothing else Just warning) + + where + interfaceAndHtmlPath pkg = do + interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg) + html <- listToMaybe (InstalledPackageInfo.haddockHTMLs pkg) + guard (not . null $ html) + return (interface, html) diff --git a/Distribution/Client/HttpUtils.hs b/Distribution/Client/HttpUtils.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/HttpUtils.hs @@ -0,0 +1,197 @@ +{-# OPTIONS -cpp #-} +----------------------------------------------------------------------------- +-- | Separate module for HTTP actions, using a proxy server if one exists +----------------------------------------------------------------------------- +module Distribution.Client.HttpUtils ( + downloadURI, + getHTTP, + proxy, + isOldHackageURI + ) where + +import Network.HTTP + ( Request (..), Response (..), RequestMethod (..) + , Header(..), HeaderName(..) ) +import Network.URI + ( URI (..), URIAuth (..), parseAbsoluteURI ) +import Network.Stream + ( Result, ConnError(..) ) +import Network.Browser + ( Proxy (..), Authority (..), browse + , setOutHandler, setErrHandler, setProxy, request) +import Control.Monad + ( mplus, join, liftM2 ) +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 + , copyFileVerbose, writeFileAtomic ) +import Distribution.Text + ( display ) +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) + +proxyString = liftM2 mplus envProxyString registryProxyString + + +-- |Get the local proxy settings +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 + +mkRequest :: URI -> Request ByteString +mkRequest uri = Request{ rqURI = uri + , rqMethod = GET + , rqHeaders = [Header HdrUserAgent userAgent] + , rqBody = ByteString.empty } + where userAgent = "cabal-install/" ++ display Paths_cabal_install_bundle.version + +-- |Carry out a GET request, using the local proxy settings +getHTTP :: Verbosity -> URI -> IO (Result (Response ByteString)) +getHTTP verbosity uri = do + p <- proxy verbosity + let req = mkRequest uri + (_, resp) <- browse $ do + setErrHandler (warn verbosity . ("http error: "++)) + setOutHandler (debug verbosity) + setProxy p + request req + return (Right resp) + +downloadURI :: Verbosity + -> URI -- ^ What to download + -> FilePath -- ^ Where to put it + -> IO () +downloadURI verbosity uri path | uriScheme uri == "file:" = + copyFileVerbose verbosity (uriPath uri) path +downloadURI verbosity uri path = do + result <- getHTTP verbosity uri + let result' = case result of + Left err -> Left err + Right rsp -> case rspCode rsp of + (2,0,0) -> Right (rspBody rsp) + (a,b,c) -> Left err + where + err = ErrorMisc $ "Unsucessful HTTP code: " + ++ concatMap show [a,b,c] + + 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) + --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 +isOldHackageURI uri + = case uriAuthority uri of + Just (URIAuth {uriRegName = "hackage.haskell.org"}) -> + FilePath.Posix.splitDirectories (uriPath uri) == ["/","packages","archive"] + _ -> False diff --git a/Distribution/Client/IndexUtils.hs b/Distribution/Client/IndexUtils.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/IndexUtils.hs @@ -0,0 +1,265 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.IndexUtils +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : duncan@community.haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Extra utils related to the package indexes. +----------------------------------------------------------------------------- +module Distribution.Client.IndexUtils ( + getInstalledPackages, + getAvailablePackages, + + readPackageIndexFile, + parseRepoIndex, + ) where + +import qualified Distribution.Client.Tar as Tar +import Distribution.Client.Types + +import Distribution.Package + ( PackageId, PackageIdentifier(..), PackageName(..) + , Package(..), packageVersion + , 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 Distribution.PackageDescription + ( GenericPackageDescription ) +import Distribution.PackageDescription.Parse + ( parsePackageDescription ) +import Distribution.Simple.Compiler + ( Compiler, PackageDBStack ) +import Distribution.Simple.Program + ( ProgramConfiguration ) +import qualified Distribution.Simple.Configure as Configure + ( getInstalledPackages ) +import Distribution.ParseUtils + ( ParseResult(..) ) +import Distribution.Version + ( Version(Version), intersectVersionRanges ) +import Distribution.Text + ( simpleParse ) +import Distribution.Verbosity + ( Verbosity, lessVerbose ) +import Distribution.Simple.Utils + ( warn, info, fromUTF8, equating ) + +import Data.Maybe (catMaybes, fromMaybe) +import Data.List (isPrefixOf, groupBy) +import Data.Monoid (Monoid(..)) +import qualified Data.Map as Map +import Control.Monad (MonadPlus(mplus), when) +import Control.Exception (evaluate) +import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString.Lazy.Char8 as BS.Char8 +import Data.ByteString.Lazy (ByteString) +import Distribution.Client.GZipUtils (maybeDecompress) +import System.FilePath ((), takeExtension, splitDirectories, normalise) +import System.FilePath.Posix as FilePath.Posix + ( takeFileName ) +import System.IO.Error (isDoesNotExistError) +import System.Directory + ( getModificationTime ) +import System.Time + ( getClockTime, diffClockTimes, normalizeTimeDiff, TimeDiff(tdDay) ) + +getInstalledPackages :: Verbosity -> Compiler + -> PackageDBStack -> ProgramConfiguration + -> IO (PackageIndex InstalledPackage) +getInstalledPackages verbosity comp packageDbs conf = + fmap convert (Configure.getInstalledPackages verbosity' + comp packageDbs conf) + where + --FIXME: make getInstalledPackages use sensible verbosity in the first place + verbosity' = lessVerbose verbosity + + convert :: InstalledPackageIndex.PackageIndex -> PackageIndex InstalledPackage + convert index = PackageIndex.fromList + -- There can be multiple installed instances of each package version, + -- like when the same package is installed in the global & user dbs. + -- InstalledPackageIndex.allPackagesByName gives us the installed + -- packages with the most preferred instances first, so by picking the + -- first we should get the user one. This is almost but not quite the + -- same as what ghc does. + [ InstalledPackage ipkg (sourceDeps index ipkg) + | ipkgs <- InstalledPackageIndex.allPackagesByName index + , (ipkg:_) <- groupBy (equating packageVersion) ipkgs ] + + -- The InstalledPackageInfo only lists dependencies by the + -- InstalledPackageId, which means we do not directly know the corresponding + -- source dependency. The only way to find out is to lookup the + -- InstalledPackageId to get the InstalledPackageInfo and look at its + -- source PackageId. But if the package is broken because it depends on + -- other packages that do not exist then we have a problem we cannot find + -- the original source package id. Instead we make up a bogus package id. + -- This should have the same effect since it should be a dependency on a + -- non-existant package. + sourceDeps index ipkg = + [ maybe (brokenPackageId depid) packageId mdep + | let depids = InstalledPackageInfo.depends ipkg + getpkg = InstalledPackageIndex.lookupInstalledPackageId index + , (depid, mdep) <- zip depids (map getpkg depids) ] + + brokenPackageId (InstalledPackageId str) = + PackageIdentifier (PackageName (str ++ "-broken")) (Version [] []) + +-- | Read a repository index from disk, from the local files specified by +-- a list of 'Repo's. +-- +-- All the 'AvailablePackage's are marked as having come from the appropriate +-- 'Repo'. +-- +-- This is a higher level wrapper used internally in cabal-install. +-- +getAvailablePackages :: Verbosity -> [Repo] -> IO AvailablePackageDb +getAvailablePackages verbosity [] = do + warn verbosity $ "No remote package servers have been specified. Usually " + ++ "you would have one specified in the config file." + return AvailablePackageDb { + packageIndex = mempty, + packagePreferences = mempty + } +getAvailablePackages verbosity repos = do + info verbosity "Reading available packages..." + pkgss <- mapM (readRepoIndex verbosity) repos + let (pkgs, prefs) = mconcat pkgss + prefs' = Map.fromListWith intersectVersionRanges + [ (name, range) | Dependency name range <- prefs ] + _ <- evaluate pkgs + _ <- evaluate prefs' + return AvailablePackageDb { + packageIndex = pkgs, + packagePreferences = prefs' + } + +-- | Read a repository index from disk, from the local file specified by +-- the 'Repo'. +-- +-- All the 'AvailablePackage's are marked as having come from the given 'Repo'. +-- +-- This is a higher level wrapper used internally in cabal-install. +-- +readRepoIndex :: Verbosity -> Repo + -> IO (PackageIndex AvailablePackage, [Dependency]) +readRepoIndex verbosity repo = handleNotFound $ do + let indexFile = repoLocalDir repo "00-index.tar" + (pkgs, prefs) <- either fail return + . foldlTarball extract ([], []) + =<< BS.readFile indexFile + + pkgIndex <- evaluate $ PackageIndex.fromList + [ AvailablePackage { + packageInfoId = pkgid, + packageDescription = pkg, + packageSource = RepoTarballPackage repo pkgid Nothing + } + | (pkgid, pkg) <- pkgs] + + warnIfIndexIsOld indexFile + return (pkgIndex, prefs) + + where + extract (pkgs, prefs) entry = fromMaybe (pkgs, prefs) $ + (do pkg <- extractPkg entry; return (pkg:pkgs, prefs)) + `mplus` (do prefs' <- extractPrefs entry; return (pkgs, prefs'++prefs)) + + extractPrefs :: Tar.Entry -> Maybe [Dependency] + extractPrefs entry = case Tar.entryContent entry of + Tar.NormalFile content _ + | takeFileName (Tar.entryPath entry) == "preferred-versions" + -> Just . parsePreferredVersions + . BS.Char8.unpack $ content + _ -> Nothing + + handleNotFound action = catch action $ \e -> if isDoesNotExistError e + then do + case repoKind repo of + Left remoteRepo -> warn verbosity $ + "The package list for '" ++ remoteRepoName remoteRepo + ++ "' does not exist. Run 'cabal update' to download it." + Right _localRepo -> warn verbosity $ + "The package list for the local repo '" ++ repoLocalDir repo + ++ "' is missing. The repo is invalid." + return mempty + else ioError e + + isOldThreshold = 15 --days + warnIfIndexIsOld indexFile = do + indexTime <- getModificationTime indexFile + currentTime <- getClockTime + let diff = normalizeTimeDiff (diffClockTimes currentTime indexTime) + when (tdDay diff >= isOldThreshold) $ case repoKind repo of + Left remoteRepo -> warn verbosity $ + "The package list for '" ++ remoteRepoName remoteRepo + ++ "' is " ++ show (tdDay diff) ++ " days old.\nRun " + ++ "'cabal update' to get the latest list of available packages." + Right _localRepo -> return () + +parsePreferredVersions :: String -> [Dependency] +parsePreferredVersions = catMaybes + . map simpleParse + . filter (not . isPrefixOf "--") + . lines + +-- | 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 +-- the hackage package index. +-- +-- It takes a function to map a 'GenericPackageDescription' into any more +-- specific instance of 'Package' that you might want to use. In the simple +-- case you can just use @\_ p -> p@ here. +-- +readPackageIndexFile :: Package pkg + => (PackageId -> GenericPackageDescription -> pkg) + -> FilePath -> IO (PackageIndex pkg) +readPackageIndexFile mkPkg indexFile = do + pkgs <- either fail return + . parseRepoIndex + . maybeDecompress + =<< BS.readFile indexFile + + evaluate $ PackageIndex.fromList + [ mkPkg pkgid pkg | (pkgid, pkg) <- pkgs] + +-- | Parse an uncompressed \"00-index.tar\" repository index file represented +-- as a 'ByteString'. +-- +parseRepoIndex :: ByteString + -> Either String [(PackageId, GenericPackageDescription)] +parseRepoIndex = foldlTarball (\pkgs -> maybe pkgs (:pkgs) . extractPkg) [] + +extractPkg :: Tar.Entry -> Maybe (PackageId, GenericPackageDescription) +extractPkg entry = 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) + where + pkgid = PackageIdentifier (PackageName pkgname) ver + parsed = parsePackageDescription . fromUTF8 . BS.Char8.unpack + $ content + descr = case parsed of + ParseOk _ d -> d + _ -> error $ "Couldn't read cabal file " + ++ show fileName + _ -> Nothing + _ -> Nothing + _ -> Nothing + where + fileName = Tar.entryPath entry + +foldlTarball :: (a -> Tar.Entry -> a) -> a + -> ByteString -> Either String a +foldlTarball f z = either Left (Right . foldl f z) . check [] . Tar.read + where + check _ (Tar.Fail err) = Left err + check ok Tar.Done = Right ok + check ok (Tar.Next e es) = check (e:ok) es diff --git a/Distribution/Client/Init.hs b/Distribution/Client/Init.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Init.hs @@ -0,0 +1,556 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Init +-- Copyright : (c) Brent Yorgey 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Implementation of the 'cabal init' command, which creates an initial .cabal +-- file for a project. +-- +----------------------------------------------------------------------------- + +module Distribution.Client.Init ( + + -- * Commands + initCabal + + ) where + +import System.IO + ( hSetBuffering, stdout, BufferMode(..) ) +import System.Directory + ( getCurrentDirectory ) +import Data.Time + ( getCurrentTime, utcToLocalTime, toGregorian, localDay, getCurrentTimeZone ) + +import Data.List + ( intersperse ) +import Data.Maybe + ( fromMaybe, isJust ) +import Data.Traversable + ( traverse ) +import Control.Monad + ( when ) +#if MIN_VERSION_base(3,0,0) +import Control.Monad + ( (>=>) ) +#endif + +import Text.PrettyPrint.HughesPJ hiding (mode, cat) + +import Data.Version + ( Version(..) ) +import Distribution.Version + ( orLaterVersion ) + +import Distribution.Client.Init.Types + ( InitFlags(..), PackageType(..), Category(..) ) +import Distribution.Client.Init.Licenses + ( bsd3, gplv2, gplv3, lgpl2, lgpl3 ) +import Distribution.Client.Init.Heuristics + ( guessPackageName, guessAuthorNameMail, SourceFileEntry(..), scanForModules, neededBuildPrograms ) + +import Distribution.License + ( License(..), knownLicenses ) +import Distribution.ModuleName + ( ) -- for the Text instance + +import Distribution.ReadE + ( runReadE, readP_to_E ) +import Distribution.Simple.Setup + ( Flag(..), flagToMaybe ) +import Distribution.Text + ( display, Text(..) ) + +initCabal :: InitFlags -> IO () +initCabal initFlags = do + hSetBuffering stdout NoBuffering + + initFlags' <- extendFlags initFlags + + writeLicense initFlags' + writeSetupFile initFlags' + success <- writeCabalFile initFlags' + + when success $ generateWarnings initFlags' + +--------------------------------------------------------------------------- +-- Flag acquisition ----------------------------------------------------- +--------------------------------------------------------------------------- + +-- | Fill in more details by guessing, discovering, or prompting the +-- user. +extendFlags :: InitFlags -> IO InitFlags +extendFlags = getPackageName + >=> getVersion + >=> getLicense + >=> getAuthorInfo + >=> getHomepage + >=> getSynopsis + >=> getCategory + >=> getLibOrExec + >=> getSrcDir + >=> getModulesAndBuildTools + +-- | Combine two actions which may return a value, preferring the first. That +-- is, run the second action only if the first doesn't return a value. +infixr 1 ?>> +(?>>) :: IO (Maybe a) -> IO (Maybe a) -> IO (Maybe a) +f ?>> g = do + ma <- f + if isJust ma + then return ma + else g + +-- | Witness the isomorphism between Maybe and Flag. +maybeToFlag :: Maybe a -> Flag a +maybeToFlag = maybe NoFlag Flag + +-- | Get the package name: use the package directory (supplied, or the current +-- directory by default) as a guess. +getPackageName :: InitFlags -> IO InitFlags +getPackageName flags = do + guess <- traverse guessPackageName (flagToMaybe $ packageDir flags) + ?>> Just `fmap` (getCurrentDirectory >>= guessPackageName) + + pkgName' <- return (flagToMaybe $ packageName flags) + ?>> maybePrompt flags (promptStr "Package name" guess) + ?>> return guess + + return $ flags { packageName = maybeToFlag pkgName' } + +-- | Package version: use 0.1 as a last resort, but try prompting the user if +-- possible. +getVersion :: InitFlags -> IO InitFlags +getVersion flags = do + let v = Just $ Version { versionBranch = [0,1], versionTags = [] } + v' <- return (flagToMaybe $ version flags) + ?>> maybePrompt flags (prompt "Package version" v) + ?>> return v + return $ flags { version = maybeToFlag v' } + +-- | Choose a license. +getLicense :: InitFlags -> IO InitFlags +getLicense flags = do + lic <- return (flagToMaybe $ license flags) + ?>> fmap (fmap (either UnknownLicense id)) + (maybePrompt flags + (promptList "Please choose a license" + knownLicenses (Just BSD3) True)) + return $ flags { license = maybeToFlag lic } + +-- | 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' <- return (flagToMaybe $ author flags) + ?>> maybePrompt flags (promptStr "Author name" authorName) + ?>> return authorName + + authorEmail' <- return (flagToMaybe $ email flags) + ?>> maybePrompt flags (promptStr "Maintainer email" authorEmail) + ?>> return authorEmail + + return $ flags { author = maybeToFlag authorName' + , email = maybeToFlag authorEmail' + } + +-- | Prompt for a homepage URL. +getHomepage :: InitFlags -> IO InitFlags +getHomepage flags = do + hp <- queryHomepage + hp' <- return (flagToMaybe $ homepage flags) + ?>> maybePrompt flags (promptStr "Project homepage/repo URL" hp) + ?>> return hp + + return $ flags { homepage = maybeToFlag hp' } + +-- | Right now this does nothing, but it could be changed to do some +-- intelligent guessing. +queryHomepage :: IO (Maybe String) +queryHomepage = return Nothing -- get default remote darcs repo? + +-- | Prompt for a project synopsis. +getSynopsis :: InitFlags -> IO InitFlags +getSynopsis flags = do + syn <- return (flagToMaybe $ synopsis flags) + ?>> maybePrompt flags (promptStr "Project synopsis" Nothing) + + return $ flags { synopsis = maybeToFlag syn } + +-- | Prompt for a package category. +-- Note that it should be possible to do some smarter guessing here too, i.e. +-- look at the name of the top level source directory. +getCategory :: InitFlags -> IO InitFlags +getCategory flags = do + cat <- return (flagToMaybe $ category flags) + ?>> maybePrompt flags (promptList "Project category" [Codec ..] + Nothing True) + return $ flags { category = maybeToFlag cat } + +-- | 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 False)) + ?>> return (Just Library) + + return $ flags { packageType = maybeToFlag isLib } + +-- | Try to guess the source root directory (don't prompt the user). +getSrcDir :: InitFlags -> IO InitFlags +getSrcDir flags = do + srcDirs <- return (sourceDirs flags) + ?>> guessSourceDirs + + return $ flags { sourceDirs = srcDirs } + +-- XXX +-- | Try to guess source directories. +guessSourceDirs :: IO (Maybe [String]) +guessSourceDirs = return Nothing + +-- | Get the list of exposed modules and extra tools needed to build them. +getModulesAndBuildTools :: InitFlags -> IO InitFlags +getModulesAndBuildTools flags = do + dir <- fromMaybe getCurrentDirectory + (fmap return . flagToMaybe $ packageDir flags) + + -- XXX really should use guessed source roots. + sourceFiles <- scanForModules dir + + mods <- return (exposedModules flags) + ?>> (return . Just . map moduleName $ sourceFiles) + + tools <- return (buildTools flags) + ?>> (return . Just . neededBuildPrograms $ sourceFiles) + + return $ flags { exposedModules = mods + , buildTools = tools } + +--------------------------------------------------------------------------- +-- Prompting/user interaction ------------------------------------------- +--------------------------------------------------------------------------- + +-- | Run a prompt or not based on the nonInteractive flag of the +-- InitFlags structure. +maybePrompt :: InitFlags -> IO t -> IO (Maybe t) +maybePrompt flags p = + case nonInteractive flags of + Flag True -> return Nothing + _ -> Just `fmap` p + +-- | Create a prompt with optional default value that returns a +-- String. +promptStr :: String -> Maybe String -> IO String +promptStr = promptDefault' Just id + +-- | Create a prompt with optional default value that returns a value +-- of some Text instance. +prompt :: Text t => String -> Maybe t -> IO t +prompt = promptDefault' + (either (const Nothing) Just . runReadE (readP_to_E id parse)) + display + +-- | Create a prompt with an optional default value. +promptDefault' :: (String -> Maybe t) -- ^ parser + -> (t -> String) -- ^ pretty-printer + -> String -- ^ prompt message + -> Maybe t -- ^ optional default value + -> IO t +promptDefault' parser pretty pr def = do + putStr $ mkDefPrompt pr (pretty `fmap` def) + inp <- getLine + case (inp, def) of + ("", Just d) -> return d + _ -> case parser inp of + Just t -> return t + Nothing -> do putStrLn $ "Couldn't parse " ++ inp ++ ", please try again!" + promptDefault' parser pretty pr def + +-- | Create a prompt from a prompt string and a String representation +-- of an optional default value. +mkDefPrompt :: String -> Maybe String -> String +mkDefPrompt pr def = pr ++ defStr def ++ "? " + where defStr Nothing = "" + defStr (Just s) = " [default \"" ++ s ++ "\"]" + +-- | Create a prompt from a list of items. +promptList :: (Text t, Eq t) + => String -- ^ prompt + -> [t] -- ^ choices + -> Maybe t -- ^ optional default value + -> Bool -- ^ whether to allow an 'other' option + -> IO (Either String t) +promptList pr choices def other = do + putStrLn $ pr ++ ":" + let options1 = map (\c -> (Just c == def, display c)) choices + options2 = zip ([1..]::[Int]) + (options1 ++ if other then [(False, "Other (specify)")] + else []) + mapM_ (putStrLn . \(n,(i,s)) -> showOption n i ++ s) options2 + promptList' (length options2) choices def other + where showOption n i | n < 10 = " " ++ star i ++ " " ++ rest + | otherwise = " " ++ star i ++ rest + where rest = show n ++ ") " + star True = "*" + star False = " " + +promptList' :: Text t => Int -> [t] -> Maybe t -> Bool -> IO (Either String t) +promptList' numChoices choices def other = do + putStr $ mkDefPrompt "Your choice" (display `fmap` def) + inp <- getLine + case (inp, def) of + ("", Just d) -> return $ Right d + _ -> case readMaybe inp of + Nothing -> invalidChoice inp + Just n -> getChoice n + where invalidChoice inp = do putStrLn $ inp ++ " is not a valid choice." + promptList' numChoices choices def other + getChoice n | n < 1 || n > numChoices = invalidChoice (show n) + | n < numChoices || + (n == numChoices && not other) + = return . Right $ choices !! (n-1) + | otherwise = Left `fmap` promptStr "Please specify" Nothing + +readMaybe :: (Read a) => String -> Maybe a +readMaybe s = case reads s of + [(a,"")] -> Just a + _ -> Nothing + +--------------------------------------------------------------------------- +-- File generation ------------------------------------------------------ +--------------------------------------------------------------------------- + +writeLicense :: InitFlags -> IO () +writeLicense flags = do + message flags "Generating LICENSE..." + year <- getYear + let licenseFile = + case license flags of + Flag BSD3 -> Just $ bsd3 (fromMaybe "???" + . flagToMaybe + . author + $ flags) + (show year) + + Flag (GPL (Just (Version {versionBranch = [2]}))) + -> Just gplv2 + + Flag (GPL (Just (Version {versionBranch = [3]}))) + -> Just gplv3 + + Flag (LGPL (Just (Version {versionBranch = [2]}))) + -> Just lgpl2 + + Flag (LGPL (Just (Version {versionBranch = [3]}))) + -> Just lgpl3 + + _ -> Nothing + + case licenseFile of + Just licenseText -> writeFile "LICENSE" licenseText + Nothing -> message flags "Warning: unknown license type, you must put a copy in LICENSE yourself." + +getYear :: IO Integer +getYear = do + u <- getCurrentTime + z <- getCurrentTimeZone + let l = utcToLocalTime z u + (y, _, _) = toGregorian $ localDay l + return y + +writeSetupFile :: InitFlags -> IO () +writeSetupFile flags = do + message flags "Generating Setup.hs..." + writeFile "Setup.hs" setupFile + where + setupFile = unlines + [ "import Distribution.Simple" + , "main = defaultMain" + ] + +writeCabalFile :: InitFlags -> IO Bool +writeCabalFile flags@(InitFlags{packageName = NoFlag}) = do + message flags "Error: no package name provided." + return False +writeCabalFile flags@(InitFlags{packageName = Flag p}) = do + let cabalFileName = p ++ ".cabal" + message flags $ "Generating " ++ cabalFileName ++ "..." + writeFile cabalFileName (generateCabalFile cabalFileName flags) + return True + +-- | 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 +-- preserves things like comments, and to write an *inverse* +-- parser/pretty-printer pair between .cabal files and this AST. +-- Then instead of this ad-hoc code we could just map an InitFlags +-- structure onto a low-level AST structure and use the existing +-- pretty-printing code to generate the file. +generateCabalFile :: String -> InitFlags -> String +generateCabalFile fileName c = render $ + (if (minimal c /= Flag True) + then showComment (Just $ fileName ++ " auto-generated by cabal init. For additional options, see http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.") + else empty) + $$ + vcat [ fieldS "Name" (packageName c) + (Just "The name of the package.") + True + + , field "Version" (version c) + (Just "The package version. See the Haskell package versioning policy (http://www.haskell.org/haskellwiki/Package_versioning_policy) for standards guiding when and how versions should be incremented.") + True + + , fieldS "Synopsis" (synopsis c) + (Just "A short (one-line) description of the package.") + True + + , fieldS "Description" NoFlag + (Just "A longer description of the package.") + True + + , fieldS "Homepage" (homepage c) + (Just "URL for the project homepage or repository.") + False + + , fieldS "Bug-reports" NoFlag + (Just "A URL where users can report bugs.") + False + + , field "License" (license c) + (Just "The license under which the package is released.") + True + + , fieldS "License-file" (Flag "LICENSE") + (Just "The file containing the license text.") + True + + , fieldS "Author" (author c) + (Just "The package author(s).") + True + + , fieldS "Maintainer" (email c) + (Just "An email address to which users can send suggestions, bug reports, and patches.") + True + + , fieldS "Copyright" NoFlag + (Just "A copyright notice.") + True + + , fieldS "Category" (either id display `fmap` category c) + Nothing + True + + , fieldS "Build-type" (Flag "Simple") + Nothing + True + + , fieldS "Extra-source-files" NoFlag + (Just "Extra files to be distributed with the package, such as examples or a README.") + True + + , field "Cabal-version" (Flag $ orLaterVersion (Version [1,2] [])) + (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 + [ fieldS "Main-is" NoFlag (Just ".hs or .lhs file containing the Main module.") True + + , generateBuildInfo c + ]) + Flag Library -> text "\nLibrary" $$ (nest 2 $ vcat + [ fieldS "Exposed-modules" (listField (exposedModules c)) + (Just "Modules exported by the library.") + True + + , generateBuildInfo c + ]) + _ -> empty + ] + where + generateBuildInfo :: InitFlags -> Doc + generateBuildInfo c' = vcat + [ fieldS "Build-depends" (listField (dependencies c')) + (Just "Packages needed in order to build this package.") + True + + , fieldS "Other-modules" (listField (otherModules c')) + (Just "Modules not exported by this package.") + True + + , fieldS "hs-source-dirs" (listFieldS (sourceDirs c')) + (Just "Directories other than the root containing source files.") + False + + , fieldS "Build-tools" (listFieldS (buildTools c')) + (Just "Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.") + True + ] + + listField :: Text s => Maybe [s] -> Flag String + listField = listFieldS . fmap (map display) + + listFieldS :: Maybe [String] -> Flag String + listFieldS = Flag . maybe "" (concat . intersperse ", ") + + field :: Text t => String -> Flag t -> Maybe String -> Bool -> Doc + field s f = fieldS s (fmap display f) + + fieldS :: String -- ^ Name of the field + -> Flag String -- ^ Field contents + -> Maybe String -- ^ Comment to explain the field + -> Bool -- ^ Should the field be included (commented out) even if blank? + -> Doc + fieldS _ NoFlag _ inc | not inc || (minimal c == Flag True) = empty + fieldS _ (Flag "") _ inc | not inc || (minimal c == Flag True) = empty + fieldS s f com _ = case (isJust com, noComments c, minimal c) of + (_, _, Flag True) -> id + (_, Flag True, _) -> id + (True, _, _) -> (showComment com $$) . ($$ text "") + (False, _, _) -> ($$ text "") + $ + comment f <> text s <> colon + <> text (take (20 - length s) (repeat ' ')) + <> text (fromMaybe "" . flagToMaybe $ f) + comment NoFlag = text "-- " + comment (Flag "") = text "-- " + comment _ = text "" + + showComment :: Maybe String -> Doc + showComment (Just t) = vcat . map text + . map ("-- "++) . lines + . render . fsep . map text . words $ t + showComment Nothing = text "" + +-- | Generate warnings for missing fields etc. +generateWarnings :: InitFlags -> IO () +generateWarnings flags = do + message flags "" + when (synopsis flags `elem` [NoFlag, Flag ""]) + (message flags "Warning: no synopsis given. You should edit the .cabal file and add one.") + + message flags "You may want to edit the .cabal file and add a Description field." + +-- | Possibly generate a message to stdout, taking into account the +-- --quiet flag. +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 new file mode 100644 --- /dev/null +++ b/Distribution/Client/Init/Heuristics.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Init.Heuristics +-- Copyright : (c) Benedikt Huber 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Heuristics for creating initial cabal files. +-- +----------------------------------------------------------------------------- +module Distribution.Client.Init.Heuristics ( + guessPackageName, + scanForModules, SourceFileEntry(..), + neededBuildPrograms, + guessAuthorNameMail, + knownCategories, +) where +import Distribution.Simple.Setup(Flag(..)) +import Distribution.ModuleName ( ModuleName, fromString ) +import Distribution.Client.PackageIndex + ( allPackagesByName ) +import qualified Distribution.PackageDescription as PD + ( category, packageDescription ) +import Distribution.Simple.Utils + ( intercalate ) + +import Distribution.Client.Types ( packageDescription, AvailablePackageDb(..) ) +import Control.Monad (liftM ) +import Data.Char ( isUpper, isLower, isSpace ) +#if MIN_VERSION_base(3,0,3) +import Data.Either ( partitionEithers ) +#endif +import Data.Maybe ( catMaybes ) +import Data.Monoid ( mempty, mappend ) +import qualified Data.Set as Set ( fromList, toList ) +import System.Directory ( getDirectoryContents, doesDirectoryExist, doesFileExist, + getHomeDirectory, canonicalizePath ) +import System.Environment ( getEnvironment ) +import System.FilePath ( takeExtension, takeBaseName, dropExtension, + (), splitDirectories, makeRelative ) + +-- |Guess the package name based on the given root directory +guessPackageName :: FilePath -> IO String +guessPackageName = liftM (last . splitDirectories) . canonicalizePath + +-- |Data type of source files found in the working directory +data SourceFileEntry = SourceFileEntry + { relativeSourcePath :: FilePath + , moduleName :: ModuleName + , fileExtension :: String + } deriving Show + +-- |Search for source files in the given directory +-- and return pairs of guessed haskell source path and +-- module names. +scanForModules :: FilePath -> IO [SourceFileEntry] +scanForModules rootDir = scanForModulesIn rootDir rootDir + +scanForModulesIn :: FilePath -> FilePath -> IO [SourceFileEntry] +scanForModulesIn projectRoot srcRoot = scan srcRoot [] + where + scan dir hierarchy = do + entries <- getDirectoryContents (projectRoot dir) + (files, dirs) <- liftM partitionEithers (mapM (tagIsDir dir) entries) + let modules = catMaybes [ guessModuleName hierarchy file + | file <- files + , isUpper (head file) ] + recMods <- mapM (scanRecursive dir hierarchy) dirs + return $ concat (modules : recMods) + tagIsDir parent entry = do + isDir <- doesDirectoryExist (parent entry) + return $ (if isDir then Right else Left) entry + guessModuleName hierarchy entry + | takeBaseName entry == "Setup" = Nothing + | ext `elem` sourceExtensions = Just $ SourceFileEntry relRoot modName ext + | otherwise = Nothing + where + relRoot = makeRelative projectRoot srcRoot + unqualModName = dropExtension entry + modName = fromString $ 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) + | otherwise = return [] + ignoreDir ('.':_) = True + ignoreDir dir = dir `elem` ["dist", "_darcs"] + +-- Unfortunately we cannot use the version exported by Distribution.Simple.Program +knownSuffixHandlers :: [(String,String)] +knownSuffixHandlers = + [ ("gc", "greencard") + , ("chs", "chs") + , ("hsc", "hsc2hs") + , ("x", "alex") + , ("y", "happy") + , ("ly", "happy") + , ("cpphs", "cpp") + ] + +sourceExtensions :: [String] +sourceExtensions = "hs" : "lhs" : map fst knownSuffixHandlers + +neededBuildPrograms :: [SourceFileEntry] -> [String] +neededBuildPrograms entries = + [ handler + | ext <- nubSet (map fileExtension entries) + , handler <- maybe [] (:[]) (lookup ext knownSuffixHandlers) + ] + +-- |Guess author and email +guessAuthorNameMail :: IO (Flag String, Flag String) +guessAuthorNameMail = + update (readFromFile authorRepoFile) mempty >>= + update (getAuthorHome >>= readFromFile) >>= + update readFromEnvironment + 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" + +-- |Get list of categories used in hackage. NOTE: Very slow, needs to be cached +knownCategories :: AvailablePackageDb -> [String] +knownCategories (AvailablePackageDb available _) = nubSet $ + [ cat | pkg <- map head (allPackagesByName available) + , let catList = (PD.category . PD.packageDescription . packageDescription) pkg + , cat <- splitString ',' catList + ] + +-- Parse name and email, from darcs pref files or environment variable +nameAndMail :: String -> (Flag String, Flag String) +nameAndMail str + | all isSpace nameOrEmail = mempty + | null erest = (mempty, Flag $ trim nameOrEmail) + | otherwise = (Flag $ trim nameOrEmail, Flag email) + where + (nameOrEmail,erest) = break (== '<') str + (email,_) = break (== '>') (tail erest) + trim = removeLeadingSpace . reverse . removeLeadingSpace . reverse + removeLeadingSpace = dropWhile isSpace + +-- split string at given character, and remove whitespaces +splitString :: Char -> String -> [String] +splitString sep str = go str where + go s = if null s' then [] else tok : go rest where + s' = dropWhile (\c -> c == sep || isSpace c) s + (tok,rest) = break (==sep) s' + +nubSet :: (Ord a) => [a] -> [a] +nubSet = Set.toList . Set.fromList + +{- +test db testProjectRoot = do + putStrLn "Guessed package name" + (guessPackageName >=> print) testProjectRoot + putStrLn "Guessed name and email" + guessAuthorNameMail >>= print + + mods <- scanForModules testProjectRoot + + putStrLn "Guessed modules" + mapM_ print mods + putStrLn "Needed build programs" + print (neededBuildPrograms mods) + + 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 new file mode 100644 --- /dev/null +++ b/Distribution/Client/Init/Licenses.hs @@ -0,0 +1,1722 @@ +module Distribution.Client.Init.Licenses + ( License + , bsd3 + , gplv2 + , gplv3 + , lgpl2 + , lgpl3 + + ) where + +type License = String + +bsd3 :: String -> String -> License +bsd3 authors year = unlines + [ "Copyright (c)" ++ year ++ ", " ++ authors + , "" + , "All rights reserved." + , "" + , "Redistribution and use in source and binary forms, with or without" + , "modification, are permitted provided that the following conditions are met:" + , "" + , " * Redistributions of source code must retain the above copyright" + , " notice, this list of conditions and the following disclaimer." + , "" + , " * Redistributions in binary form must reproduce the above" + , " copyright notice, this list of conditions and the following" + , " disclaimer in the documentation and/or other materials provided" + , " with the distribution." + , "" + , " * Neither the name of " ++ authors ++ " nor the names of other" + , " contributors may be used to endorse or promote products derived" + , " from this software without specific prior written permission." + , "" + , "THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS" + , "\"AS IS\" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT" + , "LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR" + , "A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT" + , "OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL," + , "SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT" + , "LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE," + , "DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY" + , "THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT" + , "(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE" + , "OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." + ] + +gplv2 :: License +gplv2 = unlines + [ " GNU GENERAL PUBLIC LICENSE" + , " Version 2, June 1991" + , "" + , " Copyright (C) 1989, 1991 Free Software Foundation, Inc.," + , " 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA" + , " Everyone is permitted to copy and distribute verbatim copies" + , " of this license document, but changing it is not allowed." + , "" + , " Preamble" + , "" + , " The licenses for most software are designed to take away your" + , "freedom to share and change it. By contrast, the GNU General Public" + , "License is intended to guarantee your freedom to share and change free" + , "software--to make sure the software is free for all its users. This" + , "General Public License applies to most of the Free Software" + , "Foundation's software and to any other program whose authors commit to" + , "using it. (Some other Free Software Foundation software is covered by" + , "the GNU Lesser General Public License instead.) You can apply it to" + , "your programs, too." + , "" + , " 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" + , "this service 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." + , "" + , " To protect your rights, we need to make restrictions that forbid" + , "anyone to deny you these rights or to ask you to surrender the rights." + , "These restrictions translate to certain responsibilities for you if you" + , "distribute copies of the software, or if you modify it." + , "" + , " For example, if you distribute copies of such a program, whether" + , "gratis or for a fee, you must give the recipients all the rights that" + , "you have. You must make sure that they, too, receive or can get the" + , "source code. And you must show them these terms so they know their" + , "rights." + , "" + , " We protect your rights with two steps: (1) copyright the software, and" + , "(2) offer you this license which gives you legal permission to copy," + , "distribute and/or modify the software." + , "" + , " Also, for each author's protection and ours, we want to make certain" + , "that everyone understands that there is no warranty for this free" + , "software. If the software is modified by someone else and passed on, we" + , "want its recipients to know that what they have is not the original, so" + , "that any problems introduced by others will not reflect on the original" + , "authors' reputations." + , "" + , " Finally, any free program is threatened constantly by software" + , "patents. We wish to avoid the danger that redistributors of a free" + , "program will individually obtain patent licenses, in effect making the" + , "program proprietary. To prevent this, we have made it clear that any" + , "patent must be licensed for everyone's free use or not licensed at all." + , "" + , " The precise terms and conditions for copying, distribution and" + , "modification follow." + , "" + , " GNU GENERAL PUBLIC LICENSE" + , " TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION" + , "" + , " 0. This License applies to any program or other work which contains" + , "a notice placed by the copyright holder saying it may be distributed" + , "under the terms of this General Public License. The \"Program\", below," + , "refers to any such program or work, and a \"work based on the Program\"" + , "means either the Program or any derivative work under copyright law:" + , "that is to say, a work containing the Program or a portion of it," + , "either verbatim or with modifications and/or translated into another" + , "language. (Hereinafter, translation is included without limitation in" + , "the term \"modification\".) Each licensee is addressed as \"you\"." + , "" + , "Activities other than copying, distribution and modification are not" + , "covered by this License; they are outside its scope. The act of" + , "running the Program is not restricted, and the output from the Program" + , "is covered only if its contents constitute a work based on the" + , "Program (independent of having been made by running the Program)." + , "Whether that is true depends on what the Program does." + , "" + , " 1. You may copy and distribute 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 and disclaimer of warranty; keep intact all the" + , "notices that refer to this License and to the absence of any warranty;" + , "and give any other recipients of the Program a copy of this License" + , "along with the Program." + , "" + , "You may charge a fee for the physical act of transferring a copy, and" + , "you may at your option offer warranty protection in exchange for a fee." + , "" + , " 2. You may modify your copy or copies of the Program or any portion" + , "of it, thus forming a work based on the Program, and copy and" + , "distribute such modifications or work under the terms of Section 1" + , "above, provided that you also meet all of these conditions:" + , "" + , " a) You must cause the modified files to carry prominent notices" + , " stating that you changed the files and the date of any change." + , "" + , " b) You must cause any work that you distribute or publish, that in" + , " whole or in part contains or is derived from the Program or any" + , " part thereof, to be licensed as a whole at no charge to all third" + , " parties under the terms of this License." + , "" + , " c) If the modified program normally reads commands interactively" + , " when run, you must cause it, when started running for such" + , " interactive use in the most ordinary way, to print or display an" + , " announcement including an appropriate copyright notice and a" + , " notice that there is no warranty (or else, saying that you provide" + , " a warranty) and that users may redistribute the program under" + , " these conditions, and telling the user how to view a copy of this" + , " License. (Exception: if the Program itself is interactive but" + , " does not normally print such an announcement, your work based on" + , " the Program is not required to print an announcement.)" + , "" + , "These requirements apply to the modified work as a whole. If" + , "identifiable sections of that work are not derived from the Program," + , "and can be reasonably considered independent and separate works in" + , "themselves, then this License, and its terms, do not apply to those" + , "sections when you distribute them as separate works. But when you" + , "distribute the same sections as part of a whole which is a work based" + , "on the Program, the distribution of the whole must be on the terms of" + , "this License, whose permissions for other licensees extend to the" + , "entire whole, and thus to each and every part regardless of who wrote it." + , "" + , "Thus, it is not the intent of this section to claim rights or contest" + , "your rights to work written entirely by you; rather, the intent is to" + , "exercise the right to control the distribution of derivative or" + , "collective works based on the Program." + , "" + , "In addition, mere aggregation of another work not based on the Program" + , "with the Program (or with a work based on the Program) on a volume of" + , "a storage or distribution medium does not bring the other work under" + , "the scope of this License." + , "" + , " 3. You may copy and distribute the Program (or a work based on it," + , "under Section 2) in object code or executable form under the terms of" + , "Sections 1 and 2 above provided that you also do one of the following:" + , "" + , " a) Accompany it with the complete corresponding machine-readable" + , " source code, which must be distributed under the terms of Sections" + , " 1 and 2 above on a medium customarily used for software interchange; or," + , "" + , " b) Accompany it with a written offer, valid for at least three" + , " years, to give any third party, for a charge no more than your" + , " cost of physically performing source distribution, a complete" + , " machine-readable copy of the corresponding source code, to be" + , " distributed under the terms of Sections 1 and 2 above on a medium" + , " customarily used for software interchange; or," + , "" + , " c) Accompany it with the information you received as to the offer" + , " to distribute corresponding source code. (This alternative is" + , " allowed only for noncommercial distribution and only if you" + , " received the program in object code or executable form with such" + , " an offer, in accord with Subsection b above.)" + , "" + , "The source code for a work means the preferred form of the work for" + , "making modifications to it. For an executable work, complete source" + , "code means all the source code for all modules it contains, plus any" + , "associated interface definition files, plus the scripts used to" + , "control compilation and installation of the executable. However, as a" + , "special exception, the source code distributed need not include" + , "anything that is normally distributed (in either source or binary" + , "form) with the major components (compiler, kernel, and so on) of the" + , "operating system on which the executable runs, unless that component" + , "itself accompanies the executable." + , "" + , "If distribution of executable or object code is made by offering" + , "access to copy from a designated place, then offering equivalent" + , "access to copy the source code from the same place counts as" + , "distribution of the source code, even though third parties are not" + , "compelled to copy the source along with the object code." + , "" + , " 4. You may not copy, modify, sublicense, or distribute the Program" + , "except as expressly provided under this License. Any attempt" + , "otherwise to copy, modify, sublicense or distribute the Program is" + , "void, and will automatically terminate your rights under this License." + , "However, parties who have received copies, or rights, from you under" + , "this License will not have their licenses terminated so long as such" + , "parties remain in full compliance." + , "" + , " 5. You are not required to accept this License, since you have not" + , "signed it. However, nothing else grants you permission to modify or" + , "distribute the Program or its derivative works. These actions are" + , "prohibited by law if you do not accept this License. Therefore, by" + , "modifying or distributing the Program (or any work based on the" + , "Program), you indicate your acceptance of this License to do so, and" + , "all its terms and conditions for copying, distributing or modifying" + , "the Program or works based on it." + , "" + , " 6. Each time you redistribute the Program (or any work based on the" + , "Program), the recipient automatically receives a license from the" + , "original licensor to copy, distribute or modify the Program subject to" + , "these terms and conditions. You may not impose any further" + , "restrictions on the recipients' exercise of the rights granted herein." + , "You are not responsible for enforcing compliance by third parties to" + , "this License." + , "" + , " 7. If, as a consequence of a court judgment or allegation of patent" + , "infringement or for any other reason (not limited to patent issues)," + , "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" + , "distribute so as to satisfy simultaneously your obligations under this" + , "License and any other pertinent obligations, then as a consequence you" + , "may not distribute the Program at all. For example, if a patent" + , "license would not permit royalty-free redistribution of the Program by" + , "all those who receive copies directly or indirectly through you, then" + , "the only way you could satisfy both it and this License would be to" + , "refrain entirely from distribution of the Program." + , "" + , "If any portion of this section is held invalid or unenforceable under" + , "any particular circumstance, the balance of the section is intended to" + , "apply and the section as a whole is intended to apply in other" + , "circumstances." + , "" + , "It is not the purpose of this section to induce you to infringe any" + , "patents or other property right claims or to contest validity of any" + , "such claims; this section has the sole purpose of protecting the" + , "integrity of the free software distribution system, which is" + , "implemented by public license practices. Many people have made" + , "generous contributions to the wide range of software distributed" + , "through that system in reliance on consistent application of that" + , "system; it is up to the author/donor to decide if he or she is willing" + , "to distribute software through any other system and a licensee cannot" + , "impose that choice." + , "" + , "This section is intended to make thoroughly clear what is believed to" + , "be a consequence of the rest of this License." + , "" + , " 8. If the distribution and/or use of the Program is restricted in" + , "certain countries either by patents or by copyrighted interfaces, the" + , "original copyright holder who places the Program under this License" + , "may add an explicit geographical distribution limitation excluding" + , "those countries, so that distribution is permitted only in or among" + , "countries not thus excluded. In such case, this License incorporates" + , "the limitation as if written in the body of this License." + , "" + , " 9. The Free Software Foundation may publish revised and/or new versions" + , "of the 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 a version number of this License which applies to it and \"any" + , "later version\", you have the option of following the terms and conditions" + , "either of that version or of any later version published by the Free" + , "Software Foundation. If the Program does not specify a version number of" + , "this License, you may choose any version ever published by the Free Software" + , "Foundation." + , "" + , " 10. If you wish to incorporate parts of the Program into other free" + , "programs whose distribution conditions are different, write to the author" + , "to ask for permission. For software which is copyrighted by the Free" + , "Software Foundation, write to the Free Software Foundation; we sometimes" + , "make exceptions for this. Our decision will be guided by the two goals" + , "of preserving the free status of all derivatives of our free software and" + , "of promoting the sharing and reuse of software generally." + , "" + , " NO WARRANTY" + , "" + , " 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, 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." + , "" + , " 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING" + , "WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR" + , "REDISTRIBUTE 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." + , "" + , " 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" + , "convey 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 General Public License as published by" + , " the Free Software Foundation; either version 2 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 General Public License for more details." + , "" + , " You should have received a copy of the GNU General Public License along" + , " with this program; if not, write to the Free Software Foundation, Inc.," + , " 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA." + , "" + , "Also add information on how to contact you by electronic and paper mail." + , "" + , "If the program is interactive, make it output a short notice like this" + , "when it starts in an interactive mode:" + , "" + , " Gnomovision version 69, Copyright (C) year name of author" + , " Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'." + , " This is free software, and you are welcome to redistribute it" + , " under certain conditions; type `show c' for details." + , "" + , "The hypothetical commands `show w' and `show c' should show the appropriate" + , "parts of the General Public License. Of course, the commands you use may" + , "be called something other than `show w' and `show c'; they could even be" + , "mouse-clicks or menu items--whatever suits your program." + , "" + , "You should also get your employer (if you work as a programmer) or your" + , "school, if any, to sign a \"copyright disclaimer\" for the program, if" + , "necessary. Here is a sample; alter the names:" + , "" + , " Yoyodyne, Inc., hereby disclaims all copyright interest in the program" + , " `Gnomovision' (which makes passes at compilers) written by James Hacker." + , "" + , " , 1 April 1989" + , " Ty Coon, President of Vice" + , "" + , "This General Public License does not permit incorporating your program into" + , "proprietary programs. If your program is a subroutine library, you may" + , "consider it more useful to permit linking proprietary applications with the" + , "library. If this is what you want to do, use the GNU Lesser General" + , "Public License instead of this License." + ] + +gplv3 :: License +gplv3 = unlines + [ " GNU GENERAL PUBLIC LICENSE" + , " Version 3, 29 June 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 General Public License is a free, copyleft license for" + , "software and other kinds of works." + , "" + , " The licenses for most software and other practical works are designed" + , "to take away your freedom to share and change the works. By contrast," + , "the GNU General Public License is 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. We, the Free Software Foundation, use the" + , "GNU General Public License for most of our software; it applies also to" + , "any other work released this way by its authors. You can apply it to" + , "your programs, too." + , "" + , " 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." + , "" + , " To protect your rights, we need to prevent others from denying you" + , "these rights or asking you to surrender the rights. Therefore, you have" + , "certain responsibilities if you distribute copies of the software, or if" + , "you modify it: responsibilities to respect the freedom of others." + , "" + , " For example, if you distribute copies of such a program, whether" + , "gratis or for a fee, you must pass on to the recipients the same" + , "freedoms that you received. You must make sure that they, too, receive" + , "or can get the source code. And you must show them these terms so they" + , "know their rights." + , "" + , " Developers that use the GNU GPL protect your rights with two steps:" + , "(1) assert copyright on the software, and (2) offer you this License" + , "giving you legal permission to copy, distribute and/or modify it." + , "" + , " For the developers' and authors' protection, the GPL clearly explains" + , "that there is no warranty for this free software. For both users' and" + , "authors' sake, the GPL requires that modified versions be marked as" + , "changed, so that their problems will not be attributed erroneously to" + , "authors of previous versions." + , "" + , " Some devices are designed to deny users access to install or run" + , "modified versions of the software inside them, although the manufacturer" + , "can do so. This is fundamentally incompatible with the aim of" + , "protecting users' freedom to change the software. The systematic" + , "pattern of such abuse occurs in the area of products for individuals to" + , "use, which is precisely where it is most unacceptable. Therefore, we" + , "have designed this version of the GPL to prohibit the practice for those" + , "products. If such problems arise substantially in other domains, we" + , "stand ready to extend this provision to those domains in future versions" + , "of the GPL, as needed to protect the freedom of users." + , "" + , " Finally, every program is threatened constantly by software patents." + , "States should not allow patents to restrict development and use of" + , "software on general-purpose computers, but in those that do, we wish to" + , "avoid the special danger that patents applied to a free program could" + , "make it effectively proprietary. To prevent this, the GPL assures that" + , "patents cannot be used to render the program non-free." + , "" + , " 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 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. Use with the GNU Affero General Public License." + , "" + , " 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 Affero 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 special requirements of the GNU Affero General Public License," + , "section 13, concerning interaction through a network will apply to the" + , "combination as such." + , "" + , " 14. Revised Versions of this License." + , "" + , " The Free Software Foundation may publish revised and/or new versions of" + , "the GNU 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 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 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 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 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 General Public License for more details." + , "" + , " You should have received a copy of the GNU General Public License" + , " along with this program. If not, see ." + , "" + , "Also add information on how to contact you by electronic and paper mail." + , "" + , " If the program does terminal interaction, make it output a short" + , "notice like this when it starts in an interactive mode:" + , "" + , " Copyright (C) " + , " This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'." + , " This is free software, and you are welcome to redistribute it" + , " under certain conditions; type `show c' for details." + , "" + , "The hypothetical commands `show w' and `show c' should show the appropriate" + , "parts of the General Public License. Of course, your program's commands" + , "might be different; for a GUI interface, you would use an \"about box\"." + , "" + , " 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 GPL, see" + , "." + , "" + , " The GNU General Public License does not permit incorporating your program" + , "into proprietary programs. If your program is a subroutine library, you" + , "may consider it more useful to permit linking proprietary applications with" + , "the library. If this is what you want to do, use the GNU Lesser General" + , "Public License instead of this License. But first, please read" + , "." + , "" + ] + +lgpl2 :: License +lgpl2 = unlines + [ " GNU LIBRARY GENERAL PUBLIC LICENSE" + , " Version 2, June 1991" + , "" + , " Copyright (C) 1991 Free Software Foundation, Inc." + , " 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA" + , " Everyone is permitted to copy and distribute verbatim copies" + , " of this license document, but changing it is not allowed." + , "" + , "[This is the first released version of the library GPL. It is" + , " numbered 2 because it goes with version 2 of the ordinary GPL.]" + , "" + , " Preamble" + , "" + , " The licenses for most software are designed to take away your" + , "freedom to share and change it. By contrast, the GNU General Public" + , "Licenses are intended to guarantee your freedom to share and change" + , "free software--to make sure the software is free for all its users." + , "" + , " This license, the Library General Public License, applies to some" + , "specially designated Free Software Foundation software, and to any" + , "other libraries whose authors decide to use it. You can use it for" + , "your libraries, too." + , "" + , " 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" + , "this service 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." + , "" + , " To protect your rights, we need to make restrictions that forbid" + , "anyone to deny you these rights or to ask you to surrender the rights." + , "These restrictions translate to certain responsibilities for you if" + , "you distribute copies of the library, or if you modify it." + , "" + , " For example, if you distribute copies of the library, whether gratis" + , "or for a fee, you must give the recipients all the rights that we gave" + , "you. You must make sure that they, too, receive or can get the source" + , "code. If you link a program with the library, you must provide" + , "complete object files to the recipients so that they can relink them" + , "with the library, after making changes to the library and recompiling" + , "it. And you must show them these terms so they know their rights." + , "" + , " Our method of protecting your rights has two steps: (1) copyright" + , "the library, and (2) offer you this license which gives you legal" + , "permission to copy, distribute and/or modify the library." + , "" + , " Also, for each distributor's protection, we want to make certain" + , "that everyone understands that there is no warranty for this free" + , "library. If the library is modified by someone else and passed on, we" + , "want its recipients to know that what they have is not the original" + , "version, so that any problems introduced by others will not reflect on" + , "the original authors' reputations." + , "" + , " Finally, any free program is threatened constantly by software" + , "patents. We wish to avoid the danger that companies distributing free" + , "software will individually obtain patent licenses, thus in effect" + , "transforming the program into proprietary software. To prevent this," + , "we have made it clear that any patent must be licensed for everyone's" + , "free use or not licensed at all." + , "" + , " Most GNU software, including some libraries, is covered by the ordinary" + , "GNU General Public License, which was designed for utility programs. This" + , "license, the GNU Library General Public License, applies to certain" + , "designated libraries. This license is quite different from the ordinary" + , "one; be sure to read it in full, and don't assume that anything in it is" + , "the same as in the ordinary license." + , "" + , " The reason we have a separate public license for some libraries is that" + , "they blur the distinction we usually make between modifying or adding to a" + , "program and simply using it. Linking a program with a library, without" + , "changing the library, is in some sense simply using the library, and is" + , "analogous to running a utility program or application program. However, in" + , "a textual and legal sense, the linked executable is a combined work, a" + , "derivative of the original library, and the ordinary General Public License" + , "treats it as such." + , "" + , " Because of this blurred distinction, using the ordinary General" + , "Public License for libraries did not effectively promote software" + , "sharing, because most developers did not use the libraries. We" + , "concluded that weaker conditions might promote sharing better." + , "" + , " However, unrestricted linking of non-free programs would deprive the" + , "users of those programs of all benefit from the free status of the" + , "libraries themselves. This Library General Public License is intended to" + , "permit developers of non-free programs to use free libraries, while" + , "preserving your freedom as a user of such programs to change the free" + , "libraries that are incorporated in them. (We have not seen how to achieve" + , "this as regards changes in header files, but we have achieved it as regards" + , "changes in the actual functions of the Library.) The hope is that this" + , "will lead to faster development of free libraries." + , "" + , " The precise terms and conditions for copying, distribution and" + , "modification follow. Pay close attention to the difference between a" + , "\"work based on the library\" and a \"work that uses the library\". The" + , "former contains code derived from the library, while the latter only" + , "works together with the library." + , "" + , " Note that it is possible for a library to be covered by the ordinary" + , "General Public License rather than by this special one." + , "" + , " GNU LIBRARY GENERAL PUBLIC LICENSE" + , " TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION" + , "" + , " 0. This License Agreement applies to any software library which" + , "contains a notice placed by the copyright holder or other authorized" + , "party saying it may be distributed under the terms of this Library" + , "General Public License (also called \"this License\"). Each licensee is" + , "addressed as \"you\"." + , "" + , " A \"library\" means a collection of software functions and/or data" + , "prepared so as to be conveniently linked with application programs" + , "(which use some of those functions and data) to form executables." + , "" + , " The \"Library\", below, refers to any such software library or work" + , "which has been distributed under these terms. A \"work based on the" + , "Library\" means either the Library or any derivative work under" + , "copyright law: that is to say, a work containing the Library or a" + , "portion of it, either verbatim or with modifications and/or translated" + , "straightforwardly into another language. (Hereinafter, translation is" + , "included without limitation in the term \"modification\".)" + , "" + , " \"Source code\" for a work means the preferred form of the work for" + , "making modifications to it. For a library, complete source code means" + , "all the source code for all modules it contains, plus any associated" + , "interface definition files, plus the scripts used to control compilation" + , "and installation of the library." + , "" + , " Activities other than copying, distribution and modification are not" + , "covered by this License; they are outside its scope. The act of" + , "running a program using the Library is not restricted, and output from" + , "such a program is covered only if its contents constitute a work based" + , "on the Library (independent of the use of the Library in a tool for" + , "writing it). Whether that is true depends on what the Library does" + , "and what the program that uses the Library does." + , " " + , " 1. You may copy and distribute verbatim copies of the Library's" + , "complete source code as you receive it, in any medium, provided that" + , "you conspicuously and appropriately publish on each copy an" + , "appropriate copyright notice and disclaimer of warranty; keep intact" + , "all the notices that refer to this License and to the absence of any" + , "warranty; and distribute a copy of this License along with the" + , "Library." + , "" + , " You may charge a fee for the physical act of transferring a copy," + , "and you may at your option offer warranty protection in exchange for a" + , "fee." + , "" + , " 2. You may modify your copy or copies of the Library or any portion" + , "of it, thus forming a work based on the Library, and copy and" + , "distribute such modifications or work under the terms of Section 1" + , "above, provided that you also meet all of these conditions:" + , "" + , " a) The modified work must itself be a software library." + , "" + , " b) You must cause the files modified to carry prominent notices" + , " stating that you changed the files and the date of any change." + , "" + , " c) You must cause the whole of the work to be licensed at no" + , " charge to all third parties under the terms of this License." + , "" + , " d) If a facility in the modified Library refers to a function or a" + , " table of data to be supplied by an application program that uses" + , " the facility, other than as an argument passed when the facility" + , " is invoked, then you must make a good faith effort to ensure that," + , " in the event an application does not supply such function or" + , " table, the facility still operates, and performs whatever part of" + , " its purpose remains meaningful." + , "" + , " (For example, a function in a library to compute square roots has" + , " a purpose that is entirely well-defined independent of the" + , " application. Therefore, Subsection 2d requires that any" + , " application-supplied function or table used by this function must" + , " be optional: if the application does not supply it, the square" + , " root function must still compute square roots.)" + , "" + , "These requirements apply to the modified work as a whole. If" + , "identifiable sections of that work are not derived from the Library," + , "and can be reasonably considered independent and separate works in" + , "themselves, then this License, and its terms, do not apply to those" + , "sections when you distribute them as separate works. But when you" + , "distribute the same sections as part of a whole which is a work based" + , "on the Library, the distribution of the whole must be on the terms of" + , "this License, whose permissions for other licensees extend to the" + , "entire whole, and thus to each and every part regardless of who wrote" + , "it." + , "" + , "Thus, it is not the intent of this section to claim rights or contest" + , "your rights to work written entirely by you; rather, the intent is to" + , "exercise the right to control the distribution of derivative or" + , "collective works based on the Library." + , "" + , "In addition, mere aggregation of another work not based on the Library" + , "with the Library (or with a work based on the Library) on a volume of" + , "a storage or distribution medium does not bring the other work under" + , "the scope of this License." + , "" + , " 3. You may opt to apply the terms of the ordinary GNU General Public" + , "License instead of this License to a given copy of the Library. To do" + , "this, you must alter all the notices that refer to this License, so" + , "that they refer to the ordinary GNU General Public License, version 2," + , "instead of to this License. (If a newer version than version 2 of the" + , "ordinary GNU General Public License has appeared, then you can specify" + , "that version instead if you wish.) Do not make any other change in" + , "these notices." + , "" + , " Once this change is made in a given copy, it is irreversible for" + , "that copy, so the ordinary GNU General Public License applies to all" + , "subsequent copies and derivative works made from that copy." + , "" + , " This option is useful when you wish to copy part of the code of" + , "the Library into a program that is not a library." + , "" + , " 4. You may copy and distribute the Library (or a portion or" + , "derivative of it, under Section 2) in object code or executable form" + , "under the terms of Sections 1 and 2 above provided that you accompany" + , "it with the complete corresponding machine-readable source code, which" + , "must be distributed under the terms of Sections 1 and 2 above on a" + , "medium customarily used for software interchange." + , "" + , " If distribution of object code is made by offering access to copy" + , "from a designated place, then offering equivalent access to copy the" + , "source code from the same place satisfies the requirement to" + , "distribute the source code, even though third parties are not" + , "compelled to copy the source along with the object code." + , "" + , " 5. A program that contains no derivative of any portion of the" + , "Library, but is designed to work with the Library by being compiled or" + , "linked with it, is called a \"work that uses the Library\". Such a" + , "work, in isolation, is not a derivative work of the Library, and" + , "therefore falls outside the scope of this License." + , "" + , " However, linking a \"work that uses the Library\" with the Library" + , "creates an executable that is a derivative of the Library (because it" + , "contains portions of the Library), rather than a \"work that uses the" + , "library\". The executable is therefore covered by this License." + , "Section 6 states terms for distribution of such executables." + , "" + , " When a \"work that uses the Library\" uses material from a header file" + , "that is part of the Library, the object code for the work may be a" + , "derivative work of the Library even though the source code is not." + , "Whether this is true is especially significant if the work can be" + , "linked without the Library, or if the work is itself a library. The" + , "threshold for this to be true is not precisely defined by law." + , "" + , " If such an object file uses only numerical parameters, data" + , "structure layouts and accessors, and small macros and small inline" + , "functions (ten lines or less in length), then the use of the object" + , "file is unrestricted, regardless of whether it is legally a derivative" + , "work. (Executables containing this object code plus portions of the" + , "Library will still fall under Section 6.)" + , "" + , " Otherwise, if the work is a derivative of the Library, you may" + , "distribute the object code for the work under the terms of Section 6." + , "Any executables containing that work also fall under Section 6," + , "whether or not they are linked directly with the Library itself." + , "" + , " 6. As an exception to the Sections above, you may also compile or" + , "link a \"work that uses the Library\" with the Library to produce a" + , "work containing portions of the Library, and distribute that work" + , "under terms of your choice, provided that the terms permit" + , "modification of the work for the customer's own use and reverse" + , "engineering for debugging such modifications." + , "" + , " You must give prominent notice with each copy of the work that the" + , "Library is used in it and that the Library and its use are covered by" + , "this License. You must supply a copy of this License. If the work" + , "during execution displays copyright notices, you must include the" + , "copyright notice for the Library among them, as well as a reference" + , "directing the user to the copy of this License. Also, you must do one" + , "of these things:" + , "" + , " a) Accompany the work with the complete corresponding" + , " machine-readable source code for the Library including whatever" + , " changes were used in the work (which must be distributed under" + , " Sections 1 and 2 above); and, if the work is an executable linked" + , " with the Library, with the complete machine-readable \"work that" + , " uses the Library\", as object code and/or source code, so that the" + , " user can modify the Library and then relink to produce a modified" + , " executable containing the modified Library. (It is understood" + , " that the user who changes the contents of definitions files in the" + , " Library will not necessarily be able to recompile the application" + , " to use the modified definitions.)" + , "" + , " b) Accompany the work with a written offer, valid for at" + , " least three years, to give the same user the materials" + , " specified in Subsection 6a, above, for a charge no more" + , " than the cost of performing this distribution." + , "" + , " c) If distribution of the work is made by offering access to copy" + , " from a designated place, offer equivalent access to copy the above" + , " specified materials from the same place." + , "" + , " d) Verify that the user has already received a copy of these" + , " materials or that you have already sent this user a copy." + , "" + , " For an executable, the required form of the \"work that uses the" + , "Library\" must include any data and utility programs needed for" + , "reproducing the executable from it. However, as a special exception," + , "the source code distributed need not include anything that is normally" + , "distributed (in either source or binary form) with the major" + , "components (compiler, kernel, and so on) of the operating system on" + , "which the executable runs, unless that component itself accompanies" + , "the executable." + , "" + , " It may happen that this requirement contradicts the license" + , "restrictions of other proprietary libraries that do not normally" + , "accompany the operating system. Such a contradiction means you cannot" + , "use both them and the Library together in an executable that you" + , "distribute." + , "" + , " 7. You may place library facilities that are a work based on the" + , "Library side-by-side in a single library together with other library" + , "facilities not covered by this License, and distribute such a combined" + , "library, provided that the separate distribution of the work based on" + , "the Library and of the other library facilities is otherwise" + , "permitted, and provided that you do these two things:" + , "" + , " a) Accompany the combined library with a copy of the same work" + , " based on the Library, uncombined with any other library" + , " facilities. This must be distributed under the terms of the" + , " Sections above." + , "" + , " b) Give prominent notice with the combined library of the fact" + , " that part of it is a work based on the Library, and explaining" + , " where to find the accompanying uncombined form of the same work." + , "" + , " 8. You may not copy, modify, sublicense, link with, or distribute" + , "the Library except as expressly provided under this License. Any" + , "attempt otherwise to copy, modify, sublicense, link with, or" + , "distribute the Library is void, and will automatically terminate your" + , "rights under this License. However, parties who have received copies," + , "or rights, from you under this License will not have their licenses" + , "terminated so long as such parties remain in full compliance." + , "" + , " 9. You are not required to accept this License, since you have not" + , "signed it. However, nothing else grants you permission to modify or" + , "distribute the Library or its derivative works. These actions are" + , "prohibited by law if you do not accept this License. Therefore, by" + , "modifying or distributing the Library (or any work based on the" + , "Library), you indicate your acceptance of this License to do so, and" + , "all its terms and conditions for copying, distributing or modifying" + , "the Library or works based on it." + , "" + , " 10. Each time you redistribute the Library (or any work based on the" + , "Library), the recipient automatically receives a license from the" + , "original licensor to copy, distribute, link with or modify the Library" + , "subject to these terms and conditions. You may not impose any further" + , "restrictions on the recipients' exercise of the rights granted herein." + , "You are not responsible for enforcing compliance by third parties to" + , "this License." + , "" + , " 11. If, as a consequence of a court judgment or allegation of patent" + , "infringement or for any other reason (not limited to patent issues)," + , "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" + , "distribute so as to satisfy simultaneously your obligations under this" + , "License and any other pertinent obligations, then as a consequence you" + , "may not distribute the Library at all. For example, if a patent" + , "license would not permit royalty-free redistribution of the Library by" + , "all those who receive copies directly or indirectly through you, then" + , "the only way you could satisfy both it and this License would be to" + , "refrain entirely from distribution of the Library." + , "" + , "If any portion of this section is held invalid or unenforceable under any" + , "particular circumstance, the balance of the section is intended to apply," + , "and the section as a whole is intended to apply in other circumstances." + , "" + , "It is not the purpose of this section to induce you to infringe any" + , "patents or other property right claims or to contest validity of any" + , "such claims; this section has the sole purpose of protecting the" + , "integrity of the free software distribution system which is" + , "implemented by public license practices. Many people have made" + , "generous contributions to the wide range of software distributed" + , "through that system in reliance on consistent application of that" + , "system; it is up to the author/donor to decide if he or she is willing" + , "to distribute software through any other system and a licensee cannot" + , "impose that choice." + , "" + , "This section is intended to make thoroughly clear what is believed to" + , "be a consequence of the rest of this License." + , "" + , " 12. If the distribution and/or use of the Library is restricted in" + , "certain countries either by patents or by copyrighted interfaces, the" + , "original copyright holder who places the Library under this License may add" + , "an explicit geographical distribution limitation excluding those countries," + , "so that distribution is permitted only in or among countries not thus" + , "excluded. In such case, this License incorporates the limitation as if" + , "written in the body of this License." + , "" + , " 13. The Free Software Foundation may publish revised and/or new" + , "versions of the Library 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 Library" + , "specifies a version number of this License which applies to it and" + , "\"any later version\", you have the option of following the terms and" + , "conditions either of that version or of any later version published by" + , "the Free Software Foundation. If the Library does not specify a" + , "license version number, you may choose any version ever published by" + , "the Free Software Foundation." + , "" + , " 14. If you wish to incorporate parts of the Library into other free" + , "programs whose distribution conditions are incompatible with these," + , "write to the author to ask for permission. For software which is" + , "copyrighted by the Free Software Foundation, write to the Free" + , "Software Foundation; we sometimes make exceptions for this. Our" + , "decision will be guided by the two goals of preserving the free status" + , "of all derivatives of our free software and of promoting the sharing" + , "and reuse of software generally." + , "" + , " NO WARRANTY" + , "" + , " 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO" + , "WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW." + , "EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR" + , "OTHER PARTIES PROVIDE THE LIBRARY \"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" + , "LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME" + , "THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION." + , "" + , " 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN" + , "WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY" + , "AND/OR REDISTRIBUTE THE LIBRARY 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" + , "LIBRARY (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 LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF" + , "SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH" + , "DAMAGES." + , "" + , " END OF TERMS AND CONDITIONS" + , "" + , " How to Apply These Terms to Your New Libraries" + , "" + , " If you develop a new library, and you want it to be of the greatest" + , "possible use to the public, we recommend making it free software that" + , "everyone can redistribute and change. You can do so by permitting" + , "redistribution under these terms (or, alternatively, under the terms of the" + , "ordinary General Public License)." + , "" + , " To apply these terms, attach the following notices to the library. It is" + , "safest to attach them to the start of each source file to most effectively" + , "convey 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 library is free software; you can redistribute it and/or" + , " modify it under the terms of the GNU Library General Public" + , " License as published by the Free Software Foundation; either" + , " version 2 of the License, or (at your option) any later version." + , "" + , " This library 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" + , " Library General Public License for more details." + , "" + , " You should have received a copy of the GNU Library General Public" + , " License along with this library; if not, write to the Free" + , " Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA" + , "" + , "Also add information on how to contact you by electronic and paper mail." + , "" + , "You should also get your employer (if you work as a programmer) or your" + , "school, if any, to sign a \"copyright disclaimer\" for the library, if" + , "necessary. Here is a sample; alter the names:" + , "" + , " Yoyodyne, Inc., hereby disclaims all copyright interest in the" + , " library `Frob' (a library for tweaking knobs) written by James Random Hacker." + , "" + , " , 1 April 1990" + , " Ty Coon, President of Vice" + , "" + , "That's all there is to it!" + ] + +lgpl3 :: License +lgpl3 = unlines + [ " GNU LESSER GENERAL PUBLIC LICENSE" + , " Version 3, 29 June 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." + , "" + , "" + , " This version of the GNU Lesser General Public License incorporates" + , "the terms and conditions of version 3 of the GNU General Public" + , "License, supplemented by the additional permissions listed below." + , "" + , " 0. Additional Definitions. " + , "" + , " As used herein, \"this License\" refers to version 3 of the GNU Lesser" + , "General Public License, and the \"GNU GPL\" refers to version 3 of the GNU" + , "General Public License." + , "" + , " \"The Library\" refers to a covered work governed by this License," + , "other than an Application or a Combined Work as defined below." + , "" + , " An \"Application\" is any work that makes use of an interface provided" + , "by the Library, but which is not otherwise based on the Library." + , "Defining a subclass of a class defined by the Library is deemed a mode" + , "of using an interface provided by the Library." + , "" + , " A \"Combined Work\" is a work produced by combining or linking an" + , "Application with the Library. The particular version of the Library" + , "with which the Combined Work was made is also called the \"Linked" + , "Version\"." + , "" + , " The \"Minimal Corresponding Source\" for a Combined Work means the" + , "Corresponding Source for the Combined Work, excluding any source code" + , "for portions of the Combined Work that, considered in isolation, are" + , "based on the Application, and not on the Linked Version." + , "" + , " The \"Corresponding Application Code\" for a Combined Work means the" + , "object code and/or source code for the Application, including any data" + , "and utility programs needed for reproducing the Combined Work from the" + , "Application, but excluding the System Libraries of the Combined Work." + , "" + , " 1. Exception to Section 3 of the GNU GPL." + , "" + , " You may convey a covered work under sections 3 and 4 of this License" + , "without being bound by section 3 of the GNU GPL." + , "" + , " 2. Conveying Modified Versions." + , "" + , " If you modify a copy of the Library, and, in your modifications, a" + , "facility refers to a function or data to be supplied by an Application" + , "that uses the facility (other than as an argument passed when the" + , "facility is invoked), then you may convey a copy of the modified" + , "version:" + , "" + , " a) under this License, provided that you make a good faith effort to" + , " ensure that, in the event an Application does not supply the" + , " function or data, the facility still operates, and performs" + , " whatever part of its purpose remains meaningful, or" + , "" + , " b) under the GNU GPL, with none of the additional permissions of" + , " this License applicable to that copy." + , "" + , " 3. Object Code Incorporating Material from Library Header Files." + , "" + , " The object code form of an Application may incorporate material from" + , "a header file that is part of the Library. You may convey such object" + , "code under terms of your choice, provided that, if the incorporated" + , "material is not limited to numerical parameters, data structure" + , "layouts and accessors, or small macros, inline functions and templates" + , "(ten or fewer lines in length), you do both of the following:" + , "" + , " a) Give prominent notice with each copy of the object code that the" + , " Library is used in it and that the Library and its use are" + , " covered by this License." + , "" + , " b) Accompany the object code with a copy of the GNU GPL and this license" + , " document." + , "" + , " 4. Combined Works." + , "" + , " You may convey a Combined Work under terms of your choice that," + , "taken together, effectively do not restrict modification of the" + , "portions of the Library contained in the Combined Work and reverse" + , "engineering for debugging such modifications, if you also do each of" + , "the following:" + , "" + , " a) Give prominent notice with each copy of the Combined Work that" + , " the Library is used in it and that the Library and its use are" + , " covered by this License." + , "" + , " b) Accompany the Combined Work with a copy of the GNU GPL and this license" + , " document." + , "" + , " c) For a Combined Work that displays copyright notices during" + , " execution, include the copyright notice for the Library among" + , " these notices, as well as a reference directing the user to the" + , " copies of the GNU GPL and this license document." + , "" + , " d) Do one of the following:" + , "" + , " 0) Convey the Minimal Corresponding Source under the terms of this" + , " License, and the Corresponding Application Code in a form" + , " suitable for, and under terms that permit, the user to" + , " recombine or relink the Application with a modified version of" + , " the Linked Version to produce a modified Combined Work, in the" + , " manner specified by section 6 of the GNU GPL for conveying" + , " Corresponding Source." + , "" + , " 1) Use a suitable shared library mechanism for linking with the" + , " Library. A suitable mechanism is one that (a) uses at run time" + , " a copy of the Library already present on the user's computer" + , " system, and (b) will operate properly with a modified version" + , " of the Library that is interface-compatible with the Linked" + , " Version. " + , "" + , " e) Provide Installation Information, but only if you would otherwise" + , " be required to provide such information under section 6 of the" + , " GNU GPL, and only to the extent that such information is" + , " necessary to install and execute a modified version of the" + , " Combined Work produced by recombining or relinking the" + , " Application with a modified version of the Linked Version. (If" + , " you use option 4d0, the Installation Information must accompany" + , " the Minimal Corresponding Source and Corresponding Application" + , " Code. If you use option 4d1, you must provide the Installation" + , " Information in the manner specified by section 6 of the GNU GPL" + , " for conveying Corresponding Source.)" + , "" + , " 5. Combined Libraries." + , "" + , " You may place library facilities that are a work based on the" + , "Library side by side in a single library together with other library" + , "facilities that are not Applications and are not covered by this" + , "License, and convey such a combined library under terms of your" + , "choice, if you do both of the following:" + , "" + , " a) Accompany the combined library with a copy of the same work based" + , " on the Library, uncombined with any other library facilities," + , " conveyed under the terms of this License." + , "" + , " b) Give prominent notice with the combined library that part of it" + , " is a work based on the Library, and explaining where to find the" + , " accompanying uncombined form of the same work." + , "" + , " 6. Revised Versions of the GNU Lesser General Public License." + , "" + , " The Free Software Foundation may publish revised and/or new versions" + , "of the GNU Lesser 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" + , "Library as you received it specifies that a certain numbered version" + , "of the GNU Lesser General Public License \"or any later version\"" + , "applies to it, you have the option of following the terms and" + , "conditions either of that published version or of any later version" + , "published by the Free Software Foundation. If the Library as you" + , "received it does not specify a version number of the GNU Lesser" + , "General Public License, you may choose any version of the GNU Lesser" + , "General Public License ever published by the Free Software Foundation." + , "" + , " If the Library as you received it specifies that a proxy can decide" + , "whether future versions of the GNU Lesser General Public License shall" + , "apply, that proxy's public statement of acceptance of any version is" + , "permanent authorization for you to choose that version for the" + , "Library." + ] + diff --git a/Distribution/Client/Init/Types.hs b/Distribution/Client/Init/Types.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Init/Types.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Init.Types +-- Copyright : (c) Brent Yorgey, Benedikt Huber 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Some types used by the 'cabal init' command. +-- +----------------------------------------------------------------------------- +module Distribution.Client.Init.Types where + +import Distribution.Simple.Setup + ( Flag(..) ) + +import Distribution.Version +import qualified Distribution.Package as P +import Distribution.License +import Distribution.ModuleName + +import qualified Text.PrettyPrint as Disp +import qualified Distribution.Compat.ReadP as Parse +import Distribution.Text + +import Data.Monoid + +-- | InitFlags is really just a simple type to represent certain +-- portions of a .cabal file. Rather than have a flag for EVERY +-- possible field, we just have one for each field that the user is +-- likely to want and/or that we are likely to be able to +-- intelligently guess. +data InitFlags = + InitFlags { nonInteractive :: Flag Bool + , quiet :: Flag Bool + , packageDir :: Flag FilePath + , noComments :: Flag Bool + , minimal :: Flag Bool + + , packageName :: Flag String + , version :: Flag Version + , cabalVersion :: Flag VersionRange + , license :: Flag License + , author :: Flag String + , email :: Flag String + , homepage :: Flag String + + , synopsis :: Flag String + , category :: Flag (Either String Category) + + , packageType :: Flag PackageType + + , exposedModules :: Maybe [ModuleName] + , otherModules :: Maybe [ModuleName] + + , dependencies :: Maybe [P.Dependency] + , sourceDirs :: Maybe [String] + , buildTools :: Maybe [String] + } + deriving (Show) + +data PackageType = Library | Executable + deriving (Show, Read, Eq) + +instance Text PackageType where + disp = Disp.text . show + parse = Parse.choice $ map (fmap read . Parse.string . show) [Library, Executable] + +instance Monoid InitFlags where + mempty = InitFlags + { nonInteractive = mempty + , quiet = mempty + , packageDir = mempty + , noComments = mempty + , minimal = mempty + , packageName = mempty + , version = mempty + , cabalVersion = mempty + , license = mempty + , author = mempty + , email = mempty + , homepage = mempty + , synopsis = mempty + , category = mempty + , packageType = mempty + , exposedModules = mempty + , otherModules = mempty + , dependencies = mempty + , sourceDirs = mempty + , buildTools = mempty + } + mappend a b = InitFlags + { nonInteractive = combine nonInteractive + , quiet = combine quiet + , packageDir = combine packageDir + , noComments = combine noComments + , minimal = combine minimal + , packageName = combine packageName + , version = combine version + , cabalVersion = combine cabalVersion + , license = combine license + , author = combine author + , email = combine email + , homepage = combine homepage + , synopsis = combine synopsis + , category = combine category + , packageType = combine packageType + , exposedModules = combine exposedModules + , otherModules = combine otherModules + , dependencies = combine dependencies + , sourceDirs = combine sourceDirs + , buildTools = combine buildTools + } + where combine field = field a `mappend` field b + +-- | Some common package categories. +data Category + = Codec + | Concurrency + | Control + | Data + | Database + | Development + | Distribution + | Game + | Graphics + | Language + | Math + | Network + | Sound + | System + | Testing + | Text + | Web + deriving (Read, Show, Eq, Ord, Bounded, Enum) + +instance Text Category where + 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 new file mode 100644 --- /dev/null +++ b/Distribution/Client/Install.hs @@ -0,0 +1,875 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Install +-- Copyright : (c) 2005 David Himmelstrup +-- 2007 Bjorn Bringert +-- 2007-2010 Duncan Coutts +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- High level interface to package installation. +----------------------------------------------------------------------------- +module Distribution.Client.Install ( + install, + upgrade, + ) where + +import Data.List + ( unfoldr, find, nub, sort ) +import Data.Maybe + ( isJust, fromMaybe ) +import Control.Exception as Exception + ( handleJust ) +#if MIN_VERSION_base(4,0,0) +import Control.Exception as Exception + ( Exception(toException), catches, Handler(Handler), IOException ) +import System.Exit + ( ExitCode ) +#else +import Control.Exception as Exception + ( Exception(IOException, ExitException) ) +#endif +import Distribution.Compat.Exception + ( SomeException, catchIO, catchExit ) +import Control.Monad + ( when, unless ) +import System.Directory + ( getTemporaryDirectory, doesFileExist, createDirectoryIfMissing ) +import System.FilePath + ( (), (<.>), takeDirectory ) +import System.IO + ( openFile, IOMode(AppendMode) ) +import System.IO.Error + ( isDoesNotExistError, ioeGetFileName ) + +import Distribution.Client.Targets +import Distribution.Client.Dependency +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 + ( getAvailablePackages, getInstalledPackages ) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.InstallPlan (InstallPlan) +import Distribution.Client.Setup + ( GlobalFlags(..) + , ConfigFlags(..), configureCommand, filterConfigureFlags + , ConfigExFlags(..), InstallFlags(..) ) +import Distribution.Client.Config + ( defaultCabalDir ) +import Distribution.Client.Tar (extractTarGzFile) +import Distribution.Client.Types as Available +import Distribution.Client.BuildReports.Types + ( ReportLevel(..) ) +import Distribution.Client.SetupWrapper + ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) +import qualified Distribution.Client.BuildReports.Anonymous as BuildReports +import qualified Distribution.Client.BuildReports.Storage as BuildReports + ( storeAnonymous, storeLocal, fromInstallPlan ) +import qualified Distribution.Client.InstallSymlink as InstallSymlink + ( symlinkBinaries ) +import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade +import qualified Distribution.Client.World as World +import Paths_cabal_install_bundle (getBinDir) + +import Distribution.Simple.Compiler + ( CompilerId(..), Compiler(compilerId), compilerFlavor + , PackageDB(..), PackageDBStack ) +import Distribution.Simple.Program (ProgramConfiguration, defaultProgramConfiguration) +import qualified Distribution.Simple.InstallDirs as InstallDirs +import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Client.PackageIndex (PackageIndex) +import Distribution.Simple.Setup + ( haddockCommand, HaddockFlags(..), emptyHaddockFlags + , buildCommand, BuildFlags(..), emptyBuildFlags + , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe ) +import qualified Distribution.Simple.Setup as Cabal + ( installCommand, InstallFlags(..), emptyInstallFlags ) +import Distribution.Simple.Utils + ( rawSystemExit, comparing ) +import Distribution.Simple.InstallDirs as InstallDirs + ( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate + , initialPathTemplateEnv, installDirsTemplateEnv ) +import Distribution.Package + ( PackageIdentifier, packageName, packageVersion + , Package(..), PackageFixedDeps(..) + , Dependency(..), thisPackageVersion ) +import qualified Distribution.PackageDescription as PackageDescription +import Distribution.PackageDescription + ( PackageDescription ) +import Distribution.PackageDescription.Configuration + ( finalizePackageDescription ) +import Distribution.Version + ( Version, anyVersion, thisVersion ) +import Distribution.Simple.Utils as Utils + ( notice, info, debug, warn, die, intercalate, withTempDirectory ) +import Distribution.Client.Utils + ( inDir, mergeBy, MergeResult(..) ) +import Distribution.System + ( Platform, buildPlatform, OS(Windows), buildOS ) +import Distribution.Text + ( display ) +import Distribution.Verbosity as Verbosity + ( Verbosity, showForCabal, verbose ) +import Distribution.Simple.BuildPaths ( exeExtension ) + +--TODO: +-- * assign flags to packages individually +-- * complain about flags that do not apply to any package given as target +-- so flags do not apply to dependencies, only listed, can use flag +-- constraints for dependencies +-- * only record applicable flags in world file +-- * allow flag constraints +-- * allow installed constraints +-- * allow flag and installed preferences +-- * change world file to use cabal section syntax +-- * allow persistent configure flags for each package individually + +-- ------------------------------------------------------------ +-- * Top level user actions +-- ------------------------------------------------------------ + +-- | Installs the packages needed to satisfy a list of dependencies. +-- +install, upgrade + :: Verbosity + -> PackageDBStack + -> [Repo] + -> Compiler + -> ProgramConfiguration + -> GlobalFlags + -> ConfigFlags + -> ConfigExFlags + -> InstallFlags + -> [UserTarget] + -> IO () +install verbosity packageDBs repos comp conf + globalFlags configFlags configExFlags installFlags userTargets0 = do + + installed <- getInstalledPackages verbosity comp packageDBs conf + availableDb <- getAvailablePackages verbosity repos + + 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 + globalFlags (packageIndex availableDb) userTargets + + notice verbosity "Resolving dependencies..." + installPlan <- foldProgress logMsg die return $ + planPackages + comp configFlags configExFlags installFlags + installed availableDb pkgSpecifiers + + printPlanMessages verbosity installed installPlan dryRun + + unless dryRun $ do + installPlan' <- performInstallations verbosity + context installed installPlan + postInstallActions verbosity context userTargets installPlan' + + where + context :: InstallContext + context = (packageDBs, repos, comp, conf, + globalFlags, configFlags, configExFlags, installFlags) + + dryRun = fromFlag (installDryRun installFlags) + logMsg message rest = debug verbosity message >> rest + + +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 ) + +-- ------------------------------------------------------------ +-- * Installation planning +-- ------------------------------------------------------------ + +planPackages :: Compiler + -> ConfigFlags + -> ConfigExFlags + -> InstallFlags + -> PackageIndex InstalledPackage + -> AvailablePackageDb + -> [PackageSpecifier AvailablePackage] + -> Progress String String InstallPlan +planPackages comp configFlags configExFlags installFlags + installed availableDb pkgSpecifiers = + + resolveDependencies + buildPlatform (compilerId comp) + resolverParams + + >>= if onlyDeps then adjustPlanOnlyDeps else return + + where + resolverParams = + + setPreferenceDefault (if upgradeDeps then PreferAllLatest + else PreferLatestForSelected) + + . addPreferences + -- preferences from the config file or command line + [ PackageVersionPreference name ver + | Dependency name ver <- configPreferences configExFlags ] + + . addConstraints + -- version constraints from the config file or command line + [ PackageVersionConstraint name ver + | Dependency name ver <- configConstraints configFlags ] + + . addConstraints + --FIXME: this just applies all flags to all targets which + -- is silly. We should check if the flags are appropriate + [ PackageFlagsConstraint (pkgSpecifierTarget pkgSpecifier) flags + | let flags = configConfigurationsFlags configFlags + , not (null flags) + , pkgSpecifier <- pkgSpecifiers ] + + . (if reinstall then reinstallTargets else id) + + $ standardInstallPolicy installed availableDb 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. + adjustPlanOnlyDeps :: InstallPlan -> Progress String String InstallPlan + adjustPlanOnlyDeps = + either (Fail . explain) Done + . InstallPlan.remove isTarget + where + isTarget pkg = packageName pkg `elem` targetnames + targetnames = map pkgSpecifierTarget pkgSpecifiers + + 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 ] + + reinstall = fromFlag (installReinstall installFlags) + upgradeDeps = fromFlag (installUpgradeDeps installFlags) + onlyDeps = fromFlag (installOnlyDeps installFlags) + +-- ------------------------------------------------------------ +-- * Informational messages +-- ------------------------------------------------------------ + +printPlanMessages :: Verbosity + -> PackageIndex InstalledPackage + -> InstallPlan + -> Bool + -> IO () +printPlanMessages verbosity installed installPlan dryRun = do + + when nothingToInstall $ + notice verbosity $ + "No packages to be installed. All the requested packages are " + ++ "already installed.\n If you want to reinstall anyway then use " + ++ "the --reinstall flag." + + when (dryRun || verbosity >= verbose) $ + printDryRun verbosity installed installPlan + + where + nothingToInstall = null (InstallPlan.ready installPlan) + + +printDryRun :: Verbosity + -> PackageIndex InstalledPackage + -> InstallPlan + -> IO () +printDryRun verbosity installed plan = case unfoldr next plan of + [] -> return () + pkgs + | verbosity >= Verbosity.verbose -> notice verbosity $ unlines $ + "In order, the following would be installed:" + : map showPkgAndReason pkgs + | otherwise -> notice verbosity $ unlines $ + "In order, the following would be installed (use -v for more details):" + : map (display . packageId) pkgs + where + next plan' = case InstallPlan.ready plan' of + [] -> Nothing + (pkg:_) -> Just (pkg, InstallPlan.completed pkgid result plan') + where pkgid = packageId pkg + result = BuildOk DocsNotTried TestsNotTried + --FIXME: This is a bit of a hack, + -- pretending that each package is installed + + showPkgAndReason pkg' = display (packageId pkg') ++ " " ++ + case PackageIndex.lookupPackageName installed (packageName pkg') of + [] -> "(new package)" + ps -> case find ((==packageId pkg') . packageId) ps of + Nothing -> "(new version)" + Just pkg -> "(reinstall)" ++ case changes pkg pkg' of + [] -> "" + diff -> " changes: " ++ intercalate ", " diff + changes pkg pkg' = map change . filter changed + $ mergeBy (comparing packageName) + (nub . sort . depends $ pkg) + (nub . sort . depends $ pkg') + change (OnlyInLeft pkgid) = display pkgid ++ " removed" + change (InBoth pkgid pkgid') = display pkgid ++ " -> " + ++ display (packageVersion pkgid') + change (OnlyInRight pkgid') = display pkgid' ++ " added" + changed (InBoth pkgid pkgid') = pkgid /= pkgid' + changed _ = True + +-- ------------------------------------------------------------ +-- * Post installation stuff +-- ------------------------------------------------------------ + +-- | Various stuff we do after successful or unsuccessfully installing a bunch +-- of packages. This includes: +-- +-- * build reporting, local and remote +-- * symlinking binaries +-- * updating indexes +-- * updating world file +-- * error reporting +-- +postInstallActions :: Verbosity + -> InstallContext + -> [UserTarget] + -> InstallPlan + -> IO () +postInstallActions verbosity + (packageDBs, _, comp, conf, globalFlags, configFlags, _, installFlags) + targets installPlan = do + + unless oneShot $ + World.insert verbosity worldFile + --FIXME: does not handle flags + [ World.WorldPkgInfo dep [] + | UserTargetNamed dep <- targets ] + + let buildReports = BuildReports.fromInstallPlan installPlan + BuildReports.storeLocal (installSummaryFile installFlags) buildReports + when (reportingLevel >= AnonymousReports) $ + BuildReports.storeAnonymous buildReports + when (reportingLevel == DetailedReports) $ + storeDetailedBuildReports verbosity logsDir buildReports + + regenerateHaddockIndex verbosity packageDBs comp conf + configFlags installFlags installPlan + + symlinkBinaries verbosity configFlags installFlags installPlan + + printBuildFailures installPlan + + where + reportingLevel = fromFlag (installBuildReports installFlags) + logsDir = fromFlag (globalLogsDir globalFlags) + oneShot = fromFlag (installOneShot installFlags) + worldFile = fromFlag $ globalWorldFile globalFlags + +storeDetailedBuildReports :: Verbosity -> FilePath + -> [(BuildReports.BuildReport, Repo)] -> IO () +storeDetailedBuildReports verbosity logsDir reports = sequence_ + [ do dotCabal <- defaultCabalDir + let logFileName = display (BuildReports.package report) <.> "log" + logFile = logsDir logFileName + reportsDir = dotCabal "reports" remoteRepoName remoteRepo + reportFile = reportsDir logFileName + + handleMissingLogFile $ do + buildLog <- readFile logFile + createDirectoryIfMissing True reportsDir -- FIXME + writeFile reportFile (show (BuildReports.show report, buildLog)) + + | (report, Repo { repoKind = Left remoteRepo }) <- reports + , isLikelyToHaveLogFile (BuildReports.installOutcome report) ] + + where + isLikelyToHaveLogFile BuildReports.ConfigureFailed {} = True + isLikelyToHaveLogFile BuildReports.BuildFailed {} = True + isLikelyToHaveLogFile BuildReports.InstallFailed {} = True + isLikelyToHaveLogFile BuildReports.InstallOk {} = True + isLikelyToHaveLogFile _ = False + + handleMissingLogFile = Exception.handleJust missingFile $ \ioe -> + 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 + + +regenerateHaddockIndex :: Verbosity + -> [PackageDB] + -> Compiler + -> ProgramConfiguration + -> ConfigFlags + -> InstallFlags + -> InstallPlan + -> IO () +regenerateHaddockIndex verbosity packageDBs comp conf + configFlags installFlags installPlan + | haddockIndexFileIsRequested && shouldRegenerateHaddockIndex = do + + defaultDirs <- InstallDirs.defaultInstallDirs + (compilerFlavor comp) + (fromFlag (configUserInstall configFlags)) + True + let indexFileTemplate = fromFlag (installHaddockIndex installFlags) + indexFile = substHaddockIndexFileName defaultDirs indexFileTemplate + + notice verbosity $ + "Updating documentation index " ++ indexFile + + --TODO: might be nice if the install plan gave us the new InstalledPackageInfo + installed <- getInstalledPackages verbosity comp packageDBs conf + Haddock.regenerateHaddockIndex verbosity installed conf indexFile + + | otherwise = return () + where + haddockIndexFileIsRequested = + fromFlag (installDocumentation installFlags) + && isJust (flagToMaybe (installHaddockIndex installFlags)) + + -- We want to regenerate the index if some new documentation was actually + -- installed. Since the index is per-user, we don't do it for global + -- installs or special cases where we're installing into a specific db. + shouldRegenerateHaddockIndex = normalUserInstall + && someDocsWereInstalled installPlan + where + someDocsWereInstalled = any installedDocs . InstallPlan.toList + normalUserInstall = (UserPackageDB `elem` packageDBs) + && all (not . isSpecificPackageDB) packageDBs + + installedDocs (InstallPlan.Installed _ (BuildOk DocsOk _)) = True + installedDocs _ = False + isSpecificPackageDB (SpecificPackageDB _) = True + isSpecificPackageDB _ = False + + substHaddockIndexFileName defaultDirs = fromPathTemplate + . substPathTemplate env + where + env = env0 ++ installDirsTemplateEnv absoluteDirs + env0 = InstallDirs.compilerTemplateEnv (compilerId comp) + ++ InstallDirs.platformTemplateEnv (buildPlatform) + absoluteDirs = InstallDirs.substituteInstallDirTemplates + env0 templateDirs + templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault + defaultDirs (configInstallDirs configFlags) + + +symlinkBinaries :: Verbosity + -> ConfigFlags + -> InstallFlags + -> InstallPlan -> IO () +symlinkBinaries verbosity configFlags installFlags plan = do + failed <- InstallSymlink.symlinkBinaries configFlags installFlags plan + case failed of + [] -> return () + [(_, exe, path)] -> + warn verbosity $ + "could not create a symlink in " ++ bindir ++ " for " + ++ exe ++ " because the file exists there already but is not " + ++ "managed by cabal. You can create a symlink for this executable " + ++ "manually if you wish. The executable file has been installed at " + ++ path + exes -> + warn verbosity $ + "could not create symlinks in " ++ bindir ++ " for " + ++ intercalate ", " [ exe | (_, exe, _) <- exes ] + ++ " because the files exist there already and are not " + ++ "managed by cabal. You can create symlinks for these executables " + ++ "manually if you wish. The executable files have been installed at " + ++ intercalate ", " [ path | (_, _, path) <- exes ] + where + bindir = fromFlag (installSymlinkBinDir installFlags) + + +printBuildFailures :: InstallPlan -> IO () +printBuildFailures plan = + case [ (pkg, reason) + | InstallPlan.Failed pkg reason <- InstallPlan.toList plan ] of + [] -> return () + failed -> die . unlines + $ "Error: some packages failed to install:" + : [ display (packageId pkg) ++ printFailureReason reason + | (pkg, reason) <- failed ] + where + printFailureReason reason = case reason of + DependentFailed pkgid -> " depends on " ++ display pkgid + ++ " which failed to install." + DownloadFailed e -> " failed while downloading the package." + ++ " The exception was:\n " ++ show e + UnpackFailed e -> " failed while unpacking the package." + ++ " The exception was:\n " ++ show e + ConfigureFailed e -> " failed during the configure step." + ++ " The exception was:\n " ++ show e + BuildFailed e -> " failed during the building phase." + ++ " The exception was:\n " ++ show e + InstallFailed e -> " failed during the final install step." + ++ " The exception was:\n " ++ show e + + +-- ------------------------------------------------------------ +-- * Actually do the installations +-- ------------------------------------------------------------ + +data InstallMisc = InstallMisc { + rootCmd :: Maybe FilePath, + libVersion :: Maybe Version + } + +performInstallations :: Verbosity + -> InstallContext + -> PackageIndex InstalledPackage + -> InstallPlan + -> IO InstallPlan +performInstallations verbosity + (packageDBs, _, comp, conf, + globalFlags, configFlags, configExFlags, installFlags) + installed installPlan = do + + executeInstallPlan installPlan $ \cpkg -> + installConfiguredPackage platform compid configFlags + cpkg $ \configFlags' src pkg -> + fetchAvailablePackage verbosity src $ \src' -> + installLocalPackage verbosity (packageId pkg) src' $ \mpath -> + installUnpackedPackage verbosity (setupScriptOptions installed) + miscOptions configFlags' installFlags + compid pkg mpath useLogFile + + where + platform = InstallPlan.planPlatform installPlan + compid = InstallPlan.planCompiler installPlan + + setupScriptOptions index = SetupScriptOptions { + useCabalVersion = maybe anyVersion thisVersion (libVersion miscOptions), + useCompiler = Just comp, + -- 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. + usePackageDB = if UserPackageDB `elem` packageDBs + then packageDBs + else let (db@GlobalPackageDB:dbs) = packageDBs + in db : UserPackageDB : dbs, + --TODO: use Ord instance: + -- insert UserPackageDB packageDBs + usePackageIndex = if UserPackageDB `elem` packageDBs + then Just index + else Nothing, + useProgramConfig = conf, + useDistPref = fromFlagOrDefault + (useDistPref defaultSetupScriptOptions) + (configDistPref configFlags), + useLoggingHandle = Nothing, + useWorkingDir = Nothing + } + reportingLevel = fromFlag (installBuildReports installFlags) + logsDir = fromFlag (globalLogsDir globalFlags) + useLogFile :: Maybe (PackageIdentifier -> FilePath) + useLogFile = fmap substLogFileName logFileTemplate + where + logFileTemplate :: Maybe PathTemplate + logFileTemplate --TODO: separate policy from mechanism + | reportingLevel == DetailedReports + = Just $ toPathTemplate $ logsDir "$pkgid" <.> "log" + | otherwise + = flagToMaybe (installLogFile installFlags) + substLogFileName template pkg = fromPathTemplate + . substPathTemplate env + $ template + where env = initialPathTemplateEnv (packageId pkg) (compilerId comp) + miscOptions = InstallMisc { + rootCmd = if fromFlag (configUserInstall configFlags) + then Nothing -- ignore --root-cmd if --user. + else flagToMaybe (installRootCmd installFlags), + libVersion = flagToMaybe (configCabalVersion configExFlags) + } + + +executeInstallPlan :: Monad m + => InstallPlan + -> (ConfiguredPackage -> m BuildResult) + -> m InstallPlan +executeInstallPlan plan installPkg = case InstallPlan.ready plan of + [] -> return plan + (pkg: _) -> do buildResult <- installPkg pkg + let plan' = updatePlan (packageId pkg) buildResult plan + executeInstallPlan plan' installPkg + where + updatePlan pkgid (Right buildSuccess) = + InstallPlan.completed pkgid buildSuccess + + updatePlan pkgid (Left buildFailure) = + InstallPlan.failed pkgid buildFailure depsFailure + where + depsFailure = DependentFailed pkgid + -- So this first pkgid failed for whatever reason (buildFailure). + -- All the other packages that depended on this pkgid, which we + -- now cannot build, we mark as failing due to 'DependentFailed' + -- which kind of means it was not their fault. + + +-- | Call an installer for an 'AvailablePackage' but override the configure +-- flags with the ones given by the 'ConfiguredPackage'. In particular the +-- 'ConfiguredPackage' specifies an exact 'FlagAssignment' and exactly +-- versioned package dependencies. So we ignore any previous partial flag +-- assignment or dependency constraints and use the new ones. +-- +installConfiguredPackage :: Platform -> CompilerId + -> ConfigFlags -> ConfiguredPackage + -> (ConfigFlags -> PackageLocation (Maybe FilePath) + -> PackageDescription -> a) + -> a +installConfiguredPackage platform comp configFlags + (ConfiguredPackage (AvailablePackage _ gpkg source) flags deps) + installPkg = installPkg configFlags { + configConfigurationsFlags = flags, + configConstraints = map thisPackageVersion deps + } source pkg + where + pkg = case finalizePackageDescription flags + (const True) + platform comp [] gpkg of + Left _ -> error "finalizePackageDescription ConfiguredPackage failed" + Right (desc, _) -> desc + +fetchAvailablePackage + :: Verbosity + -> PackageLocation (Maybe FilePath) + -> (PackageLocation FilePath -> IO BuildResult) + -> IO BuildResult +fetchAvailablePackage verbosity src installPkg = do + fetched <- checkFetched src + case fetched of + Just src' -> installPkg src' + Nothing -> onFailure DownloadFailed $ + fetchPackage verbosity src >>= installPkg + + +installLocalPackage + :: Verbosity -> PackageIdentifier -> PackageLocation FilePath + -> (Maybe FilePath -> IO BuildResult) + -> IO BuildResult +installLocalPackage verbosity pkgid location installPkg = case location of + + LocalUnpackedPackage dir -> + installPkg (Just dir) + + LocalTarballPackage tarballPath -> + installLocalTarballPackage verbosity pkgid tarballPath installPkg + + RemoteTarballPackage _ tarballPath -> + installLocalTarballPackage verbosity pkgid tarballPath installPkg + + RepoTarballPackage _ _ tarballPath -> + installLocalTarballPackage verbosity pkgid tarballPath installPkg + + +installLocalTarballPackage + :: Verbosity -> PackageIdentifier -> FilePath + -> (Maybe FilePath -> IO BuildResult) + -> IO BuildResult +installLocalTarballPackage verbosity pkgid tarballPath installPkg = do + tmp <- getTemporaryDirectory + withTempDirectory verbosity tmp (display pkgid) $ \tmpDirPath -> + onFailure UnpackFailed $ do + info verbosity $ "Extracting " ++ tarballPath + ++ " to " ++ tmpDirPath ++ "..." + let relUnpackedPath = display pkgid + absUnpackedPath = tmpDirPath relUnpackedPath + descFilePath = absUnpackedPath + display (packageName pkgid) <.> "cabal" + extractTarGzFile tmpDirPath relUnpackedPath tarballPath + exists <- doesFileExist descFilePath + when (not exists) $ + die $ "Package .cabal file not found: " ++ show descFilePath + installPkg (Just absUnpackedPath) + + +installUnpackedPackage :: Verbosity + -> SetupScriptOptions + -> InstallMisc + -> ConfigFlags + -> InstallFlags + -> CompilerId + -> PackageDescription + -> Maybe FilePath -- ^ Directory to change to before starting the installation. + -> Maybe (PackageIdentifier -> FilePath) -- ^ File to log output to (if any) + -> IO BuildResult +installUnpackedPackage verbosity scriptOptions miscOptions + configFlags installConfigFlags + compid pkg workingDir useLogFile = + + -- Configure phase + onFailure ConfigureFailed $ do + setup configureCommand configureFlags + + -- Build phase + onFailure BuildFailed $ do + setup buildCommand' buildFlags + + -- Doc generation phase + docsResult <- if shouldHaddock + then (do setup haddockCommand haddockFlags + return DocsOk) + `catchIO` (\_ -> return DocsFailed) + `catchExit` (\_ -> return DocsFailed) + else return DocsNotTried + + -- Tests phase + testsResult <- return TestsNotTried --TODO: add optional tests + + -- Install phase + onFailure InstallFailed $ + withWin32SelfUpgrade verbosity configFlags compid pkg $ do + case rootCmd miscOptions of + (Just cmd) -> reexec cmd + Nothing -> setup Cabal.installCommand installFlags + return (Right (BuildOk docsResult testsResult)) + + where + configureFlags = filterConfigureFlags configFlags { + configVerbosity = toFlag verbosity' + } + buildCommand' = buildCommand defaultProgramConfiguration + buildFlags _ = emptyBuildFlags { + buildDistPref = configDistPref configFlags, + buildVerbosity = toFlag verbosity' + } + shouldHaddock = fromFlag (installDocumentation installConfigFlags) + haddockFlags _ = emptyHaddockFlags { + haddockDistPref = configDistPref configFlags, + haddockVerbosity = toFlag verbosity' + } + installFlags _ = Cabal.emptyInstallFlags { + Cabal.installDistPref = configDistPref configFlags, + Cabal.installVerbosity = toFlag verbosity' + } + verbosity' | isJust useLogFile = max Verbosity.verbose verbosity + | otherwise = verbosity + setup cmd flags = do + logFileHandle <- case useLogFile of + Nothing -> return Nothing + Just mkLogFileName -> do + let logFileName = mkLogFileName (packageId pkg) + logDir = takeDirectory logFileName + unless (null logDir) $ createDirectoryIfMissing True logDir + logFile <- openFile logFileName AppendMode + return (Just logFile) + + setupWrapper verbosity + scriptOptions { useLoggingHandle = logFileHandle + , useWorkingDir = workingDir } + (Just pkg) + cmd flags [] + reexec cmd = do + -- look for our on executable file and re-exec ourselves using + -- a helper program like sudo to elevate priviledges: + bindir <- getBinDir + let self = bindir "cabal" <.> exeExtension + weExist <- doesFileExist self + if weExist + then inDir workingDir $ + rawSystemExit verbosity cmd + [self, "install", "--only" + ,"--verbose=" ++ showForCabal verbosity] + else die $ "Unable to find cabal executable at: " ++ self + + +-- 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) + ] + 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 + + +-- ------------------------------------------------------------ +-- * Wierd windows hacks +-- ------------------------------------------------------------ + +withWin32SelfUpgrade :: Verbosity + -> ConfigFlags + -> CompilerId + -> PackageDescription + -> IO a -> IO a +withWin32SelfUpgrade _ _ _ _ action | buildOS /= Windows = action +withWin32SelfUpgrade verbosity configFlags compid pkg action = do + + defaultDirs <- InstallDirs.defaultInstallDirs + compFlavor + (fromFlag (configUserInstall configFlags)) + (PackageDescription.hasLibs pkg) + + Win32SelfUpgrade.possibleSelfUpgrade verbosity + (exeInstallPaths defaultDirs) action + + where + pkgid = packageId pkg + (CompilerId compFlavor _) = compid + + exeInstallPaths defaultDirs = + [ InstallDirs.bindir absoluteDirs exeName <.> exeExtension + | exe <- PackageDescription.executables pkg + , PackageDescription.buildable (PackageDescription.buildInfo exe) + , let exeName = prefix ++ PackageDescription.exeName exe ++ suffix + prefix = substTemplate prefixTemplate + suffix = substTemplate suffixTemplate ] + where + fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "") + prefixTemplate = fromFlagTemplate (configProgPrefix configFlags) + suffixTemplate = fromFlagTemplate (configProgSuffix configFlags) + templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault + defaultDirs (configInstallDirs configFlags) + absoluteDirs = InstallDirs.absoluteInstallDirs + pkgid compid InstallDirs.NoCopyDest templateDirs + substTemplate = InstallDirs.fromPathTemplate + . InstallDirs.substPathTemplate env + where env = InstallDirs.initialPathTemplateEnv pkgid compid diff --git a/Distribution/Client/InstallPlan.hs b/Distribution/Client/InstallPlan.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/InstallPlan.hs @@ -0,0 +1,511 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.InstallPlan +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : duncan@community.haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Package installation plan +-- +----------------------------------------------------------------------------- +module Distribution.Client.InstallPlan ( + InstallPlan, + ConfiguredPackage(..), + PlanPackage(..), + + -- * Operations on 'InstallPlan's + new, + toList, + ready, + completed, + failed, + remove, + + -- ** Query functions + planPlatform, + planCompiler, + + -- * Checking valididy of plans + valid, + closed, + consistent, + acyclic, + configuredPackageValid, + + -- ** Details on invalid plans + PlanProblem(..), + showPlanProblem, + PackageProblem(..), + showPackageProblem, + problems, + configuredPackageProblems + ) where + +import Distribution.Client.Types + ( AvailablePackage(packageDescription), ConfiguredPackage(..) + , InstalledPackage + , BuildFailure, BuildSuccess ) +import Distribution.Package + ( PackageIdentifier(..), PackageName(..), Package(..), packageName + , PackageFixedDeps(..), Dependency(..) ) +import Distribution.Version + ( Version, withinRange ) +import Distribution.PackageDescription + ( GenericPackageDescription(genPackageFlags) + , Flag(flagName), FlagName(..) ) +import Distribution.Client.PackageUtils + ( externalBuildDepends ) +import Distribution.PackageDescription.Configuration + ( finalizePackageDescription ) +import Distribution.Client.PackageIndex + ( PackageIndex ) +import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Text + ( display ) +import Distribution.System + ( Platform ) +import Distribution.Compiler + ( CompilerId(..) ) +import Distribution.Client.Utils + ( duplicates, duplicatesBy, mergeBy, MergeResult(..) ) +import Distribution.Simple.Utils + ( comparing, intercalate ) + +import Data.List + ( sort, sortBy ) +import Data.Maybe + ( fromMaybe ) +import qualified Data.Graph as Graph +import Data.Graph (Graph) +import Control.Exception + ( assert ) + +-- When cabal tries to install a number of packages, including all their +-- dependencies it has a non-trivial problem to solve. +-- +-- The Problem: +-- +-- In general we start with a set of installed packages and a set of available +-- packages. +-- +-- Installed packages have fixed dependencies. They have already been built and +-- we know exactly what packages they were built against, including their exact +-- versions. +-- +-- Available package have somewhat flexible dependencies. They are specified as +-- version ranges, though really they're predicates. To make matters worse they +-- have conditional flexible dependencies. Configuration flags can affect which +-- packages are required and can place additional constraints on their +-- versions. +-- +-- These two sets of package can and usually do overlap. There can be installed +-- packages that are also available which means they could be re-installed if +-- required, though there will also be packages which are not available and +-- cannot be re-installed. Very often there will be extra versions available +-- than are installed. Sometimes we may like to prefer installed packages over +-- available ones or perhaps always prefer the latest available version whether +-- installed or not. +-- +-- The goal is to calculate an installation plan that is closed, acyclic and +-- consistent and where every configured package is valid. +-- +-- An installation plan is a set of packages that are going to be used +-- together. It will consist of a mixture of installed packages and available +-- packages along with their exact version dependencies. An installation plan +-- is closed if for every package in the set, all of its dependencies are +-- also in the set. It is consistent if for every package in the set, all +-- dependencies which target that package have the same version. + +-- Note that plans do not necessarily compose. You might have a valid plan for +-- package A and a valid plan for package B. That does not mean the composition +-- is simultaniously valid for A and B. In particular you're most likely to +-- have problems with inconsistent dependencies. +-- On the other hand it is true that every closed sub plan is valid. + +data PlanPackage = PreExisting InstalledPackage + | Configured ConfiguredPackage + | Installed ConfiguredPackage BuildSuccess + | Failed ConfiguredPackage BuildFailure + +instance Package PlanPackage where + packageId (PreExisting pkg) = packageId pkg + packageId (Configured pkg) = packageId pkg + packageId (Installed pkg _) = packageId pkg + packageId (Failed pkg _) = packageId pkg + +instance PackageFixedDeps PlanPackage where + depends (PreExisting pkg) = depends pkg + depends (Configured pkg) = depends pkg + depends (Installed pkg _) = depends pkg + depends (Failed pkg _) = depends pkg + +data InstallPlan = InstallPlan { + planIndex :: PackageIndex PlanPackage, + planGraph :: Graph, + planGraphRev :: Graph, + planPkgOf :: Graph.Vertex -> PlanPackage, + planVertexOf :: PackageIdentifier -> Graph.Vertex, + planPlatform :: Platform, + planCompiler :: CompilerId + } + +invariant :: InstallPlan -> Bool +invariant plan = + valid (planPlatform plan) (planCompiler plan) (planIndex plan) + +internalError :: String -> a +internalError msg = error $ "InstallPlan: internal error: " ++ msg + +-- | Build an installation plan from a valid set of resolved packages. +-- +new :: Platform -> CompilerId -> PackageIndex PlanPackage + -> Either [PlanProblem] InstallPlan +new platform compiler index = + case problems platform compiler index of + [] -> Right InstallPlan { + planIndex = index, + planGraph = graph, + planGraphRev = Graph.transposeG graph, + planPkgOf = vertexToPkgId, + planVertexOf = fromMaybe noSuchPkgId . pkgIdToVertex, + planPlatform = platform, + planCompiler = compiler + } + where (graph, vertexToPkgId, pkgIdToVertex) = + PackageIndex.dependencyGraph index + noSuchPkgId = internalError "package is not in the graph" + probs -> Left probs + +toList :: InstallPlan -> [PlanPackage] +toList = PackageIndex.allPackages . planIndex + +-- | Remove packages from the install plan. This will result in an +-- error if there are remaining packages that depend on any matching +-- package. This is primarily useful for obtaining an install plan for +-- the dependencies of a package or set of packages without actually +-- installing the package itself, as when doing development. +-- +remove :: (PlanPackage -> Bool) + -> InstallPlan + -> Either [PlanProblem] InstallPlan +remove shouldRemove plan = + new (planPlatform plan) (planCompiler plan) newIndex + where + newIndex = PackageIndex.fromList $ + filter (not . shouldRemove) (toList plan) + +-- | The packages that are ready to be installed. That is they are in the +-- configured state and have all their dependencies installed already. +-- The plan is complete if the result is @[]@. +-- +ready :: InstallPlan -> [ConfiguredPackage] +ready plan = assert check readyPackages + where + check = if null readyPackages then null configuredPackages else True + configuredPackages = + [ pkg | Configured pkg <- PackageIndex.allPackages (planIndex plan) ] + readyPackages = filter (all isInstalled . depends) configuredPackages + isInstalled pkg = + case PackageIndex.lookupPackageId (planIndex plan) pkg of + Just (Configured _) -> False + Just (Failed _ _) -> internalError depOnFailed + Just (PreExisting _) -> True + Just (Installed _ _) -> True + Nothing -> internalError incomplete + incomplete = "install plan is not closed" + depOnFailed = "configured package depends on failed package" + +-- | Marks a package in the graph as completed. Also saves the build result for +-- the completed package in the plan. +-- +-- * The package must exist in the graph. +-- * The package must have had no uninstalled dependent packages. +-- +completed :: PackageIdentifier + -> BuildSuccess + -> InstallPlan -> InstallPlan +completed pkgid buildResult plan = assert (invariant plan') plan' + where + plan' = plan { + planIndex = PackageIndex.insert installed (planIndex plan) + } + installed = Installed (lookupConfiguredPackage plan pkgid) buildResult + +-- | Marks a package in the graph as having failed. It also marks all the +-- packages that depended on it as having failed. +-- +-- * The package must exist in the graph and be in the configured state. +-- +failed :: PackageIdentifier -- ^ The id of the package that failed to install + -> BuildFailure -- ^ The build result to use for the failed package + -> BuildFailure -- ^ The build result to use for its dependencies + -> InstallPlan + -> InstallPlan +failed pkgid buildResult buildResult' plan = assert (invariant plan') plan' + where + plan' = plan { + planIndex = PackageIndex.merge (planIndex plan) failures + } + pkg = lookupConfiguredPackage plan pkgid + failures = PackageIndex.fromList + $ Failed pkg buildResult + : [ Failed pkg' buildResult' + | Just pkg' <- map checkConfiguredPackage + $ packagesThatDependOn plan pkgid ] + +-- | lookup the reachable packages in the reverse dependency graph +-- +packagesThatDependOn :: InstallPlan + -> PackageIdentifier -> [PlanPackage] +packagesThatDependOn plan = map (planPkgOf plan) + . tail + . Graph.reachable (planGraphRev plan) + . planVertexOf plan + +-- | lookup a package that we expect to be in the configured state +-- +lookupConfiguredPackage :: InstallPlan + -> PackageIdentifier -> ConfiguredPackage +lookupConfiguredPackage plan pkgid = + case PackageIndex.lookupPackageId (planIndex plan) pkgid of + Just (Configured pkg) -> pkg + _ -> internalError $ "not configured or no such pkg " ++ display pkgid + +-- | check a package that we expect to be in the configured or failed state +-- +checkConfiguredPackage :: PlanPackage -> Maybe ConfiguredPackage +checkConfiguredPackage (Configured pkg) = Just pkg +checkConfiguredPackage (Failed _ _) = Nothing +checkConfiguredPackage pkg = + internalError $ "not configured or no such pkg " ++ display (packageId pkg) + +-- ------------------------------------------------------------ +-- * Checking valididy of plans +-- ------------------------------------------------------------ + +-- | A valid installation plan is a set of packages that is 'acyclic', +-- 'closed' and 'consistent'. Also, every 'ConfiguredPackage' in the +-- plan has to have a valid configuration (see 'configuredPackageValid'). +-- +-- * if the result is @False@ use 'problems' to get a detailed list. +-- +valid :: Platform -> CompilerId -> PackageIndex PlanPackage -> Bool +valid platform comp index = null (problems platform comp index) + +data PlanProblem = + PackageInvalid ConfiguredPackage [PackageProblem] + | PackageMissingDeps PlanPackage [PackageIdentifier] + | PackageCycle [PlanPackage] + | PackageInconsistency PackageName [(PackageIdentifier, Version)] + | PackageStateInvalid PlanPackage PlanPackage + +showPlanProblem :: PlanProblem -> String +showPlanProblem (PackageInvalid pkg packageProblems) = + "Package " ++ display (packageId pkg) + ++ " has an invalid configuration, in particular:\n" + ++ unlines [ " " ++ showPackageProblem problem + | problem <- packageProblems ] + +showPlanProblem (PackageMissingDeps pkg missingDeps) = + "Package " ++ display (packageId pkg) + ++ " depends on the following packages which are missing from the plan " + ++ intercalate ", " (map display missingDeps) + +showPlanProblem (PackageCycle cycleGroup) = + "The following packages are involved in a dependency cycle " + ++ intercalate ", " (map (display.packageId) cycleGroup) + +showPlanProblem (PackageInconsistency name inconsistencies) = + "Package " ++ display name + ++ " is required by several packages," + ++ " but they require inconsistent versions:\n" + ++ unlines [ " package " ++ display pkg ++ " requires " + ++ display (PackageIdentifier name ver) + | (pkg, ver) <- inconsistencies ] + +showPlanProblem (PackageStateInvalid pkg pkg') = + "Package " ++ display (packageId pkg) + ++ " is in the " ++ showPlanState pkg + ++ " state but it depends on package " ++ display (packageId pkg') + ++ " which is in the " ++ showPlanState pkg' + ++ " state" + where + showPlanState (PreExisting _) = "pre-existing" + showPlanState (Configured _) = "configured" + showPlanState (Installed _ _) = "installed" + showPlanState (Failed _ _) = "failed" + +-- | For an invalid plan, produce a detailed list of problems as human readable +-- error messages. This is mainly intended for debugging purposes. +-- Use 'showPlanProblem' for a human readable explanation. +-- +problems :: Platform -> CompilerId + -> PackageIndex PlanPackage -> [PlanProblem] +problems platform comp index = + [ PackageInvalid pkg packageProblems + | Configured pkg <- PackageIndex.allPackages index + , let packageProblems = configuredPackageProblems platform comp pkg + , not (null packageProblems) ] + + ++ [ PackageMissingDeps pkg missingDeps + | (pkg, missingDeps) <- PackageIndex.brokenPackages index ] + + ++ [ PackageCycle cycleGroup + | cycleGroup <- PackageIndex.dependencyCycles index ] + + ++ [ PackageInconsistency name inconsistencies + | (name, inconsistencies) <- PackageIndex.dependencyInconsistencies index ] + + ++ [ PackageStateInvalid pkg pkg' + | pkg <- PackageIndex.allPackages index + , Just pkg' <- map (PackageIndex.lookupPackageId index) (depends pkg) + , not (stateDependencyRelation pkg pkg') ] + +-- | The graph of packages (nodes) and dependencies (edges) must be acyclic. +-- +-- * if the result is @False@ use 'PackageIndex.dependencyCycles' to find out +-- which packages are involved in dependency cycles. +-- +acyclic :: PackageIndex PlanPackage -> Bool +acyclic = null . PackageIndex.dependencyCycles + +-- | An installation plan is closed if for every package in the set, all of +-- its dependencies are also in the set. That is, the set is closed under the +-- dependency relation. +-- +-- * if the result is @False@ use 'PackageIndex.brokenPackages' to find out +-- which packages depend on packages not in the index. +-- +closed :: PackageIndex PlanPackage -> Bool +closed = null . PackageIndex.brokenPackages + +-- | An installation plan is consistent if all dependencies that target a +-- single package name, target the same version. +-- +-- This is slightly subtle. It is not the same as requiring that there be at +-- 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 +-- 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 +-- current definition is just a safe aproximation of that. +-- +-- * if the result is @False@ use 'PackageIndex.dependencyInconsistencies' to +-- find out which packages are. +-- +consistent :: PackageIndex PlanPackage -> Bool +consistent = null . PackageIndex.dependencyInconsistencies + +-- | The states of packages have that depend on each other must respect +-- this relation. That is for very case where package @a@ depends on +-- package @b@ we require that @dependencyStatesOk a b = True@. +-- +stateDependencyRelation :: PlanPackage -> PlanPackage -> Bool +stateDependencyRelation (PreExisting _) (PreExisting _) = True + +stateDependencyRelation (Configured _) (PreExisting _) = True +stateDependencyRelation (Configured _) (Configured _) = True +stateDependencyRelation (Configured _) (Installed _ _) = True + +stateDependencyRelation (Installed _ _) (PreExisting _) = True +stateDependencyRelation (Installed _ _) (Installed _ _) = True + +stateDependencyRelation (Failed _ _) (PreExisting _) = True +-- failed can depends on configured because a package can depend on +-- several other packages and if one of the deps fail then we fail +-- but we still depend on the other ones that did not fail: +stateDependencyRelation (Failed _ _) (Configured _) = True +stateDependencyRelation (Failed _ _) (Installed _ _) = True +stateDependencyRelation (Failed _ _) (Failed _ _) = True + +stateDependencyRelation _ _ = False + +-- | A 'ConfiguredPackage' is valid if the flag assignment is total and if +-- in the configuration given by the flag assignment, all the package +-- dependencies are satisfied by the specified packages. +-- +configuredPackageValid :: Platform -> CompilerId -> ConfiguredPackage -> Bool +configuredPackageValid platform comp pkg = + null (configuredPackageProblems platform comp pkg) + +data PackageProblem = DuplicateFlag FlagName + | MissingFlag FlagName + | ExtraFlag FlagName + | DuplicateDeps [PackageIdentifier] + | MissingDep Dependency + | ExtraDep PackageIdentifier + | InvalidDep Dependency PackageIdentifier + +showPackageProblem :: PackageProblem -> String +showPackageProblem (DuplicateFlag (FlagName flag)) = + "duplicate flag in the flag assignment: " ++ flag + +showPackageProblem (MissingFlag (FlagName flag)) = + "missing an assignment for the flag: " ++ flag + +showPackageProblem (ExtraFlag (FlagName flag)) = + "extra flag given that is not used by the package: " ++ flag + +showPackageProblem (DuplicateDeps pkgids) = + "duplicate packages specified as selected dependencies: " + ++ intercalate ", " (map display pkgids) + +showPackageProblem (MissingDep dep) = + "the package has a dependency " ++ display dep + ++ " but no package has been selected to satisfy it." + +showPackageProblem (ExtraDep pkgid) = + "the package configuration specifies " ++ display pkgid + ++ " but (with the given flag assignment) the package does not actually" + ++ " depend on any version of that package." + +showPackageProblem (InvalidDep dep pkgid) = + "the package depends on " ++ display dep + ++ " but the configuration specifies " ++ display pkgid + ++ " which does not satisfy the dependency." + +configuredPackageProblems :: Platform -> CompilerId + -> ConfiguredPackage -> [PackageProblem] +configuredPackageProblems platform comp + (ConfiguredPackage pkg specifiedFlags specifiedDeps) = + [ DuplicateFlag flag | ((flag,_):_) <- duplicates specifiedFlags ] + ++ [ MissingFlag flag | OnlyInLeft flag <- mergedFlags ] + ++ [ ExtraFlag flag | OnlyInRight flag <- mergedFlags ] + ++ [ DuplicateDeps pkgs + | pkgs <- duplicatesBy (comparing packageName) specifiedDeps ] + ++ [ MissingDep dep | OnlyInLeft dep <- mergedDeps ] + ++ [ ExtraDep pkgid | OnlyInRight pkgid <- mergedDeps ] + ++ [ InvalidDep dep pkgid | InBoth dep pkgid <- mergedDeps + , not (packageSatisfiesDependency pkgid dep) ] + where + mergedFlags = mergeBy compare + (sort $ map flagName (genPackageFlags (packageDescription pkg))) + (sort $ map fst specifiedFlags) + + mergedDeps = mergeBy + (\dep pkgid -> dependencyName dep `compare` packageName pkgid) + (sortBy (comparing dependencyName) requiredDeps) + (sortBy (comparing packageName) specifiedDeps) + + packageSatisfiesDependency + (PackageIdentifier name version) + (Dependency name' versionRange) = assert (name == name') $ + version `withinRange` versionRange + + dependencyName (Dependency name _) = name + + requiredDeps :: [Dependency] + requiredDeps = + --TODO: use something lower level than finalizePackageDescription + case finalizePackageDescription specifiedFlags + (const True) + platform comp + [] + (packageDescription pkg) of + Right (resolvedPkg, _) -> externalBuildDepends resolvedPkg + Left _ -> error "configuredPackageInvalidDeps internal error" diff --git a/Distribution/Client/InstallSymlink.hs b/Distribution/Client/InstallSymlink.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/InstallSymlink.hs @@ -0,0 +1,238 @@ +{-# 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 +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Managing installing binaries with symlinks. +----------------------------------------------------------------------------- +module Distribution.Client.InstallSymlink ( + symlinkBinaries, + symlinkBinary, + ) where + +#if mingw32_HOST_OS || mingw32_TARGET_OS + +import Distribution.Package (PackageIdentifier) +import Distribution.Client.InstallPlan (InstallPlan) +import Distribution.Client.Setup (InstallFlags) +import Distribution.Simple.Setup (ConfigFlags) + +symlinkBinaries :: ConfigFlags + -> InstallFlags + -> InstallPlan + -> IO [(PackageIdentifier, String, FilePath)] +symlinkBinaries _ _ _ = return [] + +symlinkBinary :: FilePath -> FilePath -> String -> String -> IO Bool +symlinkBinary _ _ _ _ = fail "Symlinking feature not available on Windows" + +#else + +import Distribution.Client.Types + ( AvailablePackage(..), ConfiguredPackage(..) ) +import Distribution.Client.Setup + ( InstallFlags(installSymlinkBinDir) ) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.InstallPlan (InstallPlan) + +import Distribution.Package + ( PackageIdentifier, Package(packageId) ) +import Distribution.Compiler + ( CompilerId(..) ) +import qualified Distribution.PackageDescription as PackageDescription +import Distribution.PackageDescription + ( PackageDescription ) +import Distribution.PackageDescription.Configuration + ( finalizePackageDescription ) +import Distribution.Simple.Setup + ( ConfigFlags(..), fromFlag, fromFlagOrDefault, flagToMaybe ) +import qualified Distribution.Simple.InstallDirs as InstallDirs + +import System.Posix.Files + ( getSymbolicLinkStatus, isSymbolicLink, createSymbolicLink + , removeLink ) +import System.Directory + ( canonicalizePath ) +import System.FilePath + ( (), splitPath, joinPath, isAbsolute ) + +import Prelude hiding (catch, ioError) +import System.IO.Error + ( catch, isDoesNotExistError, ioError ) +import Control.Exception + ( assert ) +import Data.Maybe + ( catMaybes ) + +-- | We would like by default to install binaries into some location that is on +-- the user's PATH. For per-user installations on Unix systems that basically +-- means the @~/bin/@ directory. On the majority of platforms the @~/bin/@ +-- directory will be on the user's PATH. However some people are a bit nervous +-- about letting a package manager install programs into @~/bin/@. +-- +-- A comprimise solution is that instead of installing binaries directly into +-- @~/bin/@, we could install them in a private location under @~/.cabal/bin@ +-- and then create symlinks in @~/bin/@. We can be careful when setting up the +-- symlinks that we do not overwrite any binary that the user installed. We can +-- check if it was a symlink we made because it would point to the private dir +-- where we install our binaries. This means we can install normally without +-- worrying and in a later phase set up symlinks, and if that fails then we +-- report it to the user, but even in this case the package is still in an ok +-- installed state. +-- +-- This is an optional feature that users can choose to use or not. It is +-- controlled from the config file. Of course it only works on posix systems +-- with symlinks so is not available to Windows users. +-- +symlinkBinaries :: ConfigFlags + -> InstallFlags + -> InstallPlan + -> IO [(PackageIdentifier, String, FilePath)] +symlinkBinaries configFlags installFlags plan = + case flagToMaybe (installSymlinkBinDir installFlags) of + Nothing -> return [] + Just symlinkBinDir + | null exes -> return [] + | otherwise -> do + publicBinDir <- canonicalizePath symlinkBinDir +-- TODO: do we want to do this here? : +-- createDirectoryIfMissing True publicBinDir + fmap catMaybes $ sequence + [ do privateBinDir <- pkgBinDir pkg + ok <- symlinkBinary + publicBinDir privateBinDir + publicExeName privateExeName + if ok + then return Nothing + else return (Just (pkgid, publicExeName, + privateBinDir privateExeName)) + | (pkg, exe) <- exes + , let publicExeName = PackageDescription.exeName exe + privateExeName = prefix ++ publicExeName ++ suffix + pkgid = packageId pkg + prefix = substTemplate pkgid prefixTemplate + suffix = substTemplate pkgid suffixTemplate ] + where + exes = + [ (pkg, exe) + | InstallPlan.Installed cpkg _ <- InstallPlan.toList plan + , let pkg = pkgDescription cpkg + , exe <- PackageDescription.executables pkg + , PackageDescription.buildable (PackageDescription.buildInfo exe) ] + + pkgDescription :: ConfiguredPackage -> PackageDescription + pkgDescription (ConfiguredPackage (AvailablePackage _ pkg _) flags _) = + case finalizePackageDescription flags + (const True) + platform compilerId [] pkg of + Left _ -> error "finalizePackageDescription ConfiguredPackage failed" + Right (desc, _) -> desc + + -- This is sadly rather complicated. We're kind of re-doing part of the + -- configuration for the package. :-( + pkgBinDir :: PackageDescription -> IO FilePath + pkgBinDir pkg = do + defaultDirs <- InstallDirs.defaultInstallDirs + compilerFlavor + (fromFlag (configUserInstall configFlags)) + (PackageDescription.hasLibs pkg) + let templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault + defaultDirs (configInstallDirs configFlags) + absoluteDirs = InstallDirs.absoluteInstallDirs + (packageId pkg) compilerId InstallDirs.NoCopyDest + templateDirs + canonicalizePath (InstallDirs.bindir absoluteDirs) + + substTemplate pkgid = InstallDirs.fromPathTemplate + . InstallDirs.substPathTemplate env + where env = InstallDirs.initialPathTemplateEnv pkgid compilerId + + fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "") + prefixTemplate = fromFlagTemplate (configProgPrefix configFlags) + suffixTemplate = fromFlagTemplate (configProgSuffix configFlags) + platform = InstallPlan.planPlatform plan + compilerId@(CompilerId compilerFlavor _) = InstallPlan.planCompiler plan + +symlinkBinary :: FilePath -- ^ The canonical path of the public bin dir + -- eg @/home/user/bin@ + -> FilePath -- ^ The canonical path of the private bin dir + -- eg @/home/user/.cabal/bin@ + -> String -- ^ The name of the executable to go in the public + -- bin dir, eg @foo@ + -> String -- ^ The name of the executable to in the private bin + -- dir, eg @foo-1.0@ + -> IO Bool -- ^ If creating the symlink was sucessful. @False@ + -- if there was another file there already that we + -- did not own. Other errors like permission errors + -- just propagate as exceptions. +symlinkBinary publicBindir privateBindir publicName privateName = do + ok <- targetOkToOverwrite (publicBindir publicName) + (privateBindir privateName) + case ok of + NotOurFile -> return False + NotExists -> mkLink >> return True + OkToOverwrite -> rmLink >> mkLink >> return True + where + relativeBindir = makeRelative publicBindir privateBindir + mkLink = createSymbolicLink (relativeBindir privateName) + (publicBindir publicName) + rmLink = removeLink (publicBindir publicName) + +-- | Check a filepath of a symlink that we would like to create to see if it +-- is ok. For it to be ok to overwrite it must either not already exist yet or +-- be a symlink to our target (in which case we can assume ownership). +-- +targetOkToOverwrite :: FilePath -- ^ The filepath of the symlink to the private + -- binary that we would like to create + -> FilePath -- ^ The canonical path of the private binary. + -- Use 'canonicalizePath' to make this. + -> IO SymlinkStatus +targetOkToOverwrite symlink target = handleNotExist $ do + status <- getSymbolicLinkStatus symlink + if not (isSymbolicLink status) + then return NotOurFile + else do target' <- canonicalizePath symlink + -- This relies on canonicalizePath handling symlinks + if target == target' + then return OkToOverwrite + else return NotOurFile + + where + handleNotExist action = catch action $ \ioexception -> + -- If the target doesn't exist then there's no problem overwriting it! + if isDoesNotExistError ioexception + then return NotExists + else ioError ioexception + +data SymlinkStatus + = NotExists -- ^ The file doesn't exist so we can make a symlink. + | OkToOverwrite -- ^ A symlink already exists, though it is ours. We'll + -- have to delete it first bemore we make a new symlink. + | NotOurFile -- ^ A file already exists and it is not one of our existing + -- symlinks (either because it is not a symlink or because + -- it points somewhere other than our managed space). + deriving Show + +-- | Take two canonical paths and produce a relative path to get from the first +-- to the second, even if it means adding @..@ path components. +-- +makeRelative :: FilePath -> FilePath -> FilePath +makeRelative a b = assert (isAbsolute a && isAbsolute b) $ + let as = splitPath a + bs = splitPath b + commonLen = length $ takeWhile id $ zipWith (==) as bs + in joinPath $ [ ".." | _ <- drop commonLen as ] + ++ [ b' | b' <- drop commonLen bs ] + +#endif diff --git a/Distribution/Client/List.hs b/Distribution/Client/List.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/List.hs @@ -0,0 +1,528 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.List +-- Copyright : (c) David Himmelstrup 2005 +-- Duncan Coutts 2008-2011 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- +-- Search for and print information about packages +----------------------------------------------------------------------------- +module Distribution.Client.List ( + list, info + ) where + +import Distribution.Package + ( PackageName(..), Package(..), packageName, packageVersion + , Dependency(..), thisPackageVersion, depends, simplifyDependency ) +import Distribution.ModuleName (ModuleName) +import Distribution.License (License) +import qualified Distribution.InstalledPackageInfo as Installed +import qualified Distribution.PackageDescription as Available +import Distribution.PackageDescription + ( Flag(..), FlagName(..) ) +import Distribution.PackageDescription.Configuration + ( flattenPackageDescription ) + +import Distribution.Simple.Compiler + ( Compiler, PackageDBStack ) +import Distribution.Simple.Program (ProgramConfiguration) +import Distribution.Simple.Utils + ( equating, comparing, die, notice ) +import Distribution.Simple.Setup (fromFlag) +import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Version + ( Version(..), VersionRange, withinRange, anyVersion + , intersectVersionRanges, simplifyVersionRange ) +import Distribution.Verbosity (Verbosity) +import Distribution.Text + ( Text(disp), display ) + +import Distribution.Client.Types + ( AvailablePackage(..), Repo, AvailablePackageDb(..) + , InstalledPackage(..) ) +import Distribution.Client.Dependency.Types + ( PackageConstraint(..) ) +import Distribution.Client.Targets + ( UserTarget, resolveUserTargets, PackageSpecifier(..) ) +import Distribution.Client.Setup + ( GlobalFlags(..), ListFlags(..), InfoFlags(..) ) +import Distribution.Client.Utils + ( mergeBy, MergeResult(..) ) +import Distribution.Client.IndexUtils as IndexUtils + ( getAvailablePackages, getInstalledPackages ) +import Distribution.Client.FetchUtils + ( isFetched ) + +import Data.List + ( sortBy, groupBy, sort, nub, intersperse, maximumBy, partition ) +import Data.Maybe + ( listToMaybe, fromJust, fromMaybe, isJust ) +import qualified Data.Map as Map +import Data.Tree as Tree +import Control.Monad + ( MonadPlus(mplus), join ) +import Control.Exception + ( assert ) +import Text.PrettyPrint.HughesPJ as Disp +import System.Directory + ( doesDirectoryExist ) + + +-- |Show information about packages +list :: Verbosity + -> PackageDBStack + -> [Repo] + -> Compiler + -> ProgramConfiguration + -> ListFlags + -> [String] + -> IO () +list verbosity packageDBs repos comp conf listFlags pats = do + + installed <- getInstalledPackages verbosity comp packageDBs conf + availableDb <- getAvailablePackages verbosity repos + let available = packageIndex availableDb + prefs name = fromMaybe anyVersion + (Map.lookup name (packagePreferences availableDb)) + + pkgsInfo :: [(PackageName, [InstalledPackage], [AvailablePackage])] + pkgsInfo + -- gather info for all packages + | null pats = mergePackages (PackageIndex.allPackages installed) + (PackageIndex.allPackages available) + + -- gather info for packages matching search term + | otherwise = mergePackages (matchingPackages installed) + (matchingPackages available) + + matches :: [PackageDisplayInfo] + matches = [ mergePackageInfo pref + installedPkgs availablePkgs selectedPkg False + | (pkgname, installedPkgs, availablePkgs) <- pkgsInfo + , not onlyInstalled || not (null installedPkgs) + , let pref = prefs pkgname + selectedPkg = latestWithPref pref availablePkgs ] + + if simpleOutput + then putStr $ unlines + [ display (pkgName pkg) ++ " " ++ display version + | pkg <- matches + , version <- if onlyInstalled + then installedVersions pkg + else nub . sort $ installedVersions pkg + ++ availableVersions pkg ] + -- Note: this only works because for 'list', one cannot currently + -- specify any version constraints, so listing all installed + -- and available ones works. + else + if null matches + then notice verbosity "No matches found." + else putStr $ unlines (map showPackageSummaryInfo matches) + where + onlyInstalled = fromFlag (listInstalled listFlags) + simpleOutput = fromFlag (listSimpleOutput listFlags) + + matchingPackages index = + [ pkg + | pat <- pats + , (_, pkgs) <- PackageIndex.searchByNameSubstring index pat + , pkg <- pkgs ] + +info :: Verbosity + -> PackageDBStack + -> [Repo] + -> Compiler + -> ProgramConfiguration + -> GlobalFlags + -> InfoFlags + -> [UserTarget] + -> IO () +info verbosity packageDBs repos comp conf + globalFlags _listFlags userTargets = do + + installed <- getInstalledPackages verbosity comp packageDBs conf + availableDb <- getAvailablePackages verbosity repos + let available = packageIndex availableDb + prefs name = fromMaybe anyVersion + (Map.lookup name (packagePreferences availableDb)) + + -- Users may specify names of packages that are only installed, not + -- just available source packages, so we must resolve targets using + -- the combination of installed and available packages. + let available' = PackageIndex.fromList + $ map packageId (PackageIndex.allPackages installed) + ++ map packageId (PackageIndex.allPackages available) + pkgSpecifiers <- resolveUserTargets verbosity + globalFlags available' userTargets + + pkgsinfo <- sequence + [ do pkginfo <- either die return $ + gatherPkgInfo prefs + installed available pkgSpecifier + updateFileSystemPackageDetails pkginfo + | pkgSpecifier <- pkgSpecifiers ] + + putStr $ unlines (map showPackageDetailedInfo pkgsinfo) + + where + gatherPkgInfo prefs installed available (NamedPackage name constraints) + | null (selectedInstalledPkgs) && null (selectedAvailablePkgs) + = Left $ "There is no available version of " ++ display name + ++ " that satisfies " + ++ display (simplifyVersionRange verConstraint) + + | otherwise + = Right $ mergePackageInfo pref installedPkgs + availablePkgs selectedAvailablePkg + showPkgVersion + where + pref = prefs name + installedPkgs = PackageIndex.lookupPackageName installed name + availablePkgs = PackageIndex.lookupPackageName available name + + selectedInstalledPkgs = PackageIndex.lookupDependency installed + (Dependency name verConstraint) + selectedAvailablePkgs = PackageIndex.lookupDependency available + (Dependency name verConstraint) + selectedAvailablePkg = latestWithPref pref selectedAvailablePkgs + + -- display a specific package version if the user + -- supplied a non-trivial version constraint + showPkgVersion = not (null verConstraints) + verConstraint = foldr intersectVersionRanges anyVersion verConstraints + verConstraints = [ vr | PackageVersionConstraint _ vr <- constraints ] + + gatherPkgInfo prefs installed available (SpecificSourcePackage pkg) = + Right $ mergePackageInfo pref installedPkgs availablePkgs + selectedPkg True + where + name = packageName pkg + pref = prefs name + installedPkgs = PackageIndex.lookupPackageName installed name + availablePkgs = PackageIndex.lookupPackageName available name + selectedPkg = Just pkg + + +-- | The info that we can display for each package. It is information per +-- package name and covers all installed and avilable versions. +-- +data PackageDisplayInfo = PackageDisplayInfo { + pkgName :: PackageName, + selectedVersion :: Maybe Version, + selectedAvailable :: Maybe AvailablePackage, + installedVersions :: [Version], + availableVersions :: [Version], + preferredVersions :: VersionRange, + homepage :: String, + bugReports :: String, + sourceRepo :: String, + synopsis :: String, + description :: String, + category :: String, + license :: License, + author :: String, + maintainer :: String, + dependencies :: [Dependency], + flags :: [Flag], + hasLib :: Bool, + hasExe :: Bool, + executables :: [String], + modules :: [ModuleName], + haddockHtml :: FilePath, + haveTarball :: Bool + } + +showPackageSummaryInfo :: PackageDisplayInfo -> String +showPackageSummaryInfo pkginfo = + renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $ + char '*' <+> disp (pkgName pkginfo) + $+$ + (nest 4 $ vcat [ + maybeShow (synopsis pkginfo) "Synopsis:" reflowParagraphs + , text "Default available version:" <+> + case selectedAvailable pkginfo of + Nothing -> text "[ Not available from any configured repository ]" + Just pkg -> disp (packageVersion pkg) + , text "Installed versions:" <+> + case installedVersions pkginfo of + [] | hasLib pkginfo -> text "[ Not installed ]" + | otherwise -> text "[ Unknown ]" + versions -> dispTopVersions 4 + (preferredVersions pkginfo) versions + , maybeShow (homepage pkginfo) "Homepage:" text + , text "License: " <+> text (display (license pkginfo)) + ]) + $+$ text "" + where + maybeShow [] _ _ = empty + maybeShow l s f = text s <+> (f l) + +showPackageDetailedInfo :: PackageDisplayInfo -> String +showPackageDetailedInfo pkginfo = + renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $ + char '*' <+> disp (pkgName pkginfo) + <> maybe empty (\v -> char '-' <> disp v) (selectedVersion pkginfo) + <+> text (replicate (16 - length (display (pkgName pkginfo))) ' ') + <> parens pkgkind + $+$ + (nest 4 $ vcat [ + entry "Synopsis" synopsis hideIfNull reflowParagraphs + , entry "Versions available" availableVersions + (altText null "[ Not available from server ]") + (dispTopVersions 9 (preferredVersions pkginfo)) + , entry "Versions installed" installedVersions + (altText null (if hasLib pkginfo then "[ Not installed ]" + else "[ Unknown ]")) + (dispTopVersions 4 (preferredVersions pkginfo)) + , entry "Homepage" homepage orNotSpecified text + , entry "Bug reports" bugReports orNotSpecified text + , entry "Description" description hideIfNull reflowParagraphs + , entry "Category" category hideIfNull text + , entry "License" license alwaysShow disp + , entry "Author" author hideIfNull reflowLines + , entry "Maintainer" maintainer hideIfNull reflowLines + , entry "Source repo" sourceRepo orNotSpecified text + , entry "Executables" executables hideIfNull (commaSep text) + , entry "Flags" flags hideIfNull (commaSep dispFlag) + , entry "Dependencies" dependencies hideIfNull (commaSep disp) + , entry "Documentation" haddockHtml showIfInstalled text + , entry "Cached" haveTarball alwaysShow dispYesNo + , if not (hasLib pkginfo) then empty else + text "Modules:" $+$ nest 4 (vcat (map disp . sort . modules $ pkginfo)) + ]) + $+$ text "" + where + entry fname field cond format = case cond (field pkginfo) of + Nothing -> label <+> format (field pkginfo) + Just Nothing -> empty + Just (Just other) -> label <+> text other + where + label = text fname <> char ':' <> padding + padding = text (replicate (13 - length fname ) ' ') + + normal = Nothing + hide = Just Nothing + replace msg = Just (Just msg) + + alwaysShow = const normal + hideIfNull v = if null v then hide else normal + showIfInstalled v + | not isInstalled = hide + | null v = replace "[ Not installed ]" + | otherwise = normal + altText nul msg v = if nul v then replace msg else normal + orNotSpecified = altText null "[ Not specified ]" + + commaSep f = Disp.fsep . Disp.punctuate (Disp.char ',') . map f + dispFlag f = case flagName f of FlagName n -> text n + dispYesNo True = text "Yes" + dispYesNo False = text "No" + + isInstalled = not (null (installedVersions pkginfo)) + hasExes = length (executables pkginfo) >= 2 + --TODO: exclude non-buildable exes + pkgkind | hasLib pkginfo && hasExes = text "programs and library" + | hasLib pkginfo && hasExe pkginfo = text "program and library" + | hasLib pkginfo = text "library" + | hasExes = text "programs" + | hasExe pkginfo = text "program" + | otherwise = empty + + +reflowParagraphs :: String -> Doc +reflowParagraphs = + vcat + . intersperse (text "") -- re-insert blank lines + . map (fsep . map text . concatMap words) -- reflow paragraphs + . filter (/= [""]) + . groupBy (\x y -> "" `notElem` [x,y]) -- break on blank lines + . lines + +reflowLines :: String -> Doc +reflowLines = vcat . map text . lines + +-- | We get the 'PackageDisplayInfo' by combining the info for the installed +-- and available versions of a package. +-- +-- * We're building info about a various versions of a single named package so +-- the input package info records are all supposed to refer to the same +-- package name. +-- +mergePackageInfo :: VersionRange + -> [InstalledPackage] + -> [AvailablePackage] + -> Maybe AvailablePackage + -> Bool + -> PackageDisplayInfo +mergePackageInfo versionPref installedPkgs availablePkgs selectedPkg showVer = + assert (length installedPkgs + length availablePkgs > 0) $ + PackageDisplayInfo { + pkgName = combine packageName available + packageName installed, + selectedVersion = if showVer then fmap packageVersion selectedPkg + else Nothing, + selectedAvailable = availableSelected, + installedVersions = map packageVersion installedPkgs, + availableVersions = map packageVersion availablePkgs, + preferredVersions = versionPref, + + license = combine Available.license available + Installed.license installed, + maintainer = combine Available.maintainer available + Installed.maintainer installed, + author = combine Available.author available + Installed.author installed, + homepage = combine Available.homepage available + Installed.homepage installed, + bugReports = maybe "" Available.bugReports available, + sourceRepo = fromMaybe "" . join + . fmap (uncons Nothing Available.repoLocation + . sortBy (comparing Available.repoKind) + . Available.sourceRepos) + $ available, + --TODO: installed package info is missing synopsis + synopsis = maybe "" Available.synopsis available, + description = combine Available.description available + Installed.description installed, + category = combine Available.category available + Installed.category installed, + flags = maybe [] Available.genPackageFlags availableGeneric, + hasLib = isJust installed + || fromMaybe False + (fmap (isJust . Available.condLibrary) availableGeneric), + hasExe = fromMaybe False + (fmap (not . null . Available.condExecutables) availableGeneric), + executables = map fst (maybe [] Available.condExecutables availableGeneric), + modules = combine Installed.exposedModules installed + (maybe [] Available.exposedModules + . Available.library) available, + dependencies = map simplifyDependency + $ combine Available.buildDepends available + (map thisPackageVersion . depends) installed', + haddockHtml = fromMaybe "" . join + . fmap (listToMaybe . Installed.haddockHTMLs) + $ installed, + haveTarball = False + } + where + combine f x g y = fromJust (fmap f x `mplus` fmap g y) + installed' = latestWithPref versionPref installedPkgs + installed = fmap (\(InstalledPackage p _) -> p) installed' + + availableSelected + | isJust selectedPkg = selectedPkg + | otherwise = latestWithPref versionPref availablePkgs + availableGeneric = fmap packageDescription availableSelected + available = fmap flattenPackageDescription availableGeneric + + uncons :: b -> (a -> b) -> [a] -> b + uncons z _ [] = z + uncons _ f (x:_) = f x + + +-- | Not all the info is pure. We have to check if the docs really are +-- installed, because the registered package info lies. Similarly we have to +-- check if the tarball has indeed been fetched. +-- +updateFileSystemPackageDetails :: PackageDisplayInfo -> IO PackageDisplayInfo +updateFileSystemPackageDetails pkginfo = do + fetched <- maybe (return False) (isFetched . packageSource) + (selectedAvailable pkginfo) + docsExist <- doesDirectoryExist (haddockHtml pkginfo) + return pkginfo { + haveTarball = fetched, + haddockHtml = if docsExist then haddockHtml pkginfo else "" + } + +latestWithPref :: Package pkg => VersionRange -> [pkg] -> Maybe pkg +latestWithPref _ [] = Nothing +latestWithPref pref pkgs = Just (maximumBy (comparing prefThenVersion) pkgs) + where + prefThenVersion pkg = let ver = packageVersion pkg + in (withinRange ver pref, ver) + + +-- | Rearrange installed and available packages into groups referring to the +-- same package by name. In the result pairs, the lists are guaranteed to not +-- both be empty. +-- +mergePackages :: [InstalledPackage] + -> [AvailablePackage] + -> [( PackageName + , [InstalledPackage] + , [AvailablePackage] )] +mergePackages installed available = + map collect + $ mergeBy (\i a -> fst i `compare` fst a) + (groupOn packageName installed) + (groupOn packageName available) + where + collect (OnlyInLeft (name,is) ) = (name, is, []) + collect ( InBoth (_,is) (name,as)) = (name, is, as) + collect (OnlyInRight (name,as)) = (name, [], as) + +groupOn :: Ord key => (a -> key) -> [a] -> [(key,[a])] +groupOn key = map (\xs -> (key (head xs), xs)) + . groupBy (equating key) + . sortBy (comparing key) + +dispTopVersions :: Int -> VersionRange -> [Version] -> Doc +dispTopVersions n pref vs = + (Disp.fsep . Disp.punctuate (Disp.char ',') + . map (\ver -> if ispref ver then disp ver else parens (disp ver)) + . sort . take n . interestingVersions ispref + $ vs) + <+> trailingMessage + + where + ispref ver = withinRange ver pref + extra = length vs - n + trailingMessage + | extra <= 0 = Disp.empty + | otherwise = Disp.parens $ Disp.text "and" + <+> Disp.int (length vs - n) + <+> if extra == 1 then Disp.text "other" + else Disp.text "others" + +-- | Reorder a bunch of versions to put the most interesting / significant +-- versions first. A preferred version range is taken into account. +-- +-- This may be used in a user interface to select a small number of versions +-- to present to the user, e.g. +-- +-- > let selectVersions = sort . take 5 . interestingVersions pref +-- +interestingVersions :: (Version -> Bool) -> [Version] -> [Version] +interestingVersions pref = + map ((\ns -> Version ns []) . fst) . filter snd + . concat . Tree.levels + . swizzleTree + . reorderTree (\(Node (v,_) _) -> pref (Version v [])) + . reverseTree + . mkTree + . map versionBranch + + where + swizzleTree = unfoldTree (spine []) + where + spine ts' (Node x []) = (x, ts') + spine ts' (Node x (t:ts)) = spine (Node x ts:ts') t + + reorderTree _ (Node x []) = Node x [] + reorderTree p (Node x ts) = Node x (ts' ++ ts'') + where + (ts',ts'') = partition p (map (reorderTree p) ts) + + reverseTree (Node x cs) = Node x (reverse (map reverseTree cs)) + + mkTree xs = unfoldTree step (False, [], xs) + where + step (node,ns,vs) = + ( (reverse ns, node) + , [ (any null vs', n:ns, filter (not . null) vs') + | (n, vs') <- groups vs ] + ) + groups = map (\g -> (head (head g), map tail g)) + . groupBy (equating head) diff --git a/Distribution/Client/PackageIndex.hs b/Distribution/Client/PackageIndex.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/PackageIndex.hs @@ -0,0 +1,478 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.PackageIndex +-- Copyright : (c) David Himmelstrup 2005, +-- Bjorn Bringert 2007, +-- Duncan Coutts 2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- An index of packages. +-- +module Distribution.Client.PackageIndex ( + -- * Package index data type + PackageIndex, + + -- * Creating an index + fromList, + + -- * Updates + merge, + insert, + deletePackageName, + deletePackageId, + deleteDependency, + + -- * Queries + + -- ** Precise lookups + lookupPackageName, + lookupPackageId, + lookupDependency, + + -- ** Case-insensitive searches + searchByName, + SearchResult(..), + searchByNameSubstring, + + -- ** Bulk queries + allPackages, + allPackagesByName, + + -- ** Special queries + brokenPackages, + dependencyClosure, + reverseDependencyClosure, + topologicalOrder, + reverseTopologicalOrder, + dependencyInconsistencies, + dependencyCycles, + dependencyGraph, + ) where + +import Prelude hiding (lookup) +import Control.Exception (assert) +import qualified Data.Map as Map +import Data.Map (Map) +import qualified Data.Tree as Tree +import qualified Data.Graph as Graph +import qualified Data.Array as Array +import Data.Array ((!)) +import Data.List (groupBy, sortBy, nub, isInfixOf) +import Data.Monoid (Monoid(..)) +import Data.Maybe (isNothing, fromMaybe) + +import Distribution.Package + ( PackageName(..), PackageIdentifier(..) + , Package(..), packageName, packageVersion + , Dependency(Dependency), PackageFixedDeps(..) ) +import Distribution.Version + ( Version, withinRange ) +import Distribution.Simple.Utils (lowercase, equating, comparing) + + +-- | The collection of information about packages from one or more 'PackageDB's. +-- +-- It can be searched effeciently by package name and version. +-- +newtype Package pkg => PackageIndex pkg = PackageIndex + -- This index package names to all the package records matching that package + -- name case-sensitively. It includes all versions. + -- + -- This allows us to find all versions satisfying a dependency. + -- Most queries are a map lookup followed by a linear scan of the bucket. + -- + (Map PackageName [pkg]) + + deriving (Show, Read) + +instance Package pkg => Monoid (PackageIndex pkg) where + mempty = PackageIndex (Map.empty) + mappend = merge + --save one mappend with empty in the common case: + mconcat [] = mempty + mconcat xs = foldr1 mappend xs + +invariant :: Package pkg => PackageIndex pkg -> Bool +invariant (PackageIndex m) = all (uncurry goodBucket) (Map.toList m) + where + goodBucket _ [] = False + goodBucket name (pkg0:pkgs0) = check (packageId pkg0) pkgs0 + where + check pkgid [] = packageName pkgid == name + check pkgid (pkg':pkgs) = packageName pkgid == name + && pkgid < pkgid' + && check pkgid' pkgs + where pkgid' = packageId pkg' + +-- +-- * Internal helpers +-- + +mkPackageIndex :: Package pkg => Map PackageName [pkg] -> PackageIndex pkg +mkPackageIndex index = assert (invariant (PackageIndex index)) + (PackageIndex index) + +internalError :: String -> a +internalError name = error ("PackageIndex." ++ name ++ ": internal error") + +-- | Lookup a name in the index to get all packages that match that name +-- case-sensitively. +-- +lookup :: Package pkg => PackageIndex pkg -> PackageName -> [pkg] +lookup (PackageIndex m) name = fromMaybe [] $ Map.lookup name m + +-- +-- * Construction +-- + +-- | Build an index out of a bunch of packages. +-- +-- If there are duplicates, later ones mask earlier ones. +-- +fromList :: Package pkg => [pkg] -> PackageIndex pkg +fromList pkgs = mkPackageIndex + . Map.map fixBucket + . Map.fromListWith (++) + $ [ (packageName pkg, [pkg]) + | pkg <- pkgs ] + where + fixBucket = -- out of groups of duplicates, later ones mask earlier ones + -- but Map.fromListWith (++) constructs groups in reverse order + map head + -- Eq instance for PackageIdentifier is wrong, so use Ord: + . groupBy (\a b -> EQ == comparing packageId a b) + -- relies on sortBy being a stable sort so we + -- can pick consistently among duplicates + . sortBy (comparing packageId) + +-- +-- * Updates +-- + +-- | Merge two indexes. +-- +-- Packages from the second mask packages of the same exact name +-- (case-sensitively) from the first. +-- +merge :: Package pkg => PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg +merge i1@(PackageIndex m1) i2@(PackageIndex m2) = + assert (invariant i1 && invariant i2) $ + mkPackageIndex (Map.unionWith mergeBuckets m1 m2) + +-- | Elements in the second list mask those in the first. +mergeBuckets :: Package pkg => [pkg] -> [pkg] -> [pkg] +mergeBuckets [] ys = ys +mergeBuckets xs [] = xs +mergeBuckets xs@(x:xs') ys@(y:ys') = + case packageId x `compare` packageId y of + GT -> y : mergeBuckets xs ys' + EQ -> y : mergeBuckets xs' ys' + LT -> x : mergeBuckets xs' ys + +-- | Inserts a single package into the index. +-- +-- This is equivalent to (but slightly quicker than) using 'mappend' or +-- 'merge' with a singleton index. +-- +insert :: Package pkg => pkg -> PackageIndex pkg -> PackageIndex pkg +insert pkg (PackageIndex index) = mkPackageIndex $ + Map.insertWith (\_ -> insertNoDup) (packageName pkg) [pkg] index + where + pkgid = packageId pkg + insertNoDup [] = [pkg] + insertNoDup pkgs@(pkg':pkgs') = case compare pkgid (packageId pkg') of + LT -> pkg : pkgs + EQ -> pkg : pkgs' + GT -> pkg' : insertNoDup pkgs' + +-- | Internal delete helper. +-- +delete :: Package pkg => PackageName -> (pkg -> Bool) -> PackageIndex pkg -> PackageIndex pkg +delete name p (PackageIndex index) = mkPackageIndex $ + Map.update filterBucket name index + where + filterBucket = deleteEmptyBucket + . filter (not . p) + deleteEmptyBucket [] = Nothing + deleteEmptyBucket remaining = Just remaining + +-- | Removes a single package from the index. +-- +deletePackageId :: Package pkg => PackageIdentifier -> PackageIndex pkg -> PackageIndex pkg +deletePackageId pkgid = + delete (packageName pkgid) (\pkg -> packageId pkg == pkgid) + +-- | Removes all packages with this (case-sensitive) name from the index. +-- +deletePackageName :: Package pkg => PackageName -> PackageIndex pkg -> PackageIndex pkg +deletePackageName name = + delete name (\pkg -> packageName pkg == name) + +-- | Removes all packages satisfying this dependency from the index. +-- +deleteDependency :: Package pkg => Dependency -> PackageIndex pkg -> PackageIndex pkg +deleteDependency (Dependency name verstionRange) = + delete name (\pkg -> packageVersion pkg `withinRange` verstionRange) + +-- +-- * Bulk queries +-- + +-- | Get all the packages from the index. +-- +allPackages :: Package pkg => PackageIndex pkg -> [pkg] +allPackages (PackageIndex m) = concat (Map.elems m) + +-- | Get all the packages from the index. +-- +-- They are grouped by package name, case-sensitively. +-- +allPackagesByName :: Package pkg => PackageIndex pkg -> [[pkg]] +allPackagesByName (PackageIndex m) = Map.elems m + +-- +-- * Lookups +-- + +-- | Does a lookup by package id (name & version). +-- +-- Since multiple package DBs mask each other case-sensitively by package name, +-- then we get back at most one package. +-- +lookupPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> Maybe pkg +lookupPackageId index pkgid = + case [ pkg | pkg <- lookup index (packageName pkgid) + , packageId pkg == pkgid ] of + [] -> Nothing + [pkg] -> Just pkg + _ -> internalError "lookupPackageIdentifier" + +-- | Does a case-sensitive search by package name. +-- +lookupPackageName :: Package pkg => PackageIndex pkg -> PackageName -> [pkg] +lookupPackageName index name = + [ pkg | pkg <- lookup index name + , packageName pkg == name ] + +-- | Does a case-sensitive search by package name and a range of versions. +-- +-- We get back any number of versions of the specified package name, all +-- satisfying the version range constraint. +-- +lookupDependency :: Package pkg => PackageIndex pkg -> Dependency -> [pkg] +lookupDependency index (Dependency name versionRange) = + [ pkg | pkg <- lookup index name + , packageName pkg == name + , packageVersion pkg `withinRange` versionRange ] + +-- +-- * Case insensitive name lookups +-- + +-- | Does a case-insensitive search by package name. +-- +-- If there is only one package that compares case-insentiviely to this name +-- then the search is unambiguous and we get back all versions of that package. +-- If several match case-insentiviely but one matches exactly then it is also +-- unambiguous. +-- +-- If however several match case-insentiviely and none match exactly then we +-- have an ambiguous result, and we get back all the versions of all the +-- packages. The list of ambiguous results is split by exact package name. So +-- it is a non-empty list of non-empty lists. +-- +searchByName :: Package pkg => PackageIndex pkg + -> String -> [(PackageName, [pkg])] +searchByName (PackageIndex m) name = + [ pkgs + | pkgs@(PackageName name',_) <- Map.toList m + , lowercase name' == lname ] + where + lname = lowercase name + +data SearchResult a = None | Unambiguous a | Ambiguous [a] + +-- | Does a case-insensitive substring search by package name. +-- +-- That is, all packages that contain the given string in their name. +-- +searchByNameSubstring :: Package pkg => PackageIndex pkg + -> String -> [(PackageName, [pkg])] +searchByNameSubstring (PackageIndex m) searchterm = + [ pkgs + | pkgs@(PackageName name, _) <- Map.toList m + , lsearchterm `isInfixOf` lowercase name ] + where + lsearchterm = lowercase searchterm + +-- +-- * Special queries +-- + +-- | All packages that have dependencies that are not in the index. +-- +-- Returns such packages along with the dependencies that they're missing. +-- +brokenPackages :: PackageFixedDeps pkg + => PackageIndex pkg + -> [(pkg, [PackageIdentifier])] +brokenPackages index = + [ (pkg, missing) + | pkg <- allPackages index + , let missing = [ pkg' | pkg' <- depends pkg + , isNothing (lookupPackageId index pkg') ] + , not (null missing) ] + +-- | Tries to take the transative closure of the package dependencies. +-- +-- If the transative 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 +-- the original given 'PackageIdentifier's do not occur in the index. +-- +dependencyClosure :: PackageFixedDeps pkg + => PackageIndex pkg + -> [PackageIdentifier] + -> Either (PackageIndex pkg) + [(pkg, [PackageIdentifier])] +dependencyClosure index pkgids0 = case closure mempty [] pkgids0 of + (completed, []) -> Left completed + (completed, _) -> Right (brokenPackages completed) + where + closure completed failed [] = (completed, failed) + closure completed failed (pkgid:pkgids) = case lookupPackageId index pkgid of + Nothing -> closure completed (pkgid:failed) pkgids + Just pkg -> case lookupPackageId completed (packageId pkg) of + Just _ -> closure completed failed pkgids + Nothing -> closure completed' failed pkgids' + where completed' = insert pkg completed + pkgids' = depends pkg ++ pkgids + +-- | Takes the transative closure of the packages reverse dependencies. +-- +-- * The given 'PackageIdentifier's must be in the index. +-- +reverseDependencyClosure :: PackageFixedDeps pkg + => PackageIndex pkg + -> [PackageIdentifier] + -> [pkg] +reverseDependencyClosure index = + map vertexToPkg + . concatMap Tree.flatten + . Graph.dfs reverseDepGraph + . map (fromMaybe noSuchPkgId . pkgIdToVertex) + + where + (depGraph, vertexToPkg, pkgIdToVertex) = dependencyGraph index + reverseDepGraph = Graph.transposeG depGraph + noSuchPkgId = error "reverseDependencyClosure: package is not in the graph" + +topologicalOrder :: PackageFixedDeps pkg => PackageIndex pkg -> [pkg] +topologicalOrder index = map toPkgId + . Graph.topSort + $ graph + where (graph, toPkgId, _) = dependencyGraph index + +reverseTopologicalOrder :: PackageFixedDeps pkg => PackageIndex pkg -> [pkg] +reverseTopologicalOrder index = map toPkgId + . Graph.topSort + . Graph.transposeG + $ graph + where (graph, toPkgId, _) = dependencyGraph index + +-- | Given a package index where we assume we want to use all the packages +-- (use 'dependencyClosure' if you need to get such a index subset) find out +-- if the dependencies within it use consistent versions of each package. +-- Return all cases where multiple packages depend on different versions of +-- some other package. +-- +-- Each element in the result is a package name along with the packages that +-- depend on it and the versions they require. These are guaranteed to be +-- distinct. +-- +dependencyInconsistencies :: PackageFixedDeps pkg + => PackageIndex pkg + -> [(PackageName, [(PackageIdentifier, Version)])] +dependencyInconsistencies index = + [ (name, inconsistencies) + | (name, uses) <- Map.toList inverseIndex + , let inconsistencies = duplicatesBy uses + versions = map snd inconsistencies + , reallyIsInconsistent name (nub versions) ] + + where inverseIndex = Map.fromListWith (++) + [ (packageName dep, [(packageId pkg, packageVersion dep)]) + | pkg <- allPackages index + , dep <- depends pkg ] + + duplicatesBy = (\groups -> if length groups == 1 + then [] + else concat groups) + . groupBy (equating snd) + . sortBy (comparing snd) + + reallyIsInconsistent :: PackageName -> [Version] -> Bool + reallyIsInconsistent _ [] = False + reallyIsInconsistent name [v1, v2] = + case (mpkg1, mpkg2) of + (Just pkg1, Just pkg2) -> pkgid1 `notElem` depends pkg2 + && pkgid2 `notElem` depends pkg1 + _ -> True + where + pkgid1 = PackageIdentifier name v1 + pkgid2 = PackageIdentifier name v2 + mpkg1 = lookupPackageId index pkgid1 + mpkg2 = lookupPackageId index pkgid2 + + reallyIsInconsistent _ _ = True + +-- | Find if there are any cycles in the dependency graph. If there are no +-- cycles the result is @[]@. +-- +-- This actually computes the strongly connected components. So it gives us a +-- list of groups of packages where within each group they all depend on each +-- other, directly or indirectly. +-- +dependencyCycles :: PackageFixedDeps pkg + => PackageIndex pkg + -> [[pkg]] +dependencyCycles index = + [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ] + where + adjacencyList = [ (pkg, packageId pkg, depends pkg) + | pkg <- allPackages index ] + +-- | Builds a graph of the package dependencies. +-- +-- Dependencies on other packages that are not in the index are discarded. +-- You can check if there are any such dependencies with 'brokenPackages'. +-- +dependencyGraph :: PackageFixedDeps pkg + => PackageIndex pkg + -> (Graph.Graph, + Graph.Vertex -> pkg, + PackageIdentifier -> Maybe Graph.Vertex) +dependencyGraph index = (graph, vertexToPkg, pkgIdToVertex) + where + graph = Array.listArray bounds + [ [ v | Just v <- map pkgIdToVertex (depends pkg) ] + | pkg <- pkgs ] + vertexToPkg vertex = pkgTable ! vertex + pkgIdToVertex = binarySearch 0 topBound + + pkgTable = Array.listArray bounds pkgs + pkgIdTable = Array.listArray bounds (map packageId pkgs) + pkgs = sortBy (comparing packageId) (allPackages index) + topBound = length pkgs - 1 + bounds = (0, topBound) + + binarySearch a b key + | a > b = Nothing + | otherwise = case compare key (pkgIdTable ! mid) of + LT -> binarySearch a (mid-1) key + EQ -> Just mid + GT -> binarySearch (mid+1) b key + where mid = (a + b) `div` 2 diff --git a/Distribution/Client/PackageUtils.hs b/Distribution/Client/PackageUtils.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/PackageUtils.hs @@ -0,0 +1,34 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.PackageUtils +-- Copyright : (c) Duncan Coutts 2010 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Various package description utils that should be in the Cabal lib +----------------------------------------------------------------------------- +module Distribution.Client.PackageUtils ( + externalBuildDepends, + ) where + +import Distribution.Package + ( packageVersion, packageName, Dependency(..) ) +import Distribution.PackageDescription + ( PackageDescription(..) ) +import Distribution.Version + ( withinRange ) + +-- | The list of dependencies that refer to external packages +-- rather than internal package components. +-- +externalBuildDepends :: PackageDescription -> [Dependency] +externalBuildDepends pkg = filter (not . internal) (buildDepends pkg) + where + -- True if this dependency is an internal one (depends on a library + -- defined in the same package). + internal (Dependency depName versionRange) = + depName == packageName pkg && + packageVersion pkg `withinRange` versionRange diff --git a/Distribution/Client/Setup.hs b/Distribution/Client/Setup.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Setup.hs @@ -0,0 +1,1009 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Setup +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- +----------------------------------------------------------------------------- +module Distribution.Client.Setup + ( globalCommand, GlobalFlags(..), globalRepos + , configureCommand, ConfigFlags(..), filterConfigureFlags + , configureExCommand, ConfigExFlags(..), defaultConfigExFlags + , configureExOptions + , installCommand, InstallFlags(..), installOptions, defaultInstallFlags + , listCommand, ListFlags(..) + , updateCommand + , upgradeCommand + , infoCommand, InfoFlags(..) + , fetchCommand, FetchFlags(..) + , checkCommand + , uploadCommand, UploadFlags(..) + , reportCommand, ReportFlags(..) + , unpackCommand, UnpackFlags(..) + , initCommand, IT.InitFlags(..) + + , parsePackageArgs + --TODO: stop exporting these: + , showRepo + , parseRepo + ) where + +import Distribution.Client.Types + ( Username(..), Password(..), Repo(..), RemoteRepo(..), LocalRepo(..) ) +import Distribution.Client.BuildReports.Types + ( ReportLevel(..) ) +import qualified Distribution.Client.Init.Types as IT + ( InitFlags(..), PackageType(..) ) + +import Distribution.Simple.Program + ( defaultProgramConfiguration ) +import Distribution.Simple.Command hiding (boolOpt) +import qualified Distribution.Simple.Command as Command +import qualified Distribution.Simple.Setup as Cabal + ( configureCommand ) +import Distribution.Simple.Setup + ( ConfigFlags(..) ) +import Distribution.Simple.Setup + ( Flag(..), toFlag, fromFlag, flagToList, flagToMaybe + , optionVerbosity, trueArg, falseArg ) +import Distribution.Simple.InstallDirs + ( PathTemplate, toPathTemplate, fromPathTemplate ) +import Distribution.Version + ( Version(Version), anyVersion, thisVersion ) +import Distribution.Package + ( PackageIdentifier, packageName, packageVersion, Dependency(..) ) +import Distribution.Text + ( Text(parse), display ) +import Distribution.ReadE + ( readP_to_E, succeedReadE ) +import qualified Distribution.Compat.ReadP as Parse + ( ReadP, readP_to_S, char, munch1, pfail, (+++) ) +import Distribution.Verbosity + ( Verbosity, normal ) +import Distribution.Simple.Utils + ( wrapText ) + +import Data.Char + ( isSpace, isAlphaNum ) +import Data.Maybe + ( listToMaybe, maybeToList, fromMaybe ) +import Data.Monoid + ( Monoid(..) ) +import Control.Monad + ( liftM ) +import System.FilePath + ( () ) +import Network.URI + ( parseAbsoluteURI, uriToString ) + +-- ------------------------------------------------------------ +-- * Global flags +-- ------------------------------------------------------------ + +-- | 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 + } + +defaultGlobalFlags :: GlobalFlags +defaultGlobalFlags = GlobalFlags { + globalVersion = Flag False, + globalNumericVersion = Flag False, + globalConfigFile = mempty, + globalRemoteRepos = [], + globalCacheDir = mempty, + globalLocalRepos = mempty, + globalLogsDir = mempty, + globalWorldFile = mempty + } + +globalCommand :: CommandUI GlobalFlags +globalCommand = CommandUI { + commandName = "", + commandSynopsis = "", + commandUsage = \_ -> + "This program is the command line interface " + ++ "to the Haskell Cabal infrastructure.\n" + ++ "See http://www.haskell.org/cabal/ for more information.\n", + commandDescription = Just $ \pname -> + "For more information about a command use:\n" + ++ " " ++ pname ++ " COMMAND --help\n\n" + ++ "To install Cabal packages from hackage use:\n" + ++ " " ++ pname ++ " install foo [--dry-run]\n\n" + ++ "Occasionally you need to update the list of available packages:\n" + ++ " " ++ pname ++ " update\n", + commandDefaultFlags = defaultGlobalFlags, + commandOptions = \showOrParseArgs -> + (case showOrParseArgs of ShowArgs -> take 2; ParseArgs -> id) + [option ['V'] ["version"] + "Print version information" + globalVersion (\v flags -> flags { globalVersion = v }) + trueArg + + ,option [] ["numeric-version"] + "Print just the version number" + globalNumericVersion (\v flags -> flags { globalNumericVersion = v }) + trueArg + + ,option [] ["config-file"] + "Set an alternate location for the config file" + globalConfigFile (\v flags -> flags { globalConfigFile = v }) + (reqArgFlag "FILE") + + ,option [] ["remote-repo"] + "The name and url for a remote repository" + globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v }) + (reqArg' "NAME:URL" (maybeToList . readRepo) (map showRepo)) + + ,option [] ["remote-repo-cache"] + "The location where downloads from all remote repos are cached" + globalCacheDir (\v flags -> flags { globalCacheDir = v }) + (reqArgFlag "DIR") + + ,option [] ["local-repo"] + "The location of a local repository" + globalLocalRepos (\v flags -> flags { globalLocalRepos = v }) + (reqArg' "DIR" (\x -> [x]) id) + + ,option [] ["logs-dir"] + "The location to put log files" + globalLogsDir (\v flags -> flags { globalLogsDir = v }) + (reqArgFlag "DIR") + + ,option [] ["world-file"] + "The location of the world file" + globalWorldFile (\v flags -> flags { globalWorldFile = v }) + (reqArgFlag "FILE") + ] + } + +instance Monoid GlobalFlags where + mempty = GlobalFlags { + globalVersion = mempty, + globalNumericVersion = mempty, + globalConfigFile = 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 + } + where combine field = field a `mappend` field b + +globalRepos :: GlobalFlags -> [Repo] +globalRepos globalFlags = remoteRepos ++ localRepos + where + remoteRepos = + [ Repo (Left remote) cacheDir + | remote <- globalRemoteRepos globalFlags + , let cacheDir = fromFlag (globalCacheDir globalFlags) + remoteRepoName remote ] + localRepos = + [ Repo (Right LocalRepo) local + | local <- globalLocalRepos globalFlags ] + +-- ------------------------------------------------------------ +-- * Config flags +-- ------------------------------------------------------------ + +configureCommand :: CommandUI ConfigFlags +configureCommand = (Cabal.configureCommand defaultProgramConfiguration) { + commandDefaultFlags = mempty + } + +configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags] +configureOptions = commandOptions configureCommand + +filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags +filterConfigureFlags flags cabalLibVersion + | cabalLibVersion >= Version [1,3,10] [] = flags + -- older Cabal does not grok the constraints flag: + | otherwise = flags { configConstraints = [] } + + +-- ------------------------------------------------------------ +-- * Config extra flags +-- ------------------------------------------------------------ + +-- | cabal configure takes some extra flags beyond runghc Setup configure +-- +data ConfigExFlags = ConfigExFlags { + configCabalVersion :: Flag Version, + configPreferences :: [Dependency] + } + +defaultConfigExFlags :: ConfigExFlags +defaultConfigExFlags = mempty + +configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags) +configureExCommand = configureCommand { + commandDefaultFlags = (mempty, defaultConfigExFlags), + commandOptions = \showOrParseArgs -> + liftOptions fst setFst (configureOptions showOrParseArgs) + ++ liftOptions snd setSnd (configureExOptions showOrParseArgs) + } + where + setFst a (_,b) = (a,b) + setSnd b (a,_) = (a,b) + +configureExOptions :: ShowOrParseArgs -> [OptionField ConfigExFlags] +configureExOptions _showOrParseArgs = + [ option [] ["cabal-lib-version"] + ("Select which version of the Cabal lib to use to build packages " + ++ "(useful for testing).") + configCabalVersion (\v flags -> flags { configCabalVersion = v }) + (reqArg "VERSION" (readP_to_E ("Cannot parse cabal lib version: "++) + (fmap toFlag parse)) + (map display . flagToList)) + + , option [] ["preference"] + "Specify preferences (soft constraints) on the version of a package" + configPreferences (\v flags -> flags { configPreferences = v }) + (reqArg "DEPENDENCY" + (readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parse)) + (map (\x -> display x))) + ] + +instance Monoid ConfigExFlags where + mempty = ConfigExFlags { + configCabalVersion = mempty, + configPreferences = mempty + } + mappend a b = ConfigExFlags { + configCabalVersion = combine configCabalVersion, + configPreferences = combine configPreferences + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Fetch command +-- ------------------------------------------------------------ + +data FetchFlags = FetchFlags { +-- fetchOutput :: Flag FilePath, + fetchDeps :: Flag Bool, + fetchDryRun :: Flag Bool, + fetchVerbosity :: Flag Verbosity + } + +defaultFetchFlags :: FetchFlags +defaultFetchFlags = FetchFlags { +-- fetchOutput = mempty, + fetchDeps = toFlag True, + fetchDryRun = toFlag False, + fetchVerbosity = toFlag normal + } + +fetchCommand :: CommandUI FetchFlags +fetchCommand = CommandUI { + commandName = "fetch", + commandSynopsis = "Downloads packages for later installation.", + commandDescription = Nothing, + commandUsage = usagePackages "fetch", + commandDefaultFlags = defaultFetchFlags, + commandOptions = \_ -> [ + optionVerbosity fetchVerbosity (\v flags -> flags { fetchVerbosity = v }) + +-- , option "o" ["output"] +-- "Put the package(s) somewhere specific rather than the usual cache." +-- fetchOutput (\v flags -> flags { fetchOutput = v }) +-- (reqArgFlag "PATH") + + , option [] ["dependencies", "deps"] + "Resolve and fetch dependencies (default)" + fetchDeps (\v flags -> flags { fetchDeps = v }) + trueArg + + , option [] ["no-dependencies", "no-deps"] + "Ignore dependencies" + fetchDeps (\v flags -> flags { fetchDeps = v }) + falseArg + + , option [] ["dry-run"] + "Do not install anything, only print what would be installed." + fetchDryRun (\v flags -> flags { fetchDryRun = v }) + trueArg + ] + } + +-- ------------------------------------------------------------ +-- * Other commands +-- ------------------------------------------------------------ + +updateCommand :: CommandUI (Flag Verbosity) +updateCommand = CommandUI { + commandName = "update", + commandSynopsis = "Updates list of known packages", + commandDescription = Nothing, + commandUsage = usagePackages "update", + commandDefaultFlags = toFlag normal, + commandOptions = \_ -> [optionVerbosity id const] + } + +upgradeCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags) +upgradeCommand = configureCommand { + commandName = "upgrade", + commandSynopsis = "(command disabled, use install instead)", + commandDescription = Nothing, + commandUsage = usagePackages "upgrade", + commandDefaultFlags = (mempty, mempty, mempty), + commandOptions = commandOptions installCommand + } + +{- +cleanCommand :: CommandUI () +cleanCommand = makeCommand name shortDesc longDesc emptyFlags options + where + name = "clean" + shortDesc = "Removes downloaded files" + longDesc = Nothing + emptyFlags = () + options _ = [] +-} + +checkCommand :: CommandUI (Flag Verbosity) +checkCommand = CommandUI { + commandName = "check", + commandSynopsis = "Check the package for common mistakes", + commandDescription = Nothing, + commandUsage = \pname -> "Usage: " ++ pname ++ " check\n", + commandDefaultFlags = toFlag normal, + commandOptions = \_ -> [] + } + +-- ------------------------------------------------------------ +-- * Report flags +-- ------------------------------------------------------------ + +data ReportFlags = ReportFlags { + reportUsername :: Flag Username, + reportPassword :: Flag Password, + reportVerbosity :: Flag Verbosity + } + +defaultReportFlags :: ReportFlags +defaultReportFlags = ReportFlags { + reportUsername = mempty, + reportPassword = mempty, + reportVerbosity = toFlag normal + } + +reportCommand :: CommandUI ReportFlags +reportCommand = CommandUI { + commandName = "report", + commandSynopsis = "Upload build reports to a remote server.", + commandDescription = Just $ \_ -> + "You can store your Hackage login in the ~/.cabal/config file\n", + commandUsage = \pname -> "Usage: " ++ pname ++ " report [FLAGS]\n\n" + ++ "Flags for upload:", + commandDefaultFlags = defaultReportFlags, + commandOptions = \_ -> + [optionVerbosity reportVerbosity (\v flags -> flags { reportVerbosity = v }) + + ,option ['u'] ["username"] + "Hackage username." + reportUsername (\v flags -> flags { reportUsername = v }) + (reqArg' "USERNAME" (toFlag . Username) + (flagToList . fmap unUsername)) + + ,option ['p'] ["password"] + "Hackage password." + reportPassword (\v flags -> flags { reportPassword = v }) + (reqArg' "PASSWORD" (toFlag . Password) + (flagToList . fmap unPassword)) + ] + } + +instance Monoid ReportFlags where + mempty = ReportFlags { + reportUsername = mempty, + reportPassword = mempty, + reportVerbosity = mempty + } + mappend a b = ReportFlags { + reportUsername = combine reportUsername, + reportPassword = combine reportPassword, + reportVerbosity = combine reportVerbosity + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Unpack flags +-- ------------------------------------------------------------ + +data UnpackFlags = UnpackFlags { + unpackDestDir :: Flag FilePath, + unpackVerbosity :: Flag Verbosity + } + +defaultUnpackFlags :: UnpackFlags +defaultUnpackFlags = UnpackFlags { + unpackDestDir = mempty, + unpackVerbosity = toFlag normal + } + +unpackCommand :: CommandUI UnpackFlags +unpackCommand = CommandUI { + commandName = "unpack", + commandSynopsis = "Unpacks packages for user inspection.", + commandDescription = Nothing, + commandUsage = usagePackages "unpack", + commandDefaultFlags = mempty, + commandOptions = \_ -> [ + optionVerbosity unpackVerbosity (\v flags -> flags { unpackVerbosity = v }) + + ,option "d" ["destdir"] + "where to unpack the packages, defaults to the current directory." + unpackDestDir (\v flags -> flags { unpackDestDir = v }) + (reqArgFlag "PATH") + ] + } + +instance Monoid UnpackFlags where + mempty = defaultUnpackFlags + mappend a b = UnpackFlags { + unpackDestDir = combine unpackDestDir + ,unpackVerbosity = combine unpackVerbosity + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * List flags +-- ------------------------------------------------------------ + +data ListFlags = ListFlags { + listInstalled :: Flag Bool, + listSimpleOutput :: Flag Bool, + listVerbosity :: Flag Verbosity + } + +defaultListFlags :: ListFlags +defaultListFlags = ListFlags { + listInstalled = Flag False, + listSimpleOutput = Flag False, + listVerbosity = toFlag normal + } + +listCommand :: CommandUI ListFlags +listCommand = CommandUI { + commandName = "list", + commandSynopsis = "List packages matching a search string.", + commandDescription = Nothing, + commandUsage = usagePackages "list", + commandDefaultFlags = defaultListFlags, + commandOptions = \_ -> [ + optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v }) + + , option [] ["installed"] + "Only print installed packages" + listInstalled (\v flags -> flags { listInstalled = v }) + trueArg + + , option [] ["simple-output"] + "Print in a easy-to-parse format" + listSimpleOutput (\v flags -> flags { listSimpleOutput = v }) + trueArg + + ] + } + +instance Monoid ListFlags where + mempty = defaultListFlags + mappend a b = ListFlags { + listInstalled = combine listInstalled, + listSimpleOutput = combine listSimpleOutput, + listVerbosity = combine listVerbosity + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Info flags +-- ------------------------------------------------------------ + +data InfoFlags = InfoFlags { + infoVerbosity :: Flag Verbosity + } + +defaultInfoFlags :: InfoFlags +defaultInfoFlags = InfoFlags { + infoVerbosity = toFlag normal + } + +infoCommand :: CommandUI InfoFlags +infoCommand = CommandUI { + commandName = "info", + commandSynopsis = "Display detailed information about a particular package.", + commandDescription = Nothing, + commandUsage = usagePackages "info", + commandDefaultFlags = defaultInfoFlags, + commandOptions = \_ -> [ + optionVerbosity infoVerbosity (\v flags -> flags { infoVerbosity = v }) + ] + } + +instance Monoid InfoFlags where + mempty = defaultInfoFlags + mappend a b = InfoFlags { + infoVerbosity = combine infoVerbosity + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Install flags +-- ------------------------------------------------------------ + +-- | Install takes the same flags as configure along with a few extras. +-- +data InstallFlags = InstallFlags { + installDocumentation:: Flag Bool, + installHaddockIndex :: Flag PathTemplate, + installDryRun :: Flag Bool, + installReinstall :: Flag Bool, + installUpgradeDeps :: Flag Bool, + installOnly :: Flag Bool, + installOnlyDeps :: Flag Bool, + installRootCmd :: Flag String, + installSummaryFile :: [PathTemplate], + installLogFile :: Flag PathTemplate, + installBuildReports :: Flag ReportLevel, + installSymlinkBinDir:: Flag FilePath, + installOneShot :: Flag Bool + } + +defaultInstallFlags :: InstallFlags +defaultInstallFlags = InstallFlags { + installDocumentation= Flag False, + installHaddockIndex = Flag docIndexFile, + installDryRun = Flag False, + installReinstall = Flag False, + installUpgradeDeps = Flag False, + installOnly = Flag False, + installOnlyDeps = Flag False, + installRootCmd = mempty, + installSummaryFile = mempty, + installLogFile = mempty, + installBuildReports = Flag NoReports, + installSymlinkBinDir= mempty, + installOneShot = Flag False + } + where + docIndexFile = toPathTemplate ("$datadir" "doc" "index.html") + +installCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags) +installCommand = CommandUI { + commandName = "install", + commandSynopsis = "Installs a list of packages.", + commandUsage = usagePackages "install", + commandDescription = Just $ \pname -> + let original = case commandDescription configureCommand of + Just desc -> desc pname ++ "\n" + Nothing -> "" + in original + ++ "Examples:\n" + ++ " " ++ pname ++ " install " + ++ " Package in the current directory\n" + ++ " " ++ pname ++ " install foo " + ++ " Package from the hackage server\n" + ++ " " ++ pname ++ " install foo-1.0 " + ++ " Specific version of a package\n" + ++ " " ++ pname ++ " install 'foo < 2' " + ++ " Constrained package version\n", + commandDefaultFlags = (mempty, mempty, mempty), + commandOptions = \showOrParseArgs -> + liftOptions get1 set1 (configureOptions showOrParseArgs) + ++ liftOptions get2 set2 (configureExOptions showOrParseArgs) + ++ liftOptions get3 set3 (installOptions showOrParseArgs) + } + where + get1 (a,_,_) = a; set1 a (_,b,c) = (a,b,c) + get2 (_,b,_) = b; set2 b (a,_,c) = (a,b,c) + get3 (_,_,c) = c; set3 c (a,b,_) = (a,b,c) + +installOptions :: ShowOrParseArgs -> [OptionField InstallFlags] +installOptions showOrParseArgs = + [ option "" ["documentation"] + "building of documentation" + installDocumentation (\v flags -> flags { installDocumentation = v }) + (boolOpt [] []) + + , option [] ["doc-index-file"] + "A central index of haddock API documentation (template cannot use $pkgid)" + installHaddockIndex (\v flags -> flags { installHaddockIndex = v }) + (reqArg' "TEMPLATE" (toFlag.toPathTemplate) + (flagToList . fmap fromPathTemplate)) + + , option [] ["dry-run"] + "Do not install anything, only print what would be installed." + installDryRun (\v flags -> flags { installDryRun = v }) + trueArg + + , option [] ["reinstall"] + "Install even if it means installing the same version again." + installReinstall (\v flags -> flags { installReinstall = v }) + trueArg + + , option [] ["upgrade-dependencies"] + "Pick the latest version for all dependencies, rather than trying to pick an installed version." + installUpgradeDeps (\v flags -> flags { installUpgradeDeps = v }) + trueArg + + + , option [] ["only-dependencies"] + "Install only the dependencies necessary to build the given packages" + installOnlyDeps (\v flags -> flags { installOnlyDeps = v }) + trueArg + + + , option [] ["root-cmd"] + "Command used to gain root privileges, when installing with --global." + installRootCmd (\v flags -> flags { installRootCmd = v }) + (reqArg' "COMMAND" toFlag flagToList) + + , option [] ["symlink-bindir"] + "Add symlinks to installed executables into this directory." + installSymlinkBinDir (\v flags -> flags { installSymlinkBinDir = v }) + (reqArgFlag "DIR") + + , option [] ["build-summary"] + "Save build summaries to file (name template can use $pkgid, $compiler, $os, $arch)" + installSummaryFile (\v flags -> flags { installSummaryFile = v }) + (reqArg' "TEMPLATE" (\x -> [toPathTemplate x]) (map fromPathTemplate)) + + , option [] ["build-log"] + "Log all builds to file (name template can use $pkgid, $compiler, $os, $arch)" + installLogFile (\v flags -> flags { installLogFile = v }) + (reqArg' "TEMPLATE" (toFlag.toPathTemplate) + (flagToList . fmap fromPathTemplate)) + + , option [] ["remote-build-reporting"] + "Generate build reports to send to a remote server (none, anonymous or detailed)." + installBuildReports (\v flags -> flags { installBuildReports = v }) + (reqArg "LEVEL" (readP_to_E (const $ "report level must be 'none', " + ++ "'anonymous' or 'detailed'") + (toFlag `fmap` parse)) + (flagToList . fmap display)) + + , option [] ["one-shot"] + "Do not record the packages in the world file." + installOneShot (\v flags -> flags { installOneShot = v }) + trueArg + ] ++ case showOrParseArgs of -- TODO: remove when "cabal install" avoids + ParseArgs -> + option [] ["only"] + "Only installs the package in the current directory." + installOnly (\v flags -> flags { installOnly = v }) + trueArg + : [] + _ -> [] + +instance Monoid InstallFlags where + mempty = InstallFlags { + installDocumentation= mempty, + installHaddockIndex = mempty, + installDryRun = mempty, + installReinstall = mempty, + installUpgradeDeps = mempty, + installOnly = mempty, + installOnlyDeps = mempty, + installRootCmd = mempty, + installSummaryFile = mempty, + installLogFile = mempty, + installBuildReports = mempty, + installSymlinkBinDir= mempty, + installOneShot = mempty + } + mappend a b = InstallFlags { + installDocumentation= combine installDocumentation, + installHaddockIndex = combine installHaddockIndex, + installDryRun = combine installDryRun, + installReinstall = combine installReinstall, + installUpgradeDeps = combine installUpgradeDeps, + installOnly = combine installOnly, + installOnlyDeps = combine installOnlyDeps, + installRootCmd = combine installRootCmd, + installSummaryFile = combine installSummaryFile, + installLogFile = combine installLogFile, + installBuildReports = combine installBuildReports, + installSymlinkBinDir= combine installSymlinkBinDir, + installOneShot = combine installOneShot + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Upload flags +-- ------------------------------------------------------------ + +data UploadFlags = UploadFlags { + uploadCheck :: Flag Bool, + uploadUsername :: Flag Username, + uploadPassword :: Flag Password, + uploadVerbosity :: Flag Verbosity + } + +defaultUploadFlags :: UploadFlags +defaultUploadFlags = UploadFlags { + uploadCheck = toFlag False, + uploadUsername = mempty, + uploadPassword = mempty, + uploadVerbosity = toFlag normal + } + +uploadCommand :: CommandUI UploadFlags +uploadCommand = CommandUI { + commandName = "upload", + commandSynopsis = "Uploads source packages to Hackage", + commandDescription = Just $ \_ -> + "You can store your Hackage login in the ~/.cabal/config file\n", + commandUsage = \pname -> + "Usage: " ++ pname ++ " upload [FLAGS] [TARFILES]\n\n" + ++ "Flags for upload:", + commandDefaultFlags = defaultUploadFlags, + commandOptions = \_ -> + [optionVerbosity uploadVerbosity (\v flags -> flags { uploadVerbosity = v }) + + ,option ['c'] ["check"] + "Do not upload, just do QA checks." + uploadCheck (\v flags -> flags { uploadCheck = v }) + trueArg + + ,option ['u'] ["username"] + "Hackage username." + uploadUsername (\v flags -> flags { uploadUsername = v }) + (reqArg' "USERNAME" (toFlag . Username) + (flagToList . fmap unUsername)) + + ,option ['p'] ["password"] + "Hackage password." + uploadPassword (\v flags -> flags { uploadPassword = v }) + (reqArg' "PASSWORD" (toFlag . Password) + (flagToList . fmap unPassword)) + ] + } + +instance Monoid UploadFlags where + mempty = UploadFlags { + uploadCheck = mempty, + uploadUsername = mempty, + uploadPassword = mempty, + uploadVerbosity = mempty + } + mappend a b = UploadFlags { + uploadCheck = combine uploadCheck, + uploadUsername = combine uploadUsername, + uploadPassword = combine uploadPassword, + uploadVerbosity = combine uploadVerbosity + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Init flags +-- ------------------------------------------------------------ + +emptyInitFlags :: IT.InitFlags +emptyInitFlags = mempty + +defaultInitFlags :: IT.InitFlags +defaultInitFlags = emptyInitFlags + +initCommand :: CommandUI IT.InitFlags +initCommand = CommandUI { + commandName = "init", + commandSynopsis = "Interactively create a .cabal file.", + commandDescription = Just $ \_ -> wrapText $ + "Cabalise a project by creating a .cabal, Setup.hs, and " + ++ "optionally a LICENSE file.\n\n" + ++ "Calling init with no arguments (recommended) uses an " + ++ "interactive mode, which will try to guess as much as " + ++ "possible and prompt you for the rest. Command-line " + ++ "arguments are provided for scripting purposes. " + ++ "If you don't want interactive mode, be sure to pass " + ++ "the -n flag.\n", + commandUsage = \pname -> + "Usage: " ++ pname ++ " init [FLAGS]\n\n" + ++ "Flags for init:", + commandDefaultFlags = defaultInitFlags, + commandOptions = \_ -> + [ option ['n'] ["non-interactive"] + "Non-interactive mode." + IT.nonInteractive (\v flags -> flags { IT.nonInteractive = v }) + trueArg + + , option ['q'] ["quiet"] + "Do not generate log messages to stdout." + IT.quiet (\v flags -> flags { IT.quiet = v }) + trueArg + + , option [] ["no-comments"] + "Do not generate explanatory comments in the .cabal file." + IT.noComments (\v flags -> flags { IT.noComments = v }) + trueArg + + , option ['m'] ["minimal"] + "Generate a minimal .cabal file, that is, do not include extra empty fields. Also implies --no-comments." + IT.minimal (\v flags -> flags { IT.minimal = v }) + trueArg + + , option [] ["package-dir"] + "Root directory of the package (default = current directory)." + IT.packageDir (\v flags -> flags { IT.packageDir = v }) + (reqArgFlag "DIRECTORY") + + , option ['p'] ["package-name"] + "Name of the Cabal package to create." + IT.packageName (\v flags -> flags { IT.packageName = v }) + (reqArgFlag "PACKAGE") + + , option [] ["version"] + "Initial version of the package." + IT.version (\v flags -> flags { IT.version = v }) + (reqArg "VERSION" (readP_to_E ("Cannot parse package version: "++) + (toFlag `fmap` parse)) + (flagToList . fmap display)) + + , option [] ["cabal-version"] + "Required version of the Cabal library." + IT.cabalVersion (\v flags -> flags { IT.cabalVersion = v }) + (reqArg "VERSION_RANGE" (readP_to_E ("Cannot parse Cabal version range: "++) + (toFlag `fmap` parse)) + (flagToList . fmap display)) + + , option ['l'] ["license"] + "Project license." + IT.license (\v flags -> flags { IT.license = v }) + (reqArg "LICENSE" (readP_to_E ("Cannot parse license: "++) + (toFlag `fmap` parse)) + (flagToList . fmap display)) + + , option ['a'] ["author"] + "Name of the project's author." + IT.author (\v flags -> flags { IT.author = v }) + (reqArgFlag "NAME") + + , option ['e'] ["email"] + "Email address of the maintainer." + IT.email (\v flags -> flags { IT.email = v }) + (reqArgFlag "EMAIL") + + , option ['u'] ["homepage"] + "Project homepage and/or repository." + IT.homepage (\v flags -> flags { IT.homepage = v }) + (reqArgFlag "URL") + + , option ['s'] ["synopsis"] + "Short project synopsis." + IT.synopsis (\v flags -> flags { IT.synopsis = v }) + (reqArgFlag "TEXT") + + , option ['c'] ["category"] + "Project category." + IT.category (\v flags -> flags { IT.category = v }) + (reqArg' "CATEGORY" (\s -> toFlag $ maybe (Left s) Right (readMaybe s)) + (flagToList . fmap (either id show))) + + , option [] ["is-library"] + "Build a library." + IT.packageType (\v flags -> flags { IT.packageType = v }) + (noArg (Flag IT.Library)) + + , option [] ["is-executable"] + "Build an executable." + IT.packageType + (\v flags -> flags { IT.packageType = v }) + (noArg (Flag IT.Executable)) + + , 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))) + + , 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))) + + , option [] ["source-dir"] + "Directory containing package source." + IT.sourceDirs (\v flags -> flags { IT.sourceDirs = v }) + (reqArg' "DIR" (Just . (:[])) + (fromMaybe [])) + + , option [] ["build-tool"] + "Required external build tool." + IT.buildTools (\v flags -> flags { IT.buildTools = v }) + (reqArg' "TOOL" (Just . (:[])) + (fromMaybe [])) + ] + } + where readMaybe s = case reads s of + [(x,"")] -> Just x + _ -> Nothing + +-- ------------------------------------------------------------ +-- * GetOpt Utils +-- ------------------------------------------------------------ + +boolOpt :: SFlags -> SFlags -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a +boolOpt = Command.boolOpt flagToMaybe Flag + +reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description -> + (b -> Flag String) -> (Flag String -> b -> b) -> OptDescr b +reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList + +liftOptions :: (b -> a) -> (a -> b -> b) + -> [OptionField a] -> [OptionField b] +liftOptions get set = map (liftOption get set) + +usagePackages :: String -> String -> String +usagePackages name pname = + "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n" + ++ " or: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n\n" + ++ "Flags for " ++ name ++ ":" + +--TODO: do we want to allow per-package flags? +parsePackageArgs :: [String] -> Either String [Dependency] +parsePackageArgs = parsePkgArgs [] + where + parsePkgArgs ds [] = Right (reverse ds) + parsePkgArgs ds (arg:args) = + case readPToMaybe parseDependencyOrPackageId arg of + Just dep -> parsePkgArgs (dep:ds) args + Nothing -> Left $ + show arg ++ " is not valid syntax for a package name or" + ++ " package dependency." + +readPToMaybe :: Parse.ReadP a a -> String -> Maybe a +readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str + , all isSpace s ] + +parseDependencyOrPackageId :: Parse.ReadP r Dependency +parseDependencyOrPackageId = parse Parse.+++ liftM pkgidToDependency parse + where + pkgidToDependency :: PackageIdentifier -> Dependency + pkgidToDependency p = case packageVersion p of + Version [] _ -> Dependency (packageName p) anyVersion + version -> Dependency (packageName p) (thisVersion version) + +showRepo :: RemoteRepo -> String +showRepo repo = remoteRepoName repo ++ ":" + ++ uriToString id (remoteRepoURI repo) [] + +readRepo :: String -> Maybe RemoteRepo +readRepo = readPToMaybe parseRepo + +parseRepo :: Parse.ReadP r RemoteRepo +parseRepo = do + name <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "_-.") + _ <- Parse.char ':' + uriStr <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "+-=._/*()@'$:;&!?~") + uri <- maybe Parse.pfail return (parseAbsoluteURI uriStr) + return $ RemoteRepo { + remoteRepoName = name, + remoteRepoURI = uri + } diff --git a/Distribution/Client/SetupWrapper.hs b/Distribution/Client/SetupWrapper.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/SetupWrapper.hs @@ -0,0 +1,320 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.SetupWrapper +-- Copyright : (c) The University of Glasgow 2006, +-- Duncan Coutts 2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : alpha +-- Portability : portable +-- +-- An interface to building and installing Cabal packages. +-- If the @Built-Type@ field is specified as something other than +-- 'Custom', and the current version of Cabal is acceptable, this performs +-- setup actions directly. Otherwise it builds the setup script and +-- runs it with the given arguments. + +module Distribution.Client.SetupWrapper ( + setupWrapper, + SetupScriptOptions(..), + defaultSetupScriptOptions, + ) where + +import Distribution.Client.Types + ( InstalledPackage ) + +import qualified Distribution.Make as Make +import qualified Distribution.Simple as Simple +import Distribution.Version + ( Version(..), VersionRange, anyVersion + , intersectVersionRanges, orLaterVersion + , withinRange ) +import Distribution.Package + ( PackageIdentifier(..), PackageName(..), Package(..), packageName + , packageVersion, Dependency(..) ) +import Distribution.PackageDescription + ( GenericPackageDescription(packageDescription) + , PackageDescription(..), specVersion, BuildType(..) ) +import Distribution.PackageDescription.Parse + ( readPackageDescription ) +import Distribution.Simple.Configure + ( configCompiler ) +import Distribution.Simple.Compiler + ( CompilerFlavor(GHC), Compiler, PackageDB(..), PackageDBStack ) +import Distribution.Simple.Program + ( ProgramConfiguration, emptyProgramConfiguration + , rawSystemProgramConf, ghcProgram ) +import Distribution.Simple.BuildPaths + ( defaultDistPref, exeExtension ) +import Distribution.Simple.Command + ( CommandUI(..), commandShowOptions ) +import Distribution.Simple.GHC + ( ghcVerbosityOptions ) +import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Client.PackageIndex (PackageIndex) +import Distribution.Client.IndexUtils + ( getInstalledPackages ) +import Distribution.Simple.Utils + ( die, debug, info, cabalVersion, findPackageDesc, comparing + , createDirectoryIfMissingVerbose, rewriteFile ) +import Distribution.Client.Utils + ( moreRecentFile, inDir ) +import Distribution.Text + ( display ) +import Distribution.Verbosity + ( Verbosity ) + +import System.Directory ( doesFileExist, getCurrentDirectory ) +import System.FilePath ( (), (<.>) ) +import System.IO ( Handle ) +import System.Exit ( ExitCode(..), exitWith ) +import System.Process ( runProcess, waitForProcess ) +import Control.Monad ( when, unless ) +import Data.List ( maximumBy ) +import Data.Maybe ( fromMaybe, isJust ) +import Data.Char ( isSpace ) + +data SetupScriptOptions = SetupScriptOptions { + useCabalVersion :: VersionRange, + useCompiler :: Maybe Compiler, + usePackageDB :: PackageDBStack, + usePackageIndex :: Maybe (PackageIndex InstalledPackage), + useProgramConfig :: ProgramConfiguration, + useDistPref :: FilePath, + useLoggingHandle :: Maybe Handle, + useWorkingDir :: Maybe FilePath + } + +defaultSetupScriptOptions :: SetupScriptOptions +defaultSetupScriptOptions = SetupScriptOptions { + useCabalVersion = anyVersion, + useCompiler = Nothing, + usePackageDB = [GlobalPackageDB, UserPackageDB], + usePackageIndex = Nothing, + useProgramConfig = emptyProgramConfiguration, + useDistPref = defaultDistPref, + useLoggingHandle = Nothing, + useWorkingDir = Nothing + } + +setupWrapper :: Verbosity + -> SetupScriptOptions + -> Maybe PackageDescription + -> CommandUI flags + -> (Version -> flags) + -> [String] + -> IO () +setupWrapper verbosity options mpkg cmd flags extraArgs = do + pkg <- maybe getPkg return mpkg + let setupMethod = determineSetupMethod options' buildType' + options' = options { + useCabalVersion = intersectVersionRanges + (useCabalVersion options) + (orLaterVersion (specVersion pkg)) + } + buildType' = fromMaybe Custom (buildType pkg) + mkArgs cabalLibVersion = commandName cmd + : commandShowOptions cmd (flags cabalLibVersion) + ++ extraArgs + setupMethod verbosity options' (packageId pkg) buildType' mkArgs + where + getPkg = findPackageDesc (fromMaybe "." (useWorkingDir options)) + >>= readPackageDescription verbosity + >>= return . packageDescription + +-- | Decide if we're going to be able to do a direct internal call to the +-- entry point in the Cabal library or if we're going to have to compile +-- and execute an external Setup.hs script. +-- +determineSetupMethod :: SetupScriptOptions -> BuildType -> SetupMethod +determineSetupMethod options buildType' + | isJust (useLoggingHandle options) + || buildType' == Custom = externalSetupMethod + | cabalVersion `withinRange` + useCabalVersion options = internalSetupMethod + | otherwise = externalSetupMethod + +type SetupMethod = Verbosity + -> SetupScriptOptions + -> PackageIdentifier + -> BuildType + -> (Version -> [String]) -> IO () + +-- ------------------------------------------------------------ +-- * Internal SetupMethod +-- ------------------------------------------------------------ + +internalSetupMethod :: SetupMethod +internalSetupMethod verbosity options _ bt mkargs = do + let args = mkargs cabalVersion + debug verbosity $ "Using internal setup method with build-type " ++ show bt + ++ " and args:\n " ++ show args + inDir (useWorkingDir options) $ + buildTypeAction bt args + +buildTypeAction :: BuildType -> ([String] -> IO ()) +buildTypeAction Simple = Simple.defaultMainArgs +buildTypeAction Configure = Simple.defaultMainWithHooksArgs + Simple.autoconfUserHooks +buildTypeAction Make = Make.defaultMainArgs +buildTypeAction Custom = error "buildTypeAction Custom" +buildTypeAction (UnknownBuildType _) = error "buildTypeAction UnknownBuildType" + +-- ------------------------------------------------------------ +-- * External SetupMethod +-- ------------------------------------------------------------ + +externalSetupMethod :: SetupMethod +externalSetupMethod verbosity options pkg bt mkargs = do + debug verbosity $ "Using external setup method with build-type " ++ show bt + createDirectoryIfMissingVerbose verbosity True setupDir + (cabalLibVersion, options') <- cabalLibVersionToUse + debug verbosity $ "Using Cabal library version " ++ display cabalLibVersion + setupHs <- updateSetupScript cabalLibVersion bt + debug verbosity $ "Using " ++ setupHs ++ " as setup script." + compileSetupExecutable options' cabalLibVersion setupHs + invokeSetupScript (mkargs cabalLibVersion) + + where + workingDir = case fromMaybe "" (useWorkingDir options) of + [] -> "." + dir -> dir + setupDir = workingDir useDistPref options "setup" + setupVersionFile = setupDir "setup" <.> "version" + setupProgFile = setupDir "setup" <.> exeExtension + + cabalLibVersionToUse :: IO (Version, SetupScriptOptions) + cabalLibVersionToUse = do + savedVersion <- savedCabalVersion + case savedVersion of + Just version | version `withinRange` useCabalVersion options + -> return (version, options) + _ -> do (comp, conf, options') <- configureCompiler options + version <- installedCabalVersion options comp conf + writeFile setupVersionFile (show version ++ "\n") + return (version, options') + + savedCabalVersion = do + versionString <- readFile setupVersionFile `catch` \_ -> return "" + case reads versionString of + [(version,s)] | all isSpace s -> return (Just version) + _ -> return Nothing + + installedCabalVersion :: SetupScriptOptions -> Compiler + -> ProgramConfiguration -> IO Version + 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) + case PackageIndex.lookupDependency index cabalDep of + [] -> die $ "The package requires Cabal library version " + ++ display (useCabalVersion options) + ++ " but no suitable version is installed." + pkgs -> return $ bestVersion (map packageVersion pkgs) + where + bestVersion = maximumBy (comparing preference) + preference version = (sameVersion, sameMajorVersion + ,stableVersion, latestVersion) + where + sameVersion = version == cabalVersion + sameMajorVersion = majorVersion version == majorVersion cabalVersion + majorVersion = take 2 . versionBranch + stableVersion = case versionBranch version of + (_:x:_) -> even x + _ -> False + latestVersion = version + + 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, + useProgramConfig = conf }) + + -- | Decide which Setup.hs script to use, creating it if necessary. + -- + updateSetupScript :: Version -> BuildType -> IO FilePath + updateSetupScript _ Custom = do + useHs <- doesFileExist setupHs + useLhs <- doesFileExist setupLhs + unless (useHs || useLhs) $ die + "Using 'build-type: Custom' but there is no Setup.hs or Setup.lhs script." + return (if useHs then setupHs else setupLhs) + where + setupHs = workingDir "Setup.hs" + setupLhs = workingDir "Setup.lhs" + + updateSetupScript cabalLibVersion _ = do + rewriteFile setupHs (buildTypeScript cabalLibVersion) + return setupHs + where + setupHs = setupDir "setup.hs" + + buildTypeScript :: Version -> String + buildTypeScript cabalLibVersion = case bt of + Simple -> "import Distribution.Simple; main = defaultMain\n" + Configure -> "import Distribution.Simple; main = defaultMainWithHooks " + ++ if cabalLibVersion >= Version [1,3,10] [] + then "autoconfUserHooks\n" + else "defaultUserHooks\n" + Make -> "import Distribution.Make; main = defaultMain\n" + Custom -> error "buildTypeScript Custom" + UnknownBuildType _ -> error "buildTypeScript UnknownBuildType" + + -- | 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 -> IO () + compileSetupExecutable options' cabalLibVersion setupHsFile = 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..." + (_, conf, _) <- configureCompiler options' + --TODO: get Cabal's GHC module to export a GhcOptions type and render func + rawSystemProgramConf verbosity ghcProgram conf $ + ghcVerbosityOptions verbosity + ++ ["--make", setupHsFile, "-o", setupProgFile + ,"-odir", setupDir, "-hidir", setupDir + ,"-i", "-i" ++ workingDir ] + ++ ghcPackageDbOptions (usePackageDB options') + ++ if packageName pkg == PackageName "Cabal" + then [] + else ["-package", display cabalPkgid] + where + cabalPkgid = PackageIdentifier (PackageName "Cabal") cabalLibVersion + + ghcPackageDbOptions :: PackageDBStack -> [String] + ghcPackageDbOptions dbstack = case dbstack of + (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs + (GlobalPackageDB:dbs) -> "-no-user-package-conf" + : concatMap specific dbs + _ -> ierror + where + specific (SpecificPackageDB db) = [ "-package-conf", db ] + specific _ = ierror + ierror = error "internal error: unexpected package db stack" + + + invokeSetupScript :: [String] -> IO () + invokeSetupScript args = do + info verbosity $ unwords (setupProgFile : args) + case useLoggingHandle options of + Nothing -> return () + Just logHandle -> info verbosity $ "Redirecting build log to " + ++ show logHandle + currentDir <- getCurrentDirectory + process <- runProcess (currentDir setupProgFile) args + (useWorkingDir options) Nothing + 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 new file mode 100644 --- /dev/null +++ b/Distribution/Client/SrcDist.hs @@ -0,0 +1,80 @@ +-- Implements the \"@.\/cabal sdist@\" command, which creates a source +-- distribution for this package. That is, packs up the source code +-- into a tarball, making use of the corresponding Cabal module. +module Distribution.Client.SrcDist ( + sdist + ) where +import Distribution.Simple.SrcDist + ( printPackageProblems, prepareTree + , prepareSnapshotTree, snapshotPackage ) +import Distribution.Client.Tar (createTarGzFile) + +import Distribution.Package + ( Package(..) ) +import Distribution.PackageDescription + ( PackageDescription ) +import Distribution.PackageDescription.Parse + ( readPackageDescription ) +import Distribution.Simple.Utils + ( defaultPackageDesc, warn, notice, setupMessage + , createDirectoryIfMissingVerbose, withTempDirectory ) +import Distribution.Simple.Setup (SDistFlags(..), fromFlag) +import Distribution.Verbosity (Verbosity) +import Distribution.Simple.PreProcess (knownSuffixHandlers) +import Distribution.Simple.BuildPaths ( srcPref) +import Distribution.Simple.Configure(maybeGetPersistBuildConfig) +import Distribution.PackageDescription.Configuration ( flattenPackageDescription ) +import Distribution.Text + ( display ) + +import System.Time (getClockTime, toCalendarTime) +import System.FilePath ((), (<.>)) +import Control.Monad (when) +import Data.Maybe (isNothing) + +-- |Create a source distribution. +sdist :: SDistFlags -> IO () +sdist flags = do + pkg <- return . flattenPackageDescription + =<< readPackageDescription verbosity + =<< defaultPackageDesc verbosity + mb_lbi <- maybeGetPersistBuildConfig distPref + let tmpTargetDir = srcPref distPref + + -- do some QA + printPackageProblems verbosity pkg + + when (isNothing mb_lbi) $ + warn verbosity "Cannot run preprocessors. Run 'configure' command first." + + createDirectoryIfMissingVerbose verbosity True tmpTargetDir + withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do + + date <- toCalendarTime =<< getClockTime + let pkg' | snapshot = snapshotPackage date pkg + | otherwise = pkg + setupMessage verbosity "Building source dist for" (packageId pkg') + + _ <- if snapshot + then prepareSnapshotTree verbosity pkg' mb_lbi distPref tmpDir pps + else prepareTree verbosity pkg' mb_lbi distPref tmpDir pps + targzFile <- createArchive verbosity pkg' tmpDir distPref + notice verbosity $ "Source tarball created: " ++ targzFile + + where + verbosity = fromFlag (sDistVerbosity flags) + snapshot = fromFlag (sDistSnapshot flags) + distPref = fromFlag (sDistDistPref flags) + pps = knownSuffixHandlers + +-- |Create an archive from a tree of source files, and clean up the tree. +createArchive :: Verbosity + -> PackageDescription + -> FilePath + -> FilePath + -> IO FilePath +createArchive _verbosity pkg tmpDir targetPref = do + let tarBallName = display (packageId pkg) + tarBallFilePath = targetPref tarBallName <.> "tar.gz" + createTarGzFile tarBallFilePath tmpDir tarBallName + return tarBallFilePath diff --git a/Distribution/Client/Tar.hs b/Distribution/Client/Tar.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Tar.hs @@ -0,0 +1,903 @@ +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Tar +-- Copyright : (c) 2007 Bjorn Bringert, +-- 2008 Andrea Vezzosi, +-- 2008-2009 Duncan Coutts +-- License : BSD3 +-- +-- Maintainer : duncan@community.haskell.org +-- Portability : portable +-- +-- Reading, writing and manipulating \"@.tar@\" archive files. +-- +----------------------------------------------------------------------------- +module Distribution.Client.Tar ( + -- * High level \"all in one\" operations + createTarGzFile, + extractTarGzFile, + + -- * Converting between internal and external representation + read, + write, + + -- * Packing and unpacking files to\/from internal representation + pack, + unpack, + + -- * Tar entry and associated types + Entry(..), + entryPath, + EntryContent(..), + Ownership(..), + FileSize, + Permissions, + EpochTime, + DevMajor, + DevMinor, + TypeCode, + Format(..), + + -- * Constructing simple entry values + simpleEntry, + fileEntry, + directoryEntry, + + -- * TarPath type + TarPath, + toTarPath, + fromTarPath, + + -- ** Sequences of tar entries + Entries(..), + foldrEntries, + foldlEntries, + unfoldrEntries, + mapEntries, + filterEntries, + entriesIndex, + + ) where + +import Data.Char (ord) +import Data.Int (Int64) +import Data.Bits (Bits, shiftL, testBit) +import Data.List (foldl') +import Numeric (readOct, showOct) +import Control.Monad (MonadPlus(mplus), when) +import qualified Data.Map as Map +import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString.Lazy.Char8 as BS.Char8 +import Data.ByteString.Lazy (ByteString) +import qualified Codec.Compression.GZip as GZip +import qualified Distribution.Client.GZipUtils as GZipUtils + +import System.FilePath + ( () ) +import qualified System.FilePath as FilePath.Native +import qualified System.FilePath.Windows as FilePath.Windows +import qualified System.FilePath.Posix as FilePath.Posix +import System.Directory + ( getDirectoryContents, doesDirectoryExist, getModificationTime + , getPermissions, createDirectoryIfMissing, copyFile ) +import qualified System.Directory as Permissions + ( Permissions(executable) ) +import Distribution.Compat.FilePerms + ( setFileExecutable ) +import System.Posix.Types + ( FileMode ) +import System.Time + ( ClockTime(..) ) +import System.IO + ( IOMode(ReadMode), openBinaryFile, hFileSize ) +import System.IO.Unsafe (unsafeInterleaveIO) + +import Prelude hiding (read) + + +-- +-- * High level operations +-- + +createTarGzFile :: FilePath -- ^ Full Tarball path + -> FilePath -- ^ Base directory + -> FilePath -- ^ Directory to archive, relative to base dir + -> IO () +createTarGzFile tar base dir = + BS.writeFile tar . GZip.compress . write =<< pack base [dir] + +extractTarGzFile :: FilePath -- ^ Destination directory + -> 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 + +-- +-- * Entry type +-- + +type FileSize = Int64 +-- | The number of seconds since the UNIX epoch +type EpochTime = Int64 +type DevMajor = Int +type DevMinor = Int +type TypeCode = Char +type Permissions = FileMode + +-- | Tar archive entry. +-- +data Entry = Entry { + + -- | The path of the file or directory within the archive. This is in a + -- tar-specific form. Use 'entryPath' to get a native 'FilePath'. + entryTarPath :: !TarPath, + + -- | The real content of the entry. For 'NormalFile' this includes the + -- file data. An entry usually contains a 'NormalFile' or a 'Directory'. + entryContent :: !EntryContent, + + -- | File permissions (Unix style file mode). + entryPermissions :: !Permissions, + + -- | The user and group to which this file belongs. + entryOwnership :: !Ownership, + + -- | The time the file was last modified. + entryTime :: !EpochTime, + + -- | The tar format the archive is using. + entryFormat :: !Format + } + +-- | Native 'FilePath' of the file or directory within the archive. +-- +entryPath :: Entry -> FilePath +entryPath = fromTarPath . entryTarPath + +-- | The content of a tar archive entry, which depends on the type of entry. +-- +-- Portable archives should contain only 'NormalFile' and 'Directory'. +-- +data EntryContent = NormalFile ByteString !FileSize + | Directory + | SymbolicLink !LinkTarget + | HardLink !LinkTarget + | CharacterDevice !DevMajor !DevMinor + | BlockDevice !DevMajor !DevMinor + | NamedPipe + | OtherEntryType !TypeCode ByteString !FileSize + +data Ownership = Ownership { + -- | The owner user name. Should be set to @\"\"@ if unknown. + ownerName :: String, + + -- | The owner group name. Should be set to @\"\"@ if unknown. + groupName :: String, + + -- | Numeric owner user id. Should be set to @0@ if unknown. + ownerId :: !Int, + + -- | Numeric owner group id. Should be set to @0@ if unknown. + groupId :: !Int + } + +-- | There have been a number of extensions to the tar file format over the +-- years. They all share the basic entry fields and put more meta-data in +-- different extended headers. +-- +data Format = + + -- | This is the classic Unix V7 tar format. It does not support owner and + -- group names, just numeric Ids. It also does not support device numbers. + V7Format + + -- | The \"USTAR\" format is an extension of the classic V7 format. It was + -- later standardised by POSIX. It has some restructions but is the most + -- portable format. + -- + | UstarFormat + + -- | The GNU tar implementation also extends the classic V7 format, though + -- in a slightly different way from the USTAR format. In general for new + -- archives the standard USTAR/POSIX should be used. + -- + | GnuFormat + deriving Eq + +-- | @rw-r--r--@ for normal files +ordinaryFilePermissions :: Permissions +ordinaryFilePermissions = 0o0644 + +-- | @rwxr-xr-x@ for executable files +executableFilePermissions :: Permissions +executableFilePermissions = 0o0755 + +-- | @rwxr-xr-x@ for directories +directoryPermissions :: Permissions +directoryPermissions = 0o0755 + +isExecutable :: Permissions -> Bool +isExecutable p = testBit p 0 || testBit p 6 -- user or other exectuable + +-- | An 'Entry' with all default values except for the file name and type. It +-- uses the portable USTAR/POSIX format (see 'UstarHeader'). +-- +-- You can use this as a basis and override specific fields, eg: +-- +-- > (emptyEntry name HardLink) { linkTarget = target } +-- +simpleEntry :: TarPath -> EntryContent -> Entry +simpleEntry tarpath content = Entry { + entryTarPath = tarpath, + entryContent = content, + entryPermissions = case content of + Directory -> directoryPermissions + _ -> ordinaryFilePermissions, + entryOwnership = Ownership "" "" 0 0, + entryTime = 0, + entryFormat = UstarFormat + } + +-- | A tar 'Entry' for a file. +-- +-- Entry fields such as file permissions and ownership have default values. +-- +-- You can use this as a basis and override specific fields. For example if you +-- need an executable file you could use: +-- +-- > (fileEntry name content) { fileMode = executableFileMode } +-- +fileEntry :: TarPath -> ByteString -> Entry +fileEntry name fileContent = + simpleEntry name (NormalFile fileContent (BS.length fileContent)) + +-- | A tar 'Entry' for a directory. +-- +-- Entry fields such as file permissions and ownership have default values. +-- +directoryEntry :: TarPath -> Entry +directoryEntry name = simpleEntry name Directory + +-- +-- * Tar paths +-- + +-- | The classic tar format allowed just 100 charcters for the file name. The +-- USTAR format extended this with an extra 155 characters, however it uses a +-- complex method of splitting the name between the two sections. +-- +-- Instead of just putting any overflow into the extended area, it uses the +-- extended area as a prefix. The agrevating insane bit however is that the +-- prefix (if any) must only contain a directory prefix. That is the split +-- between the two areas must be on a directory separator boundary. So there is +-- no simple calculation to work out if a file name is too long. Instead we +-- have to try to find a valid split that makes the name fit in the two areas. +-- +-- The rationale presumably was to make it a bit more compatible with old tar +-- programs that only understand the classic format. A classic tar would be +-- able to extract the file name and possibly some dir prefix, but not the +-- full dir prefix. So the files would end up in the wrong place, but that's +-- probably better than ending up with the wrong names too. +-- +-- So it's understandable but rather annoying. +-- +-- * Tar paths use posix format (ie @\'/\'@ directory separators), irrespective +-- of the local path conventions. +-- +-- * The directory separator between the prefix and name is /not/ stored. +-- +data TarPath = TarPath FilePath -- path name, 100 characters max. + FilePath -- path prefix, 155 characters max. + deriving (Eq, Ord) + +-- | Convert a 'TarPath' to a native 'FilePath'. +-- +-- The native 'FilePath' will use the native directory separator but it is not +-- otherwise checked for validity or sanity. In particular: +-- +-- * The tar path may be invalid as a native path, eg the filename @\"nul\"@ is +-- not valid on Windows. +-- +-- * The tar path may be an absolute path or may contain @\"..\"@ components. +-- For security reasons this should not usually be allowed, but it is your +-- responsibility to check for these conditions (eg using 'checkSecurity'). +-- +fromTarPath :: TarPath -> FilePath +fromTarPath (TarPath name prefix) = adjustDirectory $ + FilePath.Native.joinPath $ FilePath.Posix.splitDirectories prefix + ++ FilePath.Posix.splitDirectories name + where + adjustDirectory | FilePath.Posix.hasTrailingPathSeparator name + = FilePath.Native.addTrailingPathSeparator + | otherwise = id + +-- | Convert a native 'FilePath' to a 'TarPath'. +-- +-- The conversion may fail if the 'FilePath' is too long. See 'TarPath' for a +-- description of the problem with splitting long 'FilePath's. +-- +toTarPath :: Bool -- ^ Is the path for a directory? This is needed because for + -- directories a 'TarPath' must always use a trailing @\/@. + -> FilePath -> Either String TarPath +toTarPath isDir = splitLongPath + . addTrailingSep + . FilePath.Posix.joinPath + . FilePath.Native.splitDirectories + where + addTrailingSep | isDir = FilePath.Posix.addTrailingPathSeparator + | otherwise = id + +-- | Take a sanitized path, split on directory separators and try to pack it +-- into the 155 + 100 tar file name format. +-- +-- The stragey is this: take the name-directory components in reverse order +-- and try to fit as many components into the 100 long name area as possible. +-- If all the remaining components fit in the 155 name area then we win. +-- +splitLongPath :: FilePath -> Either String TarPath +splitLongPath path = + case packName nameMax (reverse (FilePath.Posix.splitPath path)) of + Left err -> Left err + 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 (prefix, []) -> Right (TarPath name prefix) + where + -- drop the '/' between the name and prefix: + remainder = init first : rest + + where + nameMax, prefixMax :: Int + nameMax = 100 + prefixMax = 155 + + packName _ [] = Left "File name empty" + packName maxLen (c:cs) + | n > maxLen = Left "File name too long" + | otherwise = Right (packName' maxLen n [c] cs) + where n = length c + + packName' maxLen n ok (c:cs) + | n' <= maxLen = packName' maxLen n' (c:ok) cs + 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 +-- 'HardLink' entry types. +-- +newtype LinkTarget = LinkTarget FilePath + deriving (Eq, Ord) + +-- | Convert a tar 'LinkTarget' to a native 'FilePath'. +-- +fromLinkTarget :: LinkTarget -> FilePath +fromLinkTarget (LinkTarget path) = adjustDirectory $ + FilePath.Native.joinPath $ FilePath.Posix.splitDirectories path + where + adjustDirectory | FilePath.Posix.hasTrailingPathSeparator path + = FilePath.Native.addTrailingPathSeparator + | otherwise = id + +-- +-- * Entries type +-- + +-- | A tar archive is a sequence of entries. +data Entries = Next Entry Entries + | Done + | Fail String + +unfoldrEntries :: (a -> Either String (Maybe (Entry, a))) -> a -> Entries +unfoldrEntries f = unfold + where + unfold x = case f x of + Left err -> Fail err + Right Nothing -> Done + Right (Just (e, x')) -> Next e (unfold x') + +foldrEntries :: (Entry -> a -> a) -> a -> (String -> a) -> Entries -> a +foldrEntries next done fail' = fold + where + fold (Next e es) = next e (fold es) + fold Done = done + fold (Fail err) = fail' err + +foldlEntries :: (a -> Entry -> a) -> a -> Entries -> Either String a +foldlEntries f = fold + where + fold a (Next e es) = (fold $! f a e) es + fold a Done = Right a + fold _ (Fail err) = Left err + +mapEntries :: (Entry -> Entry) -> Entries -> Entries +mapEntries f = foldrEntries (Next . f) Done Fail + +filterEntries :: (Entry -> Bool) -> Entries -> Entries +filterEntries p = + foldrEntries + (\entry rest -> if p entry + then Next entry rest + else rest) + Done Fail + +checkEntries :: (Entry -> Maybe String) -> Entries -> Entries +checkEntries checkEntry = + foldrEntries + (\entry rest -> case checkEntry entry of + Nothing -> Next entry rest + Just err -> Fail err) + Done Fail + +entriesIndex :: Entries -> Either String (Map.Map TarPath Entry) +entriesIndex = foldlEntries (\m e -> Map.insert (entryTarPath e) e m) Map.empty + +-- +-- * Checking +-- + +-- | This function checks a sequence of tar entries for file name security +-- problems. It checks that: +-- +-- * file paths are not absolute +-- +-- * file paths do not contain any path components that are \"@..@\" +-- +-- * file names are valid +-- +-- These checks are from the perspective of the current OS. That means we check +-- for \"@C:\blah@\" files on Windows and \"\/blah\" files on unix. For archive +-- entry types 'HardLink' and 'SymbolicLink' the same checks are done for the +-- link target. A failure in any entry terminates the sequence of entries with +-- an error. +-- +checkSecurity :: Entries -> Entries +checkSecurity = checkEntries checkEntrySecurity + +checkTarbomb :: FilePath -> Entries -> Entries +checkTarbomb expectedTopDir = checkEntries (checkEntryTarbomb expectedTopDir) + +checkEntrySecurity :: Entry -> Maybe String +checkEntrySecurity entry = case entryContent entry of + HardLink link -> check (entryPath entry) + `mplus` check (fromLinkTarget link) + SymbolicLink link -> check (entryPath entry) + `mplus` check (fromLinkTarget link) + _ -> check (entryPath entry) + + where + check name + | not (FilePath.Native.isRelative name) + = Just $ "Absolute file name in tar archive: " ++ show name + + | not (FilePath.Native.isValid name) + = Just $ "Invalid file name in tar archive: " ++ show name + + | any (=="..") (FilePath.Native.splitDirectories name) + = Just $ "Invalid file name in tar archive: " ++ show name + + | otherwise = Nothing + +checkEntryTarbomb :: FilePath -> Entry -> Maybe String +checkEntryTarbomb _ entry | nonFilesystemEntry = Nothing + where + -- Ignore some special entries we will not unpack anyway + nonFilesystemEntry = + case entryContent entry of + OtherEntryType 'g' _ _ -> True --PAX global header + OtherEntryType 'x' _ _ -> True --PAX individual header + _ -> False + +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 + + +-- +-- * Reading +-- + +read :: ByteString -> Entries +read = unfoldrEntries getEntry + +getEntry :: ByteString -> Either String (Maybe (Entry, ByteString)) +getEntry bs + | BS.length header < 512 = Left "truncated tar archive" + + -- Tar files end with at least two blocks of all '0'. Checking this serves + -- two purposes. It checks the format but also forces the tail of the data + -- which is necessary to close the file if it came from a lazily read file. + | BS.head bs == 0 = case BS.splitAt 1024 bs of + (end, trailing) + | BS.length end /= 1024 -> Left "short tar trailer" + | not (BS.all (== 0) end) -> Left "bad tar trailer" + | not (BS.all (== 0) trailing) -> Left "tar file has trailing junk" + | otherwise -> Right Nothing + + | otherwise = partial $ do + + case (chksum_, format_) of + (Ok chksum, _ ) | correctChecksum header chksum -> return () + (Ok _, Ok _) -> fail "tar checksum error" + _ -> fail "data is not in tar format" + + -- These fields are partial, have to check them + format <- format_; mode <- mode_; + uid <- uid_; gid <- gid_; + size <- size_; mtime <- mtime_; + devmajor <- devmajor_; devminor <- devminor_; + + let content = BS.take size (BS.drop 512 bs) + padding = (512 - size) `mod` 512 + bs' = BS.drop (512 + size + padding) bs + + entry = Entry { + entryTarPath = TarPath name prefix, + entryContent = case typecode of + '\0' -> NormalFile content size + '0' -> NormalFile content size + '1' -> HardLink (LinkTarget linkname) + '2' -> SymbolicLink (LinkTarget linkname) + '3' -> CharacterDevice devmajor devminor + '4' -> BlockDevice devmajor devminor + '5' -> Directory + '6' -> NamedPipe + '7' -> NormalFile content size + _ -> OtherEntryType typecode content size, + entryPermissions = mode, + entryOwnership = Ownership uname gname uid gid, + entryTime = mtime, + entryFormat = format + } + + return (Just (entry, bs')) + + where + header = BS.take 512 bs + + name = getString 0 100 header + mode_ = getOct 100 8 header + uid_ = getOct 108 8 header + gid_ = getOct 116 8 header + size_ = getOct 124 12 header + mtime_ = getOct 136 12 header + chksum_ = getOct 148 8 header + typecode = getByte 156 header + linkname = getString 157 100 header + magic = getChars 257 8 header + uname = getString 265 32 header + gname = getString 297 32 header + devmajor_ = getOct 329 8 header + devminor_ = getOct 337 8 header + prefix = getString 345 155 header +-- trailing = getBytes 500 12 header + + format_ = case magic of + "\0\0\0\0\0\0\0\0" -> return V7Format + "ustar\NUL00" -> return UstarFormat + "ustar \NUL" -> return GnuFormat + _ -> fail "tar entry not in a recognised format" + +correctChecksum :: ByteString -> Int -> Bool +correctChecksum header checksum = checksum == checksum' + where + -- sum of all 512 bytes in the header block, + -- treating each byte as an 8-bit unsigned value + checksum' = BS.Char8.foldl' (\x y -> x + ord y) 0 header' + -- treating the 8 bytes of chksum as blank characters. + header' = BS.concat [BS.take 148 header, + BS.Char8.replicate 8 ' ', + BS.drop 156 header] + +-- * TAR format primitive input + +getOct :: (Integral a, Bits a) => Int64 -> Int64 -> ByteString -> Partial a +getOct off len header + | BS.head bytes == 128 = parseBinInt (BS.unpack (BS.tail bytes)) + | null octstr = return 0 + | otherwise = case readOct octstr of + [(x,[])] -> return x + _ -> fail "tar header is malformed (bad numeric encoding)" + where + bytes = getBytes off len header + octstr = BS.Char8.unpack + . BS.Char8.takeWhile (\c -> c /= '\NUL' && c /= ' ') + . BS.Char8.dropWhile (== ' ') + $ bytes + + -- Some tar programs switch into a binary format when they try to represent + -- field values that will not fit in the required width when using the text + -- octal format. In particular, the UID/GID fields can only hold up to 2^21 + -- while in the binary format can hold up to 2^32. The binary format uses + -- '\128' as the header which leaves 7 bytes. Only the last 4 are used. + parseBinInt [0, 0, 0, byte3, byte2, byte1, byte0] = + return $! shiftL (fromIntegral byte3) 24 + + shiftL (fromIntegral byte2) 16 + + shiftL (fromIntegral byte1) 8 + + shiftL (fromIntegral byte0) 0 + parseBinInt _ = fail "tar header uses non-standard number encoding" + +getBytes :: Int64 -> Int64 -> ByteString -> ByteString +getBytes off len = BS.take len . BS.drop off + +getByte :: Int64 -> ByteString -> Char +getByte off bs = BS.Char8.index bs off + +getChars :: Int64 -> Int64 -> ByteString -> String +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 + +data Partial a = Error String | Ok a + +partial :: Partial a -> Either String a +partial (Error msg) = Left msg +partial (Ok x) = Right x + +instance Monad Partial where + return = Ok + Error m >>= _ = Error m + Ok x >>= k = k x + fail = Error + +-- +-- * Writing +-- + +-- | Create the external representation of a tar archive by serialising a list +-- of tar entries. +-- +-- * The conversion is done lazily. +-- +write :: [Entry] -> ByteString +write es = BS.concat $ map putEntry es ++ [BS.replicate (512*2) 0] + +putEntry :: Entry -> ByteString +putEntry entry = case entryContent entry of + NormalFile content size -> BS.concat [ header, content, padding size ] + OtherEntryType _ content size -> BS.concat [ header, content, padding size ] + _ -> header + where + header = putHeader entry + padding size = BS.replicate paddingSize 0 + where paddingSize = fromIntegral (negate size `mod` 512) + +putHeader :: Entry -> ByteString +putHeader entry = + BS.Char8.pack $ take 148 block + ++ putOct 7 checksum + ++ ' ' : drop 156 block + where + block = putHeaderNoChkSum entry + checksum = foldl' (\x y -> x + ord y) 0 block + +putHeaderNoChkSum :: Entry -> String +putHeaderNoChkSum Entry { + entryTarPath = TarPath name prefix, + entryContent = content, + entryPermissions = permissions, + entryOwnership = ownership, + entryTime = modTime, + entryFormat = format + } = + + concat + [ putString 100 $ name + , putOct 8 $ permissions + , putOct 8 $ ownerId ownership + , putOct 8 $ groupId ownership + , putOct 12 $ contentSize + , putOct 12 $ modTime + , fill 8 $ ' ' -- dummy checksum + , putChar8 $ typeCode + , putString 100 $ linkTarget + ] ++ + case format of + V7Format -> + fill 255 '\NUL' + UstarFormat -> concat + [ putString 8 $ "ustar\NUL00" + , putString 32 $ ownerName ownership + , putString 32 $ groupName ownership + , putOct 8 $ deviceMajor + , putOct 8 $ deviceMinor + , putString 155 $ prefix + , fill 12 $ '\NUL' + ] + GnuFormat -> concat + [ putString 8 $ "ustar \NUL" + , putString 32 $ ownerName ownership + , putString 32 $ groupName ownership + , putGnuDev 8 $ deviceMajor + , putGnuDev 8 $ deviceMinor + , putString 155 $ prefix + , fill 12 $ '\NUL' + ] + where + (typeCode, contentSize, linkTarget, + deviceMajor, deviceMinor) = case content of + NormalFile _ size -> ('0' , size, [], 0, 0) + Directory -> ('5' , 0, [], 0, 0) + SymbolicLink (LinkTarget link) -> ('2' , 0, link, 0, 0) + HardLink (LinkTarget link) -> ('1' , 0, link, 0, 0) + CharacterDevice major minor -> ('3' , 0, [], major, minor) + BlockDevice major minor -> ('4' , 0, [], major, minor) + NamedPipe -> ('6' , 0, [], 0, 0) + OtherEntryType code _ size -> (code, size, [], 0, 0) + + putGnuDev w n = case content of + CharacterDevice _ _ -> putOct w n + BlockDevice _ _ -> putOct w n + _ -> replicate w '\NUL' + +-- * TAR format primitive output + +type FieldWidth = Int + +putString :: FieldWidth -> String -> String +putString n s = take n s ++ fill (n - length s) '\NUL' + +--TODO: check integer widths, eg for large file sizes +putOct :: Integral a => FieldWidth -> a -> String +putOct n x = + let octStr = take (n-1) $ showOct x "" + in fill (n - length octStr - 1) '0' + ++ octStr + ++ putChar8 '\NUL' + +putChar8 :: Char -> String +putChar8 c = [c] + +fill :: FieldWidth -> Char -> String +fill n c = replicate n c + +-- +-- * Unpacking +-- + +unpack :: FilePath -> Entries -> IO () +unpack baseDir entries = unpackEntries [] (checkSecurity entries) + >>= emulateLinks + + where + -- We're relying here on 'checkSecurity' to make sure we're not scribbling + -- files all over the place. + + unpackEntries _ (Fail err) = fail err + unpackEntries links Done = return links + unpackEntries links (Next entry es) = case entryContent entry of + NormalFile file _ -> extractFile entry path file + >> unpackEntries links es + Directory -> extractDir path + >> unpackEntries links es + HardLink link -> (unpackEntries $! saveLink path link links) es + SymbolicLink link -> (unpackEntries $! saveLink path link links) es + _ -> unpackEntries links es --ignore other file types + where + path = entryPath entry + + extractFile entry path content = do + -- Note that tar archives do not make sure each directory is created + -- before files they contain, indeed we may have to create several + -- levels of directory. + createDirectoryIfMissing True absDir + BS.writeFile absPath content + when (isExecutable (entryPermissions entry)) + (setFileExecutable absPath) + where + absDir = baseDir FilePath.Native.takeDirectory path + absPath = baseDir path + + extractDir path = createDirectoryIfMissing True (baseDir path) + + saveLink path link links = seq (length path) + $ seq (length link') + $ (path, link'):links + where link' = fromLinkTarget link + + emulateLinks = mapM_ $ \(relPath, relLinkTarget) -> + let absPath = baseDir relPath + absTarget = FilePath.Native.takeDirectory absPath relLinkTarget + in copyFile absTarget absPath + +-- +-- * Packing +-- + +pack :: FilePath -- ^ Base directory + -> [FilePath] -- ^ Files and directories to pack, relative to the base dir + -> IO [Entry] +pack baseDir paths0 = preparePaths baseDir paths0 >>= packPaths baseDir + +preparePaths :: FilePath -> [FilePath] -> IO [FilePath] +preparePaths baseDir paths = + fmap concat $ interleave + [ do isDir <- doesDirectoryExist (baseDir path) + if isDir + then do entries <- getDirectoryContentsRecursive (baseDir path) + return (FilePath.Native.addTrailingPathSeparator path + : map (path ) entries) + else return [path] + | path <- paths ] + +packPaths :: FilePath -> [FilePath] -> IO [Entry] +packPaths baseDir paths = + interleave + [ do tarpath <- either fail return (toTarPath isDir relpath) + if isDir then packDirectoryEntry filepath tarpath + else packFileEntry filepath tarpath + | relpath <- paths + , let isDir = FilePath.Native.hasTrailingPathSeparator filepath + filepath = baseDir relpath ] + +interleave :: [IO a] -> IO [a] +interleave = unsafeInterleaveIO . go + where + go [] = return [] + go (x:xs) = do + x' <- x + xs' <- interleave xs + return (x':xs') + +packFileEntry :: FilePath -- ^ Full path to find the file on the local disk + -> TarPath -- ^ Path to use for the tar Entry in the archive + -> IO Entry +packFileEntry filepath tarpath = do + mtime <- getModTime filepath + perms <- getPermissions filepath + file <- openBinaryFile filepath ReadMode + size <- hFileSize file + content <- BS.hGetContents file + return (simpleEntry tarpath (NormalFile content (fromIntegral size))) { + entryPermissions = if Permissions.executable perms + then executableFilePermissions + else ordinaryFilePermissions, + entryTime = mtime + } + +packDirectoryEntry :: FilePath -- ^ Full path to find the file on the local disk + -> TarPath -- ^ Path to use for the tar Entry in the archive + -> IO Entry +packDirectoryEntry filepath tarpath = do + mtime <- getModTime filepath + return (directoryEntry tarpath) { + entryTime = mtime + } + +getDirectoryContentsRecursive :: FilePath -> IO [FilePath] +getDirectoryContentsRecursive dir0 = + fmap tail (recurseDirectories dir0 [""]) + +recurseDirectories :: FilePath -> [FilePath] -> IO [FilePath] +recurseDirectories _ [] = return [] +recurseDirectories base (dir:dirs) = unsafeInterleaveIO $ do + (files, dirs') <- collect [] [] =<< getDirectoryContents (base dir) + + files' <- recurseDirectories base (dirs' ++ dirs) + return (dir : files ++ files') + + where + collect files dirs' [] = return (reverse files, reverse dirs') + collect files dirs' (entry:entries) | ignore entry + = collect files dirs' entries + collect files dirs' (entry:entries) = do + let dirEntry = dir entry + dirEntry' = FilePath.Native.addTrailingPathSeparator dirEntry + isDirectory <- doesDirectoryExist (base dirEntry) + if isDirectory + then collect files (dirEntry':dirs') entries + else collect (dirEntry:files) dirs' entries + + ignore ['.'] = True + ignore ['.', '.'] = True + ignore _ = False + +getModTime :: FilePath -> IO EpochTime +getModTime path = do + (TOD s _) <- getModificationTime path + return $! fromIntegral s diff --git a/Distribution/Client/Targets.hs b/Distribution/Client/Targets.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Targets.hs @@ -0,0 +1,657 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Targets +-- Copyright : (c) Duncan Coutts 2011 +-- License : BSD-like +-- +-- Maintainer : duncan@community.haskell.org +-- +-- Handling for user-specified targets +----------------------------------------------------------------------------- +module Distribution.Client.Targets ( + -- * User targets + UserTarget(..), + readUserTargets, + + -- * Package specifiers + PackageSpecifier(..), + pkgSpecifierTarget, + pkgSpecifierConstraints, + + -- * Resolving user targets to package specifiers + resolveUserTargets, + + -- ** Detailed interface + UserTargetProblem(..), + readUserTarget, + reportUserTargetProblems, + expandUserTarget, + + PackageTarget(..), + fetchPackageTarget, + readPackageTarget, + + PackageTargetProblem(..), + reportPackageTargetProblems, + + disambiguatePackageTargets, + disambiguatePackageName, + + ) where + +import Distribution.Package + ( Package(..), PackageName(..) + , PackageIdentifier(..), packageName, packageVersion + , Dependency(Dependency) ) +import Distribution.Client.Types + ( AvailablePackage(..), PackageLocation(..) ) +import Distribution.Client.Dependency.Types + ( PackageConstraint(..) ) + +import qualified Distribution.Client.World as World +import Distribution.Client.PackageIndex (PackageIndex) +import qualified Distribution.Client.PackageIndex as PackageIndex +import qualified Distribution.Client.Tar as Tar +import Distribution.Client.FetchUtils + +import Distribution.PackageDescription + ( GenericPackageDescription ) +import Distribution.PackageDescription.Parse + ( readPackageDescription, parsePackageDescription, ParseResult(..) ) +import Distribution.Simple.Setup + ( fromFlag ) +import Distribution.Client.Setup + ( GlobalFlags(..) ) +import Distribution.Version + ( Version(Version), thisVersion, anyVersion, isAnyVersion ) +import Distribution.Text + ( Text(parse), display ) +import Distribution.Verbosity (Verbosity) +import Distribution.Simple.Utils + ( die, warn, intercalate, findPackageDesc, fromUTF8, lowercase ) + +import Data.List + ( find, nub ) +import Data.Maybe + ( listToMaybe ) +import Data.Either + ( partitionEithers ) +import Data.Monoid + ( Monoid(..) ) +import qualified Data.Map as Map +import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString.Lazy.Char8 as BS.Char8 +import qualified Distribution.Client.GZipUtils as GZipUtils +import Control.Monad (liftM) +import qualified Distribution.Compat.ReadP as Parse + ( ReadP, readP_to_S, (+++) ) +import Data.Char + ( isSpace ) +import System.FilePath + ( takeExtension, dropExtension, takeDirectory, splitPath ) +import System.Directory + ( doesFileExist, doesDirectoryExist ) +import Network.URI + ( URI(..), URIAuth(..), parseAbsoluteURI ) + +-- ------------------------------------------------------------ +-- * User targets +-- ------------------------------------------------------------ + +-- | Various ways that a user may specify a package or package collection. +-- +data UserTarget = + + -- | A partially specified package, identified by name and possibly with + -- an exact version or a version constraint. + -- + -- > cabal install foo + -- > cabal install foo-1.0 + -- > cabal install 'foo < 2' + -- + UserTargetNamed Dependency + + -- | A special virtual package that refers to the collection of packages + -- recorded in the world file that the user specifically installed. + -- + -- > cabal install world + -- + | UserTargetWorld + + -- | A specific package that is unpacked in a local directory, often the + -- current directory. + -- + -- > cabal install . + -- > cabal install ../lib/other + -- + -- * Note: in future, if multiple @.cabal@ files are allowed in a single + -- directory then this will refer to the collection of packages. + -- + | UserTargetLocalDir FilePath + + -- | A specific local unpacked package, identified by its @.cabal@ file. + -- + -- > cabal install foo.cabal + -- > cabal install ../lib/other/bar.cabal + -- + | UserTargetLocalCabalFile FilePath + + -- | A specific package that is available as a local tarball file + -- + -- > cabal install dist/foo-1.0.tar.gz + -- > cabal install ../build/baz-1.0.tar.gz + -- + | UserTargetLocalTarball FilePath + + -- | A specific package that is available as a remote tarball file + -- + -- > cabal install http://code.haskell.org/~user/foo/foo-0.9.tar.gz + -- + | UserTargetRemoteTarball URI + deriving (Show,Eq) + + +-- ------------------------------------------------------------ +-- * Package specifier +-- ------------------------------------------------------------ + +-- | A fully or partially resolved reference to a package. +-- +data PackageSpecifier pkg = + + -- | A partially specified reference to a package (either source or + -- installed). It is specified by package name and optionally some + -- additional constraints. Use a dependency resolver to pick a specific + -- package satisfying these constraints. + -- + NamedPackage PackageName [PackageConstraint] + + -- | A fully specified source package. + -- + | SpecificSourcePackage pkg + deriving Show + + +pkgSpecifierTarget :: Package pkg => PackageSpecifier pkg -> PackageName +pkgSpecifierTarget (NamedPackage name _) = name +pkgSpecifierTarget (SpecificSourcePackage pkg) = packageName pkg + +pkgSpecifierConstraints :: Package pkg + => PackageSpecifier pkg -> [PackageConstraint] +pkgSpecifierConstraints (NamedPackage _ constraints) = constraints +pkgSpecifierConstraints (SpecificSourcePackage pkg) = + [PackageVersionConstraint (packageName pkg) + (thisVersion (packageVersion pkg))] + + +-- ------------------------------------------------------------ +-- * Parsing and checking user targets +-- ------------------------------------------------------------ + +readUserTargets :: Verbosity -> [String] -> IO [UserTarget] +readUserTargets _verbosity targetStrs = do + (problems, targets) <- liftM partitionEithers + (mapM readUserTarget targetStrs) + reportUserTargetProblems problems + return targets + + +data UserTargetProblem + = UserTargetUnexpectedFile String + | UserTargetNonexistantFile String + | UserTargetUnexpectedUriScheme String + | UserTargetUnrecognisedUri String + | UserTargetUnrecognised String + | UserTargetBadWorldPkg + deriving Show + +readUserTarget :: String -> IO (Either UserTargetProblem UserTarget) +readUserTarget targetstr = + case testNamedTargets targetstr of + Just (Dependency (PackageName "world") verrange) + | verrange == anyVersion -> return (Right UserTargetWorld) + | otherwise -> return (Left UserTargetBadWorldPkg) + Just dep -> return (Right (UserTargetNamed dep)) + Nothing -> do + fileTarget <- testFileTargets targetstr + case fileTarget of + Just target -> return target + Nothing -> + case testUriTargets targetstr of + Just target -> return target + Nothing -> return (Left (UserTargetUnrecognised targetstr)) + where + testNamedTargets = readPToMaybe parseDependencyOrPackageId + + testFileTargets filename = do + isDir <- doesDirectoryExist filename + isFile <- doesFileExist filename + parentDirExists <- case takeDirectory filename of + [] -> return False + dir -> doesDirectoryExist dir + let result + | isDir + = Just (Right (UserTargetLocalDir filename)) + + | isFile && extensionIsTarGz filename + = Just (Right (UserTargetLocalTarball filename)) + + | isFile && takeExtension filename == ".cabal" + = Just (Right (UserTargetLocalCabalFile filename)) + + | isFile + = Just (Left (UserTargetUnexpectedFile filename)) + + | parentDirExists + = Just (Left (UserTargetNonexistantFile filename)) + + | otherwise + = Nothing + return result + + testUriTargets str = + case parseAbsoluteURI str of + Just uri@URI { + uriScheme = scheme, + uriAuthority = Just URIAuth { uriRegName = host } + } + | scheme /= "http:" -> + Just (Left (UserTargetUnexpectedUriScheme targetstr)) + + | null host -> + Just (Left (UserTargetUnrecognisedUri targetstr)) + + | otherwise -> + Just (Right (UserTargetRemoteTarball uri)) + _ -> Nothing + + extensionIsTarGz f = takeExtension f == ".gz" + && takeExtension (dropExtension f) == ".tar" + + parseDependencyOrPackageId :: Parse.ReadP r Dependency + parseDependencyOrPackageId = parse Parse.+++ liftM pkgidToDependency parse + where + pkgidToDependency :: PackageIdentifier -> Dependency + pkgidToDependency p = case packageVersion p of + Version [] _ -> Dependency (packageName p) anyVersion + version -> Dependency (packageName p) (thisVersion version) + + readPToMaybe :: Parse.ReadP a a -> String -> Maybe a + readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str + , all isSpace s ] + + +reportUserTargetProblems :: [UserTargetProblem] -> IO () +reportUserTargetProblems problems = do + case [ target | UserTargetUnrecognised target <- problems ] of + [] -> return () + target -> die + $ unlines + [ "Unrecognised target '" ++ name ++ "'." + | name <- target ] + ++ "Targets can be:\n" + ++ " - package names, e.g. 'pkgname', 'pkgname-1.0.1', 'pkgname < 2.0'\n" + ++ " - the special 'world' target\n" + ++ " - cabal files 'pkgname.cabal' or package directories 'pkgname/'\n" + ++ " - package tarballs 'pkgname.tar.gz' or 'http://example.com/pkgname.tar.gz'" + + case [ () | UserTargetBadWorldPkg <- problems ] of + [] -> return () + _ -> die "The special 'world' target does not take any version." + + case [ target | UserTargetNonexistantFile target <- problems ] of + [] -> return () + target -> die + $ unlines + [ "The file does not exist '" ++ name ++ "'." + | name <- target ] + + case [ target | UserTargetUnexpectedFile target <- problems ] of + [] -> return () + target -> die + $ unlines + [ "Unrecognised file target '" ++ name ++ "'." + | name <- target ] + ++ "File targets can be either package tarballs 'pkgname.tar.gz' " + ++ "or cabal files 'pkgname.cabal'." + + case [ target | UserTargetUnexpectedUriScheme target <- problems ] of + [] -> return () + target -> die + $ unlines + [ "URL target not supported '" ++ name ++ "'." + | name <- target ] + ++ "Only 'http://' URLs are supported." + + case [ target | UserTargetUnrecognisedUri target <- problems ] of + [] -> return () + target -> die + $ unlines + [ "Unrecognise URL target '" ++ name ++ "'." + | name <- target ] + + +-- ------------------------------------------------------------ +-- * Resolving user targets to package specifiers +-- ------------------------------------------------------------ + +-- | Given a bunch of user-specified targets, try to resolve what it is they +-- refer to. They can either be specific packages (local dirs, tarballs etc) +-- or they can be named packages (with or without version info). +-- +resolveUserTargets :: Package pkg + => Verbosity + -> GlobalFlags + -> PackageIndex pkg + -> [UserTarget] + -> IO [PackageSpecifier AvailablePackage] +resolveUserTargets verbosity globalFlags available userTargets = do + + -- given the user targets, get a list of fully or partially resolved + -- package references + packageTargets <- mapM (readPackageTarget verbosity) + =<< mapM (fetchPackageTarget verbosity) . concat + =<< mapM (expandUserTarget globalFlags) userTargets + + -- users are allowed to give package names case-insensitively, so we must + -- disambiguate named package references + let (problems, packageSpecifiers) = + disambiguatePackageTargets available availableExtra packageTargets + + -- use any extra specific available packages to help us disambiguate + availableExtra = [ packageName pkg + | PackageTargetLocation pkg <- packageTargets ] + + reportPackageTargetProblems verbosity problems + + return packageSpecifiers + + +-- ------------------------------------------------------------ +-- * Package targets +-- ------------------------------------------------------------ + +-- | An intermediate between a 'UserTarget' and a resolved 'PackageSpecifier'. +-- Unlike a 'UserTarget', a 'PackageTarget' refers only to a single package. +-- +data PackageTarget pkg = + PackageTargetNamed PackageName [PackageConstraint] UserTarget + + -- | A package identified by name, but case insensitively, so it needs + -- to be resolved to the right case-sensitive name. + | PackageTargetNamedFuzzy PackageName [PackageConstraint] UserTarget + | PackageTargetLocation pkg + deriving Show + + +-- ------------------------------------------------------------ +-- * Converting user targets to package targets +-- ------------------------------------------------------------ + +-- | Given a user-specified target, expand it to a bunch of package targets +-- (each of which refers to only one package). +-- +expandUserTarget :: GlobalFlags + -> UserTarget + -> IO [PackageTarget (PackageLocation ())] +expandUserTarget globalFlags userTarget = case userTarget of + + UserTargetNamed (Dependency name vrange) -> + let constraints = [ PackageVersionConstraint name vrange + | not (isAnyVersion vrange) ] + in return [PackageTargetNamedFuzzy name constraints userTarget] + + UserTargetWorld -> do + worldPkgs <- World.getContents worldFile + --TODO: should we warn if there are no world targets? + return [ PackageTargetNamed name constraints userTarget + | World.WorldPkgInfo (Dependency name vrange) flags <- worldPkgs + , let constraints = [ PackageVersionConstraint name vrange + | not (isAnyVersion vrange) ] + ++ [ PackageFlagsConstraint name flags + | not (null flags) ] ] + + UserTargetLocalDir dir -> + return [ PackageTargetLocation (LocalUnpackedPackage dir) ] + + UserTargetLocalCabalFile file -> do + let dir = takeDirectory file + _ <- findPackageDesc dir -- just as a check + return [ PackageTargetLocation (LocalUnpackedPackage dir) ] + + UserTargetLocalTarball tarballFile -> + return [ PackageTargetLocation (LocalTarballPackage tarballFile) ] + + UserTargetRemoteTarball tarballURL -> + return [ PackageTargetLocation (RemoteTarballPackage tarballURL ()) ] + where + worldFile = fromFlag $ globalWorldFile globalFlags + + +-- ------------------------------------------------------------ +-- * Fetching and reading package targets +-- ------------------------------------------------------------ + + +-- | Fetch any remote targets so that they can be read. +-- +fetchPackageTarget :: Verbosity + -> PackageTarget (PackageLocation ()) + -> IO (PackageTarget (PackageLocation FilePath)) +fetchPackageTarget verbosity target = case target of + PackageTargetNamed n cs ut -> return (PackageTargetNamed n cs ut) + PackageTargetNamedFuzzy n cs ut -> return (PackageTargetNamedFuzzy n cs ut) + PackageTargetLocation location -> do + location' <- fetchPackage verbosity (fmap (const Nothing) location) + return (PackageTargetLocation location') + + +-- | Given a package target that has been fetched, read the .cabal file. +-- +-- This only affects targets given by location, named targets are unaffected. +-- +readPackageTarget :: Verbosity + -> PackageTarget (PackageLocation FilePath) + -> IO (PackageTarget AvailablePackage) +readPackageTarget verbosity target = case target of + + PackageTargetNamed pkgname constraints userTarget -> + return (PackageTargetNamed pkgname constraints userTarget) + + PackageTargetNamedFuzzy pkgname constraints userTarget -> + return (PackageTargetNamedFuzzy pkgname constraints userTarget) + + PackageTargetLocation location -> case location of + + LocalUnpackedPackage dir -> do + pkg <- readPackageDescription verbosity =<< findPackageDesc dir + return $ PackageTargetLocation $ + AvailablePackage { + packageInfoId = packageId pkg, + packageDescription = pkg, + packageSource = fmap Just location + } + + LocalTarballPackage tarballFile -> + readTarballPackageTarget location tarballFile tarballFile + + RemoteTarballPackage tarballURL tarballFile -> + readTarballPackageTarget location tarballFile (show tarballURL) + + RepoTarballPackage _repo _pkgid _ -> + error "TODO: readPackageTarget RepoTarballPackage" + -- For repo tarballs this info should be obtained from the index. + + where + readTarballPackageTarget location tarballFile tarballOriginalLoc = do + (filename, content) <- extractTarballPackageCabalFile + tarballFile tarballOriginalLoc + case parsePackageDescription' content of + Nothing -> die $ "Could not parse the cabal file " + ++ filename ++ " in " ++ tarballFile + Just pkg -> + return $ PackageTargetLocation $ + AvailablePackage { + packageInfoId = packageId pkg, + packageDescription = pkg, + packageSource = fmap Just location + } + + extractTarballPackageCabalFile :: FilePath -> String + -> IO (FilePath, BS.ByteString) + extractTarballPackageCabalFile tarballFile tarballOriginalLoc = + either (die . formatErr) return + . check + . Tar.entriesIndex + . Tar.filterEntries isCabalFile + . Tar.read + . GZipUtils.maybeDecompress + =<< BS.readFile tarballFile + where + formatErr msg = "Error reading " ++ tarballOriginalLoc ++ ": " ++ msg + + check (Left e) = Left e + check (Right m) = case Map.elems m of + [] -> Left noCabalFile + [file] -> case Tar.entryContent file of + Tar.NormalFile content _ -> Right (Tar.entryPath file, content) + _ -> Left noCabalFile + _files -> Left multipleCabalFiles + where + noCabalFile = "No cabal file found" + multipleCabalFiles = "Multiple cabal files found" + + isCabalFile e = case splitPath (Tar.entryPath e) of + [ _dir, file] -> takeExtension file == ".cabal" + [".", _dir, file] -> takeExtension file == ".cabal" + _ -> False + + parsePackageDescription' :: BS.ByteString -> Maybe GenericPackageDescription + parsePackageDescription' content = + case parsePackageDescription . fromUTF8 . BS.Char8.unpack $ content of + ParseOk _ pkg -> Just pkg + _ -> Nothing + + +-- ------------------------------------------------------------ +-- * Checking package targets +-- ------------------------------------------------------------ + +data PackageTargetProblem + = PackageNameUnknown PackageName UserTarget + | PackageNameAmbigious PackageName [PackageName] UserTarget + deriving Show + + +-- | Users are allowed to give package names case-insensitively, so we must +-- disambiguate named package references. +-- +disambiguatePackageTargets :: Package pkg' + => PackageIndex pkg' + -> [PackageName] + -> [PackageTarget pkg] + -> ( [PackageTargetProblem] + , [PackageSpecifier pkg] ) +disambiguatePackageTargets available availableExtra targets = + partitionEithers (map disambiguatePackageTarget targets) + where + disambiguatePackageTarget packageTarget = case packageTarget of + PackageTargetLocation pkg -> Right (SpecificSourcePackage pkg) + + PackageTargetNamed pkgname constraints userTarget + | null (PackageIndex.lookupPackageName available pkgname) + -> Left (PackageNameUnknown pkgname userTarget) + | otherwise -> Right (NamedPackage pkgname constraints) + + PackageTargetNamedFuzzy pkgname constraints userTarget -> + case disambiguatePackageName packageNameEnv pkgname of + None -> Left (PackageNameUnknown + pkgname userTarget) + Ambiguous pkgnames -> Left (PackageNameAmbigious + pkgname pkgnames userTarget) + Unambiguous pkgname' -> Right (NamedPackage pkgname' constraints) + + -- use any extra specific available packages to help us disambiguate + packageNameEnv :: PackageNameEnv + packageNameEnv = mappend (indexPackageNameEnv available) + (extraPackageNameEnv availableExtra) + + +-- | Report problems to the user. That is, if there are any problems +-- then raise an exception. +reportPackageTargetProblems :: Verbosity + -> [PackageTargetProblem] -> IO () +reportPackageTargetProblems verbosity problems = do + case [ pkg | PackageNameUnknown pkg originalTarget <- problems + , not (isUserTagetWorld originalTarget) ] of + [] -> return () + pkgs -> die $ unlines + [ "There is no package named '" ++ display name ++ "'. " + | name <- pkgs ] + ++ "You may need to run 'cabal update' to get the latest " + ++ "list of available packages." + + case [ (pkg, matches) | PackageNameAmbigious pkg matches _ <- problems ] of + [] -> return () + ambiguities -> die $ unlines + [ "The package name '" ++ display name + ++ "' is ambigious. It could be: " + ++ intercalate ", " (map display matches) + | (name, matches) <- ambiguities ] + + case [ pkg | PackageNameUnknown pkg UserTargetWorld <- problems ] of + [] -> return () + pkgs -> warn verbosity $ + "The following 'world' packages will be ignored because " + ++ "they refer to packages that cannot be found: " + ++ intercalate ", " (map display pkgs) ++ "\n" + ++ "You can surpress this warning by correcting the world file." + where + isUserTagetWorld UserTargetWorld = True; isUserTagetWorld _ = False + + +-- ------------------------------------------------------------ +-- * Disambiguating package names +-- ------------------------------------------------------------ + +data MaybeAmbigious a = None | Unambiguous a | Ambiguous [a] + +-- | Given a package name and a list of matching names, figure out which one it +-- might be referring to. If there is an exact case-sensitive match then that's +-- ok. If it matches just one package case-insensitively then that's also ok. +-- The only problem is if it matches multiple packages case-insensitively, in +-- that case it is ambigious. +-- +disambiguatePackageName :: PackageNameEnv + -> PackageName + -> MaybeAmbigious PackageName +disambiguatePackageName (PackageNameEnv pkgNameLookup) name = + case nub (pkgNameLookup name) of + [] -> None + [name'] -> Unambiguous name' + names -> case find (name==) names of + Just name' -> Unambiguous name' + Nothing -> Ambiguous names + + +newtype PackageNameEnv = PackageNameEnv (PackageName -> [PackageName]) + +instance Monoid PackageNameEnv where + mempty = PackageNameEnv (const []) + mappend (PackageNameEnv lookupA) (PackageNameEnv lookupB) = + PackageNameEnv (\name -> lookupA name ++ lookupB name) + +indexPackageNameEnv :: Package pkg => PackageIndex pkg -> PackageNameEnv +indexPackageNameEnv index = PackageNameEnv pkgNameLookup + where + pkgNameLookup (PackageName name) = + map fst (PackageIndex.searchByName index name) + +extraPackageNameEnv :: [PackageName] -> PackageNameEnv +extraPackageNameEnv names = PackageNameEnv pkgNameLookup + where + pkgNameLookup (PackageName name) = + [ PackageName name' + | let lname = lowercase name + , PackageName name' <- names + , lowercase name' == lname ] diff --git a/Distribution/Client/Types.hs b/Distribution/Client/Types.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Types.hs @@ -0,0 +1,163 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Types +-- Copyright : (c) David Himmelstrup 2005 +-- Duncan Coutts 2011 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Various common data types for the entire cabal-install system +----------------------------------------------------------------------------- +module Distribution.Client.Types where + +import Distribution.Package + ( PackageName, PackageId, Package(..), PackageFixedDeps(..) ) +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo ) +import Distribution.PackageDescription + ( GenericPackageDescription, FlagAssignment ) +import Distribution.Client.PackageIndex + ( PackageIndex ) +import Distribution.Version + ( VersionRange ) + +import Data.Map (Map) +import Network.URI (URI) +import Distribution.Compat.Exception + ( SomeException ) + +newtype Username = Username { unUsername :: String } +newtype Password = Password { unPassword :: String } + +-- | This is the information we get from a @00-index.tar.gz@ hackage index. +-- +data AvailablePackageDb = AvailablePackageDb { + packageIndex :: PackageIndex AvailablePackage, + packagePreferences :: Map PackageName VersionRange +} + +-- ------------------------------------------------------------ +-- * Various kinds of information about packages +-- ------------------------------------------------------------ + +-- | TODO: This is a hack to help us transition from Cabal-1.6 to 1.8. +-- What is new in 1.8 is that installed packages and dependencies between +-- installed packages are now identified by an opaque InstalledPackageId +-- rather than a source PackageId. +-- +-- We should use simply an 'InstalledPackageInfo' here but to ease the +-- transition we are temporarily using this variant where we pretend that +-- installed packages still specify their deps in terms of PackageIds. +-- +-- Crucially this means that 'InstalledPackage' can be an instance of +-- 'PackageFixedDeps' where as 'InstalledPackageInfo' is no longer an instance +-- of that class. This means we can make 'PackageIndex'es of InstalledPackage +-- where as the InstalledPackageInfo now has its own monomorphic index type. +-- +data InstalledPackage = InstalledPackage + InstalledPackageInfo + [PackageId] + +instance Package InstalledPackage where + packageId (InstalledPackage pkg _) = packageId pkg +instance PackageFixedDeps InstalledPackage where + depends (InstalledPackage _ deps) = deps + +-- | A 'ConfiguredPackage' is a not-yet-installed package along with the +-- total configuration information. The configuration information is total in +-- the sense that it provides all the configuration information and so the +-- final configure process will be independent of the environment. +-- +data ConfiguredPackage = ConfiguredPackage + AvailablePackage -- package info, including repo + FlagAssignment -- complete flag assignment for the package + [PackageId] -- set of exact dependencies. These must be + -- consistent with the 'buildDepends' in the + -- 'PackageDescrption' that you'd get by applying + -- the flag assignment. + deriving Show + +instance Package ConfiguredPackage where + packageId (ConfiguredPackage pkg _ _) = packageId pkg + +instance PackageFixedDeps ConfiguredPackage where + depends (ConfiguredPackage _ _ deps) = deps + + +-- | We re-use @GenericPackageDescription@ and use the @package-url@ +-- field to store the tarball URI. +data AvailablePackage = AvailablePackage { + packageInfoId :: PackageId, + packageDescription :: GenericPackageDescription, + packageSource :: PackageLocation (Maybe FilePath) + } + deriving Show + +instance Package AvailablePackage where packageId = packageInfoId + +-- ------------------------------------------------------------ +-- * Package locations and repositories +-- ------------------------------------------------------------ + +data PackageLocation local = + + -- | An unpacked package in the given dir, or current dir + LocalUnpackedPackage FilePath + + -- | A package as a tarball that's available as a local tarball + | LocalTarballPackage FilePath + + -- | A package as a tarball from a remote URI + | RemoteTarballPackage URI local + + -- | A package available as a tarball from a repository. + -- + -- It may be from a local repository or from a remote repository, with a + -- locally cached copy. ie a package available from hackage + | RepoTarballPackage Repo PackageId local + +--TODO: +-- * add support for darcs and other SCM style remote repos with a local cache +-- | ScmPackage + deriving Show + +instance Functor PackageLocation where + fmap _ (LocalUnpackedPackage dir) = LocalUnpackedPackage dir + fmap _ (LocalTarballPackage file) = LocalTarballPackage file + fmap f (RemoteTarballPackage uri x) = RemoteTarballPackage uri (f x) + fmap f (RepoTarballPackage repo pkg x) = RepoTarballPackage repo pkg (f x) + + +data LocalRepo = LocalRepo + deriving (Show,Eq) + +data RemoteRepo = RemoteRepo { + remoteRepoName :: String, + remoteRepoURI :: URI + } + deriving (Show,Eq) + +data Repo = Repo { + repoKind :: Either RemoteRepo LocalRepo, + repoLocalDir :: FilePath + } + deriving (Show,Eq) + +-- ------------------------------------------------------------ +-- * Build results +-- ------------------------------------------------------------ + +type BuildResult = Either BuildFailure BuildSuccess +data BuildFailure = DependentFailed PackageId + | DownloadFailed SomeException + | UnpackFailed SomeException + | ConfigureFailed SomeException + | BuildFailed SomeException + | InstallFailed SomeException +data BuildSuccess = BuildOk DocsResult TestsResult + +data DocsResult = DocsNotTried | DocsFailed | DocsOk +data TestsResult = TestsNotTried | TestsFailed | TestsOk diff --git a/Distribution/Client/Unpack.hs b/Distribution/Client/Unpack.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Unpack.hs @@ -0,0 +1,121 @@ +----------------------------------------------------------------------------- +-- | +-- 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 ) +import Distribution.Simple.Setup + ( fromFlagOrDefault ) +import Distribution.Simple.Utils + ( notice, die ) +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 + ( getAvailablePackages ) + +import System.Directory + ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist ) +import Control.Monad + ( unless, when ) +import Data.Monoid + ( mempty ) +import System.FilePath + ( (), addTrailingPathSeparator ) + + +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 + + availableDb <- getAvailablePackages verbosity repos + + pkgSpecifiers <- resolveUserTargets verbosity + globalFlags (packageIndex availableDb) userTargets + + pkgs <- either (die . unlines . map show) return $ + resolveWithoutDependencies + (resolverParams availableDb pkgSpecifiers) + + unless (null prefix) $ + createDirectoryIfMissing True prefix + + flip mapM_ pkgs $ \pkg -> do + location <- fetchPackage verbosity (packageSource pkg) + let pkgid = packageId pkg + case location of + LocalTarballPackage tarballPath -> + unpackPackage verbosity prefix pkgid tarballPath + + RemoteTarballPackage _tarballURL tarballPath -> + unpackPackage verbosity prefix pkgid tarballPath + + RepoTarballPackage _repo _pkgid tarballPath -> + unpackPackage verbosity prefix pkgid tarballPath + + LocalUnpackedPackage _ -> + error "Distribution.Client.Unpack.unpack: the impossible happened." + + where + resolverParams availableDb pkgSpecifiers = + --TODO: add commandline constraint and preference args for unpack + + standardInstallPolicy mempty availableDb pkgSpecifiers + + prefix = fromFlagOrDefault "" (unpackDestDir 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 -> FilePath -> IO () +unpackPackage verbosity prefix pkgid 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 diff --git a/Distribution/Client/Update.hs b/Distribution/Client/Update.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Update.hs @@ -0,0 +1,81 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Update +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- +----------------------------------------------------------------------------- +module Distribution.Client.Update + ( update + ) where + +import Distribution.Client.Types + ( Repo(..), RemoteRepo(..), LocalRepo(..), AvailablePackageDb(..) ) +import Distribution.Client.FetchUtils + ( downloadIndex ) +import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Client.IndexUtils + ( getAvailablePackages ) +import qualified Paths_cabal_install_bundle + ( version ) + +import Distribution.Package + ( PackageName(..), packageVersion ) +import Distribution.Version + ( anyVersion, withinRange ) +import Distribution.Simple.Utils + ( warn, notice, writeFileAtomic ) +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) + +-- | 'update' downloads the package list from all known servers +update :: Verbosity -> [Repo] -> IO () +update verbosity [] = do + warn verbosity $ "No remote package servers have been specified. Usually " + ++ "you would have one specified in the config file." +update verbosity repos = do + mapM_ (updateRepo verbosity) repos + checkForSelfUpgrade verbosity repos + +updateRepo :: Verbosity -> Repo -> IO () +updateRepo verbosity repo = case repoKind repo of + Right LocalRepo -> return () + 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 + +checkForSelfUpgrade :: Verbosity -> [Repo] -> IO () +checkForSelfUpgrade verbosity repos = do + AvailablePackageDb available prefs <- getAvailablePackages verbosity repos + + let self = PackageName "cabal-install" + preferredVersionRange = fromMaybe anyVersion (Map.lookup self prefs) + currentVersion = Paths_cabal_install_bundle.version + laterPreferredVersions = + [ packageVersion pkg + | pkg <- PackageIndex.lookupPackageName available self + , let version = packageVersion pkg + , version > currentVersion + , version `withinRange` preferredVersionRange ] + + when (not (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/Upload.hs b/Distribution/Client/Upload.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Upload.hs @@ -0,0 +1,190 @@ +-- This is a quick hack for uploading packages to Hackage. +-- See http://hackage.haskell.org/trac/hackage/wiki/CabalUpload + +module Distribution.Client.Upload (check, upload, report) where + +import Distribution.Client.Types (Username(..), Password(..),Repo(..),RemoteRepo(..)) +import Distribution.Client.HttpUtils (proxy, isOldHackageURI) + +import Distribution.Simple.Utils (debug, notice, warn, info) +import Distribution.Verbosity (Verbosity) +import Distribution.Text (display) +import Distribution.Client.Config + +import qualified Distribution.Client.BuildReports.Anonymous as BuildReport +import qualified Distribution.Client.BuildReports.Upload as BuildReport + +import Network.Browser + ( BrowserAction, browse, request + , Authority(..), addAuthority, setAuthorityGen + , setOutHandler, setErrHandler, setProxy ) +import Network.HTTP + ( Header(..), HeaderName(..), findHeader + , Request(..), RequestMethod(..), Response(..) ) +import Network.TCP (HandleStream) +import Network.URI (URI(uriPath), parseURI) + +import Data.Char (intToDigit) +import Numeric (showHex) +import System.IO (hFlush, stdin, stdout, hGetEcho, hSetEcho + ,openBinaryFile, IOMode(ReadMode), hGetContents) +import Control.Exception (bracket) +import System.Random (randomRIO) +import System.FilePath ((), takeExtension, takeFileName) +import qualified System.FilePath.Posix as FilePath.Posix (combine) +import System.Directory +import Control.Monad (forM_) + + +--FIXME: how do we find this path for an arbitrary hackage server? +-- is it always at some fixed location relative to the server root? +legacyUploadURI :: URI +Just legacyUploadURI = parseURI "http://hackage.haskell.org/cgi-bin/hackage-scripts/protected/upload-pkg" + +checkURI :: URI +Just checkURI = parseURI "http://hackage.haskell.org/cgi-bin/hackage-scripts/check-pkg" + + +upload :: Verbosity -> [Repo] -> Maybe Username -> Maybe Password -> [FilePath] -> IO () +upload verbosity repos mUsername mPassword paths = do + let uploadURI = if isOldHackageURI targetRepoURI + then legacyUploadURI + else targetRepoURI{uriPath = uriPath targetRepoURI `FilePath.Posix.combine` "upload"} + Username username <- maybe promptUsername return mUsername + Password password <- maybe promptPassword return mPassword + let auth = addAuthority AuthBasic { + auRealm = "Hackage", + auUsername = username, + auPassword = password, + auSite = uploadURI + } + flip mapM_ paths $ \path -> do + notice verbosity $ "Uploading " ++ path ++ "... " + handlePackage verbosity uploadURI auth path + where + targetRepoURI = remoteRepoURI $ last [ remoteRepo | Left remoteRepo <- map repoKind repos ] --FIXME: better error message when no repos are given + +promptUsername :: IO Username +promptUsername = do + putStr "Hackage username: " + hFlush stdout + fmap Username getLine + +promptPassword :: IO Password +promptPassword = do + putStr "Hackage password: " + hFlush stdout + -- save/restore the terminal echoing status + passwd <- bracket (hGetEcho stdin) (hSetEcho stdin) $ \_ -> do + hSetEcho stdin False -- no echoing for entering the password + fmap Password getLine + putStrLn "" + return passwd + +report :: Verbosity -> [Repo] -> Maybe Username -> Maybe Password -> IO () +report verbosity repos mUsername mPassword = do + let uploadURI = if isOldHackageURI targetRepoURI + then legacyUploadURI + else targetRepoURI{uriPath = ""} + Username username <- maybe promptUsername return mUsername + Password password <- maybe promptPassword return mPassword + let auth = addAuthority AuthBasic { + auRealm = "Hackage", + auUsername = username, + auPassword = password, + auSite = uploadURI + } + forM_ repos $ \repo -> case repoKind repo of + Left remoteRepo + -> do dotCabal <- defaultCabalDir + let srcDir = dotCabal "reports" remoteRepoName remoteRepo + contents <- getDirectoryContents srcDir + forM_ (filter (\c -> takeExtension c == ".log") contents) $ \logFile -> + do inp <- readFile (srcDir logFile) + let (reportStr, buildLog) = read inp :: (String,String) + case BuildReport.parse reportStr of + Left errs -> do warn verbosity $ "Errors: " ++ errs -- FIXME + Right report' -> + do info verbosity $ "Uploading report for " ++ display (BuildReport.package report') + browse $ BuildReport.uploadReports (remoteRepoURI remoteRepo) [(report', Just buildLog)] auth + return () + Right{} -> return () + where + targetRepoURI = remoteRepoURI $ last [ remoteRepo | Left remoteRepo <- map repoKind repos ] --FIXME: better error message when no repos are given + +check :: Verbosity -> [FilePath] -> IO () +check verbosity paths = do + flip mapM_ paths $ \path -> do + notice verbosity $ "Checking " ++ path ++ "... " + handlePackage verbosity checkURI (return ()) path + +handlePackage :: Verbosity -> URI -> BrowserAction (HandleStream String) () + -> FilePath -> IO () +handlePackage verbosity uri auth path = + do req <- mkRequest uri path + p <- proxy verbosity + debug verbosity $ "\n" ++ show req + (_,resp) <- browse $ do + setProxy p + setErrHandler (warn verbosity . ("http error: "++)) + setOutHandler (debug verbosity) + auth + setAuthorityGen (\_ _ -> return Nothing) + request req + debug verbosity $ show resp + case rspCode resp of + (2,0,0) -> do notice verbosity "Ok" + (x,y,z) -> do notice verbosity $ "Error: " ++ path ++ ": " + ++ map intToDigit [x,y,z] ++ " " + ++ rspReason resp + case findHeader HdrContentType resp of + Just contenttype + | takeWhile (/= ';') contenttype == "text/plain" + -> notice verbosity $ rspBody resp + _ -> debug verbosity $ rspBody resp + +mkRequest :: URI -> FilePath -> IO (Request String) +mkRequest uri path = + do pkg <- readBinaryFile path + boundary <- genBoundary + let body = printMultiPart boundary (mkFormData path pkg) + return $ Request { + rqURI = uri, + rqMethod = POST, + rqHeaders = [Header HdrContentType ("multipart/form-data; boundary="++boundary), + Header HdrContentLength (show (length body)), + Header HdrAccept ("text/plain")], + rqBody = body + } + +readBinaryFile :: FilePath -> IO String +readBinaryFile path = openBinaryFile path ReadMode >>= hGetContents + +genBoundary :: IO String +genBoundary = do i <- randomRIO (0x10000000000000,0xFFFFFFFFFFFFFF) :: IO Integer + return $ showHex i "" + +mkFormData :: FilePath -> String -> [BodyPart] +mkFormData path pkg = + -- yes, web browsers are that stupid (re quoting) + [BodyPart [Header hdrContentDisposition $ + "form-data; name=package; filename=\""++takeFileName path++"\"", + Header HdrContentType "application/x-gzip"] + pkg] + +hdrContentDisposition :: HeaderName +hdrContentDisposition = HdrCustom "Content-disposition" + +-- * Multipart, partly stolen from the cgi package. + +data BodyPart = BodyPart [Header] String + +printMultiPart :: String -> [BodyPart] -> String +printMultiPart boundary xs = + concatMap (printBodyPart boundary) xs ++ crlf ++ "--" ++ boundary ++ "--" ++ crlf + +printBodyPart :: String -> BodyPart -> String +printBodyPart boundary (BodyPart hs c) = crlf ++ "--" ++ boundary ++ crlf ++ concatMap show hs ++ crlf ++ c + +crlf :: String +crlf = "\r\n" diff --git a/Distribution/Client/Utils.hs b/Distribution/Client/Utils.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Utils.hs @@ -0,0 +1,60 @@ +module Distribution.Client.Utils where + +import Data.List + ( sortBy, groupBy ) +import System.Directory + ( doesFileExist, getModificationTime + , getCurrentDirectory, setCurrentDirectory ) +import qualified Control.Exception as Exception + ( finally ) + +-- | Generic merging utility. For sorted input lists this is a full outer join. +-- +-- * The result list never contains @(Nothing, Nothing)@. +-- +mergeBy :: (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b] +mergeBy cmp = merge + where + merge [] ys = [ OnlyInRight y | y <- ys] + merge xs [] = [ OnlyInLeft x | x <- xs] + merge (x:xs) (y:ys) = + case x `cmp` y of + GT -> OnlyInRight y : merge (x:xs) ys + EQ -> InBoth x y : merge xs ys + LT -> OnlyInLeft x : merge xs (y:ys) + +data MergeResult a b = OnlyInLeft a | InBoth a b | OnlyInRight b + +duplicates :: Ord a => [a] -> [[a]] +duplicates = duplicatesBy compare + +duplicatesBy :: (a -> a -> Ordering) -> [a] -> [[a]] +duplicatesBy cmp = filter moreThanOne . groupBy eq . sortBy cmp + where + eq a b = case cmp a b of + EQ -> True + _ -> False + 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) + +-- | Executes the action in the specified directory. +inDir :: Maybe FilePath -> IO () -> IO () +inDir Nothing m = m +inDir (Just d) m = do + old <- getCurrentDirectory + setCurrentDirectory d + m `Exception.finally` setCurrentDirectory old diff --git a/Distribution/Client/Win32SelfUpgrade.hs b/Distribution/Client/Win32SelfUpgrade.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Win32SelfUpgrade.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} +{-# OPTIONS_NHC98 -cpp #-} +{-# OPTIONS_JHC -fcpp -fffi #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Win32SelfUpgrade +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Support for self-upgrading executables on Windows platforms. +----------------------------------------------------------------------------- +module Distribution.Client.Win32SelfUpgrade ( +-- * Explanation +-- +-- | Windows inherited a design choice from DOS that while initially innocuous +-- has rather unfortunate consequences. It maintains the invariant that every +-- open file has a corresponding name on disk. One positive consequence of this +-- is that an executable can always find it's own executable file. The downside +-- is that a program cannot be deleted or upgraded while it is running without +-- hideous workarounds. This module implements one such hideous workaround. +-- +-- The basic idea is: +-- +-- * Move our own exe file to a new name +-- * Copy a new exe file to the previous name +-- * Run the new exe file, passing our own pid and new path +-- * Wait for the new process to start +-- * Close the new exe file +-- * Exit old process +-- +-- Then in the new process: +-- +-- * Inform the old process that we've started +-- * Wait for the old process to die +-- * Delete the old exe file +-- * Exit new process +-- + + possibleSelfUpgrade, + deleteOldExeFile, + ) where + +#if mingw32_HOST_OS || mingw32_TARGET_OS + +import qualified System.Win32 as Win32 +import qualified System.Win32.DLL as Win32 +import System.Win32 (DWORD, BOOL, HANDLE, LPCTSTR) +import Foreign.Ptr (Ptr, nullPtr) +import System.Process (runProcess) +import System.Directory (canonicalizePath) +import System.FilePath (takeBaseName, replaceBaseName, equalFilePath) + +import Distribution.Verbosity as Verbosity (Verbosity, showForCabal) +import Distribution.Simple.Utils (debug, info) + +import Prelude hiding (log) + +-- | If one of the given files is our own exe file then we arrange things such +-- that the nested action can replace our own exe file. +-- +-- We require that the new process accepts a command line invocation that +-- calls 'deleteOldExeFile', passing in the pid and exe file. +-- +possibleSelfUpgrade :: Verbosity + -> [FilePath] + -> IO a -> IO a +possibleSelfUpgrade verbosity newPaths action = do + dstPath <- canonicalizePath =<< Win32.getModuleFileName Win32.nullHANDLE + + newPaths' <- mapM canonicalizePath newPaths + let doingSelfUpgrade = any (equalFilePath dstPath) newPaths' + + if not doingSelfUpgrade + then action + else do + info verbosity $ "cabal-install does the replace-own-exe-file dance..." + tmpPath <- moveOurExeOutOfTheWay verbosity + result <- action + scheduleOurDemise verbosity dstPath tmpPath + (\pid path -> ["win32selfupgrade", pid, path + ,"--verbose=" ++ Verbosity.showForCabal verbosity]) + return result + +-- | The name of a Win32 Event object that we use to synchronise between the +-- old and new processes. We need to synchronise to make sure that the old +-- process has not yet terminated by the time the new one starts up and looks +-- for the old process. Otherwise the old one might have already terminated +-- and we could not wait on it terminating reliably (eg the pid might get +-- re-used). +-- +syncEventName :: String +syncEventName = "Local\\cabal-install-upgrade" + +-- | The first part of allowing our exe file to be replaced is to move the +-- existing exe file out of the way. Although we cannot delete our exe file +-- while we're still running, fortunately we can rename it, at least within +-- the same directory. +-- +moveOurExeOutOfTheWay :: Verbosity -> IO FilePath +moveOurExeOutOfTheWay verbosity = do + ourPID <- getCurrentProcessId + dstPath <- Win32.getModuleFileName Win32.nullHANDLE + + let tmpPath = replaceBaseName dstPath (takeBaseName dstPath ++ show ourPID) + + debug verbosity $ "moving " ++ dstPath ++ " to " ++ tmpPath + Win32.moveFile dstPath tmpPath + return tmpPath + +-- | Assuming we've now installed the new exe file in the right place, we +-- launch it and ask it to delete our exe file when we eventually terminate. +-- +scheduleOurDemise :: Verbosity -> FilePath -> FilePath + -> (String -> FilePath -> [String]) -> IO () +scheduleOurDemise verbosity dstPath tmpPath mkArgs = do + ourPID <- getCurrentProcessId + event <- createEvent syncEventName + + let args = mkArgs (show ourPID) tmpPath + log $ "launching child " ++ unwords (dstPath : map show args) + 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 + log $ "child started ok" + + where + log msg = debug verbosity ("Win32Reinstall.parent: " ++ msg) + +-- | Assuming we're now in the new child process, we've been asked by the old +-- process to wait for it to terminate and then we can remove the old exe file +-- that it renamted itself to. +-- +deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO () +deleteOldExeFile verbosity oldPID tmpPath = do + log $ "process started. Will delete exe file of process " + ++ show oldPID ++ " at path " ++ tmpPath + + log $ "getting handle of parent process " ++ show oldPID + oldPHANDLE <- Win32.openProcess Win32.sYNCHORNIZE False (fromIntegral oldPID) + + log $ "synchronising with parent" + event <- openEvent syncEventName + setEvent event + + log $ "waiting for parent process to terminate" + waitForSingleObject oldPHANDLE Win32.iNFINITE + log $ "parent process terminated" + + log $ "deleting parent's old .exe file" + Win32.deleteFile tmpPath + + where + log msg = debug verbosity ("Win32Reinstall.child: " ++ msg) + +------------------------ +-- Win32 foreign imports +-- + +-- A bunch of functions sadly not provided by the Win32 package. + +foreign import stdcall unsafe "windows.h GetCurrentProcessId" + getCurrentProcessId :: IO DWORD + +foreign import stdcall unsafe "windows.h WaitForSingleObject" + waitForSingleObject_ :: HANDLE -> DWORD -> IO DWORD + +waitForSingleObject :: HANDLE -> DWORD -> IO () +waitForSingleObject handle timeout = + Win32.failIf_ bad "WaitForSingleObject" $ + waitForSingleObject_ handle timeout + where + bad result = not (result == 0 || result == wAIT_TIMEOUT) + wAIT_TIMEOUT = 0x00000102 + +foreign import stdcall unsafe "windows.h CreateEventW" + createEvent_ :: Ptr () -> BOOL -> BOOL -> LPCTSTR -> IO HANDLE + +createEvent :: String -> IO HANDLE +createEvent name = do + Win32.failIfNull "CreateEvent" $ + Win32.withTString name $ + createEvent_ nullPtr False False + +foreign import stdcall unsafe "windows.h OpenEventW" + openEvent_ :: DWORD -> BOOL -> LPCTSTR -> IO HANDLE + +openEvent :: String -> IO HANDLE +openEvent name = do + Win32.failIfNull "OpenEvent" $ + Win32.withTString name $ + openEvent_ eVENT_MODIFY_STATE False + where + eVENT_MODIFY_STATE :: DWORD + eVENT_MODIFY_STATE = 0x0002 + +foreign import stdcall unsafe "windows.h SetEvent" + setEvent_ :: HANDLE -> IO BOOL + +setEvent :: HANDLE -> IO () +setEvent handle = + Win32.failIfFalse_ "SetEvent" $ + setEvent_ handle + +#else + +import Distribution.Verbosity (Verbosity) +import Distribution.Simple.Utils (die) + +possibleSelfUpgrade :: Verbosity + -> [FilePath] + -> IO a -> IO a +possibleSelfUpgrade _ _ action = action + +deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO () +deleteOldExeFile _ _ _ = die "win32selfupgrade not needed except on win32" + +#endif diff --git a/Distribution/Client/World.hs b/Distribution/Client/World.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/World.hs @@ -0,0 +1,173 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.World +-- Copyright : (c) Peter Robinson 2009 +-- License : BSD-like +-- +-- Maintainer : thaldyron@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Interface to the world-file that contains a list of explicitly +-- requested packages. Meant to be imported qualified. +-- +-- A world file entry stores the package-name, package-version, and +-- user flags. +-- For example, the entry generated by +-- # cabal install stm-io-hooks --flags="-debug" +-- looks like this: +-- # stm-io-hooks -any --flags="-debug" +-- To rebuild/upgrade the packages in world (e.g. when updating the compiler) +-- use +-- # cabal install world +-- +----------------------------------------------------------------------------- +module Distribution.Client.World ( + WorldPkgInfo(..), + insert, + delete, + getContents, + ) where + +import Distribution.Package + ( Dependency(..) ) +import Distribution.PackageDescription + ( FlagAssignment, FlagName(FlagName) ) +import Distribution.Verbosity + ( Verbosity ) +import Distribution.Simple.Utils + ( die, info, chattyTry, writeFileAtomic ) +import Distribution.Text + ( Text(..), display, simpleParse ) +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp +import Text.PrettyPrint ( (<>), (<+>) ) + + +import Data.Char as Char + +import Data.List + ( unionBy, deleteFirstsBy, nubBy ) +import Data.Maybe + ( isJust, fromJust ) +import System.IO.Error + ( isDoesNotExistError ) +import qualified Data.ByteString.Lazy.Char8 as B +import Prelude hiding (getContents) + + +data WorldPkgInfo = WorldPkgInfo Dependency FlagAssignment + deriving (Show,Eq) + +-- | Adds packages to the world file; creates the file if it doesn't +-- exist yet. Version constraints and flag assignments for a package are +-- updated if already present. IO errors are non-fatal. +insert :: Verbosity -> FilePath -> [WorldPkgInfo] -> IO () +insert = modifyWorld $ unionBy equalUDep + +-- | Removes packages from the world file. +-- Note: Currently unused as there is no mechanism in Cabal (yet) to +-- handle uninstalls. IO errors are non-fatal. +delete :: Verbosity -> FilePath -> [WorldPkgInfo] -> IO () +delete = modifyWorld $ flip (deleteFirstsBy equalUDep) + +-- | WorldPkgInfo values are considered equal if they refer to +-- the same package, i.e., we don't care about differing versions or flags. +equalUDep :: WorldPkgInfo -> WorldPkgInfo -> Bool +equalUDep (WorldPkgInfo (Dependency pkg1 _) _) + (WorldPkgInfo (Dependency pkg2 _) _) = pkg1 == pkg2 + +-- | Modifies the world file by applying an update-function ('unionBy' +-- for 'insert', 'deleteFirstsBy' for 'delete') to the given list of +-- packages. IO errors are considered non-fatal. +modifyWorld :: ([WorldPkgInfo] -> [WorldPkgInfo] + -> [WorldPkgInfo]) + -- ^ Function that defines how + -- the list of user packages are merged with + -- existing world packages. + -> Verbosity + -> FilePath -- ^ Location of the world file + -> [WorldPkgInfo] -- ^ list of user supplied packages + -> IO () +modifyWorld _ _ _ [] = return () +modifyWorld f verbosity world pkgs = + chattyTry "Error while updating world-file. " $ do + pkgsOldWorld <- getContents world + -- Filter out packages that are not in the world file: + let pkgsNewWorld = nubBy equalUDep $ f pkgs pkgsOldWorld + -- 'Dependency' is not an Ord instance, so we need to check for + -- equivalence the awkward way: + if not (all (`elem` pkgsOldWorld) pkgsNewWorld && + all (`elem` pkgsNewWorld) pkgsOldWorld) + then do + info verbosity "Updating world file..." + writeFileAtomic world $ unlines + [ (display pkg) | pkg <- pkgsNewWorld] + else + info verbosity "World file is already up to date." + + +-- | Returns the content of the world file as a list +getContents :: FilePath -> IO [WorldPkgInfo] +getContents world = do + content <- safelyReadFile world + let result = map simpleParse (lines $ B.unpack content) + if all isJust result + then return $ map fromJust result + else die "Could not parse world file." + where + safelyReadFile :: FilePath -> IO B.ByteString + safelyReadFile file = B.readFile file `catch` handler + where + handler e | isDoesNotExistError e = return B.empty + | otherwise = ioError e + + +instance Text WorldPkgInfo where + disp (WorldPkgInfo dep flags) = disp dep <+> dispFlags flags + where + dispFlags [] = Disp.empty + dispFlags fs = Disp.text "--flags=" + <> Disp.doubleQuotes (flagAssToDoc fs) + flagAssToDoc = foldr (\(FlagName fname,val) flagAssDoc -> + (if not val then Disp.char '-' + else Disp.empty) + Disp.<> Disp.text fname + Disp.<+> flagAssDoc) + Disp.empty + parse = do + dep <- parse + Parse.skipSpaces + flagAss <- Parse.option [] parseFlagAssignment + return $ WorldPkgInfo dep flagAss + where + parseFlagAssignment :: Parse.ReadP r FlagAssignment + parseFlagAssignment = do + _ <- Parse.string "--flags" + Parse.skipSpaces + _ <- Parse.char '=' + Parse.skipSpaces + inDoubleQuotes $ Parse.many1 flag + where + inDoubleQuotes :: Parse.ReadP r a -> Parse.ReadP r a + inDoubleQuotes = Parse.between (Parse.char '"') (Parse.char '"') + + flag = do + Parse.skipSpaces + val <- negative Parse.+++ positive + name <- ident + Parse.skipSpaces + return (FlagName name,val) + negative = do + _ <- Parse.char '-' + return False + positive = return True + + ident :: Parse.ReadP r String + ident = do + -- First character must be a letter/digit to avoid flags + -- like "+-debug": + c <- Parse.satisfy Char.isAlphaNum + cs <- Parse.munch (\ch -> Char.isAlphaNum ch || ch == '_' + || ch == '-') + return (c:cs) diff --git a/Distribution/Compat/Exception.hs b/Distribution/Compat/Exception.hs new file mode 100644 --- /dev/null +++ b/Distribution/Compat/Exception.hs @@ -0,0 +1,56 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/Distribution/Compat/FilePerms.hs @@ -0,0 +1,40 @@ +{-# 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/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,403 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Main +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Entry point to the default cabal-install front-end. +----------------------------------------------------------------------------- + +module Main (main) where + +import Distribution.Client.Setup + ( GlobalFlags(..), globalCommand, globalRepos + , ConfigFlags(..) + , ConfigExFlags(..), configureExCommand + , InstallFlags(..), defaultInstallFlags + , installCommand, upgradeCommand + , FetchFlags(..), fetchCommand + , checkCommand + , updateCommand + , ListFlags(..), listCommand + , InfoFlags(..), infoCommand + , UploadFlags(..), uploadCommand + , ReportFlags(..), reportCommand + , InitFlags, initCommand + , reportCommand + , unpackCommand, UnpackFlags(..) ) +import Distribution.Simple.Setup + ( BuildFlags(..), buildCommand + , HaddockFlags(..), haddockCommand + , HscolourFlags(..), hscolourCommand + , CopyFlags(..), copyCommand + , RegisterFlags(..), registerCommand + , CleanFlags(..), cleanCommand + , SDistFlags(..), sdistCommand + , TestFlags(..), testCommand + , Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe ) + +import Distribution.Client.SetupWrapper + ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) +import Distribution.Client.Config + ( SavedConfig(..), loadConfig, defaultConfigFile ) +import Distribution.Client.Targets + ( readUserTargets ) + +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.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 qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade + +import Distribution.Simple.Compiler + ( Compiler, PackageDB(..), PackageDBStack ) +import Distribution.Simple.Program + ( ProgramConfiguration, defaultProgramConfiguration ) +import Distribution.Simple.Command +import Distribution.Simple.Configure (configCompilerAux) +import Distribution.Simple.Utils + ( cabalVersion, die, topHandler, intercalate ) +import Distribution.Text + ( display ) +import Distribution.Verbosity as Verbosity + ( Verbosity, normal, intToVerbosity, lessVerbose ) +import qualified Paths_cabal_install_bundle (version) + +import System.Environment (getArgs, getProgName) +import System.Exit (exitFailure) +import System.FilePath (splitExtension, takeExtension) +import System.Directory (doesFileExist) +import Data.List (intersperse) +import Data.Maybe (fromMaybe) +import Data.Monoid (Monoid(..)) +import Control.Monad (unless) + +-- | Entry point +-- +main :: IO () +main = getArgs >>= mainWorker + +mainWorker :: [String] -> IO () +mainWorker ("win32selfupgrade":args) = win32SelfUpgradeAction args +mainWorker args = topHandler $ + case commandsRun globalCommand commands args of + CommandHelp help -> printGlobalHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo (globalflags, commandParse) -> + case commandParse of + _ | fromFlag (globalVersion globalflags) -> printVersion + | fromFlag (globalNumericVersion globalflags) -> printNumericVersion + CommandHelp help -> printCommandHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo action -> action globalflags + + where + printCommandHelp help = do + pname <- getProgName + putStr (help pname) + printGlobalHelp help = do + pname <- getProgName + configFile <- defaultConfigFile + putStr (help pname) + putStr $ "\nYou can edit the cabal configuration file to set defaults:\n" + ++ " " ++ configFile ++ "\n" + printOptionsList = putStr . unlines + printErrors errs = die $ concat (intersperse "\n" errs) + printNumericVersion = putStrLn $ display Paths_cabal_install_bundle.version + printVersion = putStrLn $ "cabal-install version " + ++ display Paths_cabal_install_bundle.version + ++ "\nusing version " + ++ display cabalVersion + ++ " of the Cabal library " + + commands = + [installCommand `commandAddAction` installAction + ,updateCommand `commandAddAction` updateAction + ,listCommand `commandAddAction` listAction + ,infoCommand `commandAddAction` infoAction + ,fetchCommand `commandAddAction` fetchAction + ,unpackCommand `commandAddAction` unpackAction + ,checkCommand `commandAddAction` checkAction + ,sdistCommand `commandAddAction` sdistAction + ,uploadCommand `commandAddAction` uploadAction + ,reportCommand `commandAddAction` reportAction + ,initCommand `commandAddAction` initAction + ,configureExCommand `commandAddAction` configureAction + ,wrapperAction (buildCommand defaultProgramConfiguration) + buildVerbosity buildDistPref + ,wrapperAction copyCommand + copyVerbosity copyDistPref + ,wrapperAction haddockCommand + haddockVerbosity haddockDistPref + ,wrapperAction cleanCommand + cleanVerbosity cleanDistPref + ,wrapperAction hscolourCommand + hscolourVerbosity hscolourDistPref + ,wrapperAction registerCommand + regVerbosity regDistPref + ,wrapperAction testCommand + testVerbosity testDistPref + ,upgradeCommand `commandAddAction` upgradeAction + ] + +wrapperAction :: Monoid flags + => CommandUI flags + -> (flags -> Flag Verbosity) + -> (flags -> Flag String) + -> Command (GlobalFlags -> IO ()) +wrapperAction command verbosityFlag distPrefFlag = + commandAddAction command + { commandDefaultFlags = mempty } $ \flags extraArgs _globalFlags -> do + let verbosity = fromFlagOrDefault normal (verbosityFlag flags) + setupScriptOptions = defaultSetupScriptOptions { + useDistPref = fromFlagOrDefault + (useDistPref defaultSetupScriptOptions) + (distPrefFlag flags) + } + setupWrapper verbosity setupScriptOptions Nothing + command (const flags) extraArgs + +configureAction :: (ConfigFlags, ConfigExFlags) + -> [String] -> GlobalFlags -> IO () +configureAction (configFlags, configExFlags) extraArgs globalFlags = do + let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + config <- loadConfig verbosity (globalConfigFile 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 + +installAction :: (ConfigFlags, ConfigExFlags, InstallFlags) + -> [String] -> GlobalFlags -> IO () +installAction (configFlags, _, installFlags) _ _globalFlags + | fromFlagOrDefault False (installOnly installFlags) + = let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + in setupWrapper verbosity defaultSetupScriptOptions Nothing + installCommand (const mempty) [] + +installAction (configFlags, configExFlags, installFlags) + 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' + install verbosity + (configPackageDB' configFlags') (globalRepos globalFlags') + comp conf globalFlags' configFlags' configExFlags' installFlags' + targets + +listAction :: ListFlags -> [String] -> GlobalFlags -> IO () +listAction listFlags extraArgs globalFlags = do + let verbosity = fromFlag (listVerbosity listFlags) + config <- loadConfig verbosity (globalConfigFile globalFlags) mempty + let configFlags = savedConfigureFlags config + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, conf) <- configCompilerAux' configFlags + list verbosity + (configPackageDB' configFlags) + (globalRepos globalFlags') + comp + conf + listFlags + extraArgs + +infoAction :: InfoFlags -> [String] -> GlobalFlags -> IO () +infoAction infoFlags extraArgs globalFlags = do + let verbosity = fromFlag (infoVerbosity infoFlags) + targets <- readUserTargets verbosity extraArgs + config <- loadConfig verbosity (globalConfigFile globalFlags) mempty + let configFlags = savedConfigureFlags config + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, conf) <- configCompilerAux configFlags + info verbosity + (configPackageDB' configFlags) + (globalRepos globalFlags') + comp + conf + globalFlags' + infoFlags + targets + +updateAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO () +updateAction verbosityFlag extraArgs globalFlags = do + unless (null extraArgs) $ do + die $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs + let verbosity = fromFlag verbosityFlag + config <- loadConfig verbosity (globalConfigFile globalFlags) mempty + let globalFlags' = savedGlobalFlags config `mappend` globalFlags + update verbosity (globalRepos globalFlags') + +upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags) + -> [String] -> GlobalFlags -> IO () +upgradeAction (configFlags, configExFlags, installFlags) + 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' + targets + +fetchAction :: FetchFlags -> [String] -> GlobalFlags -> IO () +fetchAction fetchFlags extraArgs globalFlags = do + let verbosity = fromFlag (fetchVerbosity fetchFlags) + targets <- readUserTargets verbosity extraArgs + config <- loadConfig verbosity (globalConfigFile globalFlags) mempty + let configFlags = savedConfigureFlags config + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, conf) <- configCompilerAux' configFlags + fetch verbosity + (configPackageDB' configFlags) (globalRepos globalFlags') + comp conf globalFlags' fetchFlags + targets + +uploadAction :: UploadFlags -> [String] -> GlobalFlags -> IO () +uploadAction uploadFlags extraArgs globalFlags = do + let verbosity = fromFlag (uploadVerbosity uploadFlags) + config <- loadConfig verbosity (globalConfigFile globalFlags) mempty + let uploadFlags' = savedUploadFlags config `mappend` uploadFlags + globalFlags' = savedGlobalFlags config `mappend` globalFlags + tarfiles = extraArgs + checkTarFiles extraArgs + if fromFlag (uploadCheck uploadFlags') + then Upload.check verbosity tarfiles + else upload verbosity + (globalRepos globalFlags') + (flagToMaybe $ uploadUsername uploadFlags') + (flagToMaybe $ uploadPassword uploadFlags') + tarfiles + where + checkTarFiles tarfiles + | null tarfiles + = die "the 'upload' command expects one or more .tar.gz packages." + | not (null otherFiles) + = die $ "the 'upload' command expects only .tar.gz packages: " + ++ intercalate ", " otherFiles + | otherwise = sequence_ + [ do exists <- doesFileExist tarfile + unless exists $ die $ "file not found: " ++ tarfile + | tarfile <- tarfiles ] + + where otherFiles = filter (not . isTarGzFile) tarfiles + isTarGzFile file = case splitExtension file of + (file', ".gz") -> takeExtension file' == ".tar" + _ -> False + +checkAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO () +checkAction verbosityFlag extraArgs _globalFlags = do + unless (null extraArgs) $ do + die $ "'check' doesn't take any extra arguments: " ++ unwords extraArgs + allOk <- Check.check (fromFlag verbosityFlag) + unless allOk exitFailure + + +sdistAction :: SDistFlags -> [String] -> GlobalFlags -> IO () +sdistAction sflags extraArgs _globalFlags = do + unless (null extraArgs) $ do + die $ "'sdist' doesn't take any extra arguments: " ++ unwords extraArgs + sdist sflags + +reportAction :: ReportFlags -> [String] -> GlobalFlags -> IO () +reportAction reportFlags extraArgs globalFlags = do + unless (null extraArgs) $ do + die $ "'report' doesn't take any extra arguments: " ++ unwords extraArgs + + let verbosity = fromFlag (reportVerbosity reportFlags) + config <- loadConfig verbosity (globalConfigFile globalFlags) mempty + let globalFlags' = savedGlobalFlags config `mappend` globalFlags + reportFlags' = savedReportFlags config `mappend` reportFlags + + Upload.report verbosity (globalRepos globalFlags') + (flagToMaybe $ reportUsername reportFlags') + (flagToMaybe $ reportPassword reportFlags') + +unpackAction :: UnpackFlags -> [String] -> GlobalFlags -> IO () +unpackAction unpackFlags extraArgs globalFlags = do + let verbosity = fromFlag (unpackVerbosity unpackFlags) + targets <- readUserTargets verbosity extraArgs + config <- loadConfig verbosity (globalConfigFile globalFlags) mempty + let globalFlags' = savedGlobalFlags config `mappend` globalFlags + unpack verbosity + (globalRepos (savedGlobalFlags config)) + globalFlags' + unpackFlags + targets + +initAction :: InitFlags -> [String] -> GlobalFlags -> IO () +initAction flags _extraArgs _globalFlags = do + initCabal flags + +-- | 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 () + +-- +-- Utils (transitionary) +-- + +-- | Currently the user interface specifies the package dbs to use with just a +-- single valued option, a 'PackageDB'. However internally we represent the +-- stack of 'PackageDB's explictly as a list. This function converts encodes +-- the package db stack implicit in a single packagedb. +-- +-- TODO: sort this out, make it consistent with the command line UI +implicitPackageDbStack :: Bool -> Maybe PackageDB -> PackageDBStack +implicitPackageDbStack userInstall packageDbFlag + | userInstall = GlobalPackageDB : UserPackageDB : extra + | otherwise = GlobalPackageDB : extra + where + extra = case packageDbFlag of + Just (SpecificPackageDB db) -> [SpecificPackageDB db] + _ -> [] + +configPackageDB' :: ConfigFlags -> PackageDBStack +configPackageDB' cfg = + implicitPackageDbStack userInstall (flagToMaybe (configPackageDB cfg)) + where + userInstall = fromFlagOrDefault True (configUserInstall cfg) + +configCompilerAux' :: ConfigFlags + -> IO (Compiler, ProgramConfiguration) +configCompilerAux' configFlags = + configCompilerAux configFlags + --FIXME: make configCompilerAux use a sensible verbosity + { configVerbosity = fmap lessVerbose (configVerbosity configFlags) } diff --git a/Network.hs b/Network.hs new file mode 100644 --- /dev/null +++ b/Network.hs @@ -0,0 +1,468 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Network +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/network/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- The "Network" interface is a \"higher-level\" interface to +-- networking facilities, and it is recommended unless you need the +-- lower-level interface in "Network.Socket". +-- +----------------------------------------------------------------------------- + +#include "HsNetworkConfig.h" + +#ifdef HAVE_GETADDRINFO +-- Use IPv6-capable function definitions if the OS supports it. +#define IPV6_SOCKET_SUPPORT 1 +#endif + +module Network + ( + -- * Basic data types + Socket + , PortID(..) + , HostName + , PortNumber + + -- * Initialisation + , withSocketsDo + + -- * Server-side connections + , listenOn + , accept + , sClose + + -- * Client-side connections + , connectTo + + -- * Simple sending and receiving + {-$sendrecv-} + , sendTo + , recvFrom + + -- * Miscellaneous + , socketPort + + -- * Networking Issues + -- ** Buffering + {-$buffering-} + + -- ** Improving I\/O Performance over sockets + {-$performance-} + + -- ** @SIGPIPE@ + {-$sigpipe-} + ) where + +import Control.Monad (liftM) +import Data.Maybe (fromJust) +import Network.BSD +import Network.Socket hiding (accept, socketPort, recvFrom, sendTo, PortNumber) +import qualified Network.Socket as Socket (accept) +import System.IO +import Prelude +import qualified Control.Exception as Exception + +-- --------------------------------------------------------------------------- +-- High Level ``Setup'' functions + +-- If the @PortID@ specifies a unix family socket and the @Hostname@ +-- differs from that returned by @getHostname@ then an error is +-- raised. Alternatively an empty string may be given to @connectTo@ +-- signalling that the current hostname applies. + +data PortID = + Service String -- Service Name eg "ftp" + | PortNumber PortNumber -- User defined Port Number +#if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) && !defined(_WIN32) + | UnixSocket String -- Unix family socket in file system +#endif + +-- | Calling 'connectTo' creates a client side socket which is +-- connected to the given host and port. The Protocol and socket type is +-- derived from the given port identifier. If a port number is given +-- then the result is always an internet family 'Stream' socket. + +connectTo :: HostName -- Hostname + -> PortID -- Port Identifier + -> IO Handle -- Connected Socket + +#if defined(IPV6_SOCKET_SUPPORT) +-- IPv6 and IPv4. + +connectTo hostname (Service serv) = connect' hostname serv + +connectTo hostname (PortNumber port) = connect' hostname (show port) +#else +-- IPv4 only. + +connectTo hostname (Service serv) = do + proto <- getProtocolNumber "tcp" + bracketOnError + (socket AF_INET Stream proto) + (sClose) -- only done if there's an error + (\sock -> do + port <- getServicePortNumber serv + he <- getHostByName hostname + connect sock (SockAddrInet port (hostAddress he)) + socketToHandle sock ReadWriteMode + ) + +connectTo hostname (PortNumber port) = do + proto <- getProtocolNumber "tcp" + bracketOnError + (socket AF_INET Stream proto) + (sClose) -- only done if there's an error + (\sock -> do + he <- getHostByName hostname + connect sock (SockAddrInet port (hostAddress he)) + socketToHandle sock ReadWriteMode + ) +#endif + +#if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) && !defined(_WIN32) +connectTo _ (UnixSocket path) = do + bracketOnError + (socket AF_UNIX Stream 0) + (sClose) + (\sock -> do + connect sock (SockAddrUnix path) + socketToHandle sock ReadWriteMode + ) +#endif + +#if defined(IPV6_SOCKET_SUPPORT) +connect' :: HostName -> ServiceName -> IO Handle + +connect' host serv = do + proto <- getProtocolNumber "tcp" + let hints = defaultHints { addrFlags = [AI_ADDRCONFIG] + , addrProtocol = proto + , addrSocketType = Stream } + addrs <- getAddrInfo (Just hints) (Just host) (Just serv) + firstSuccessful $ map tryToConnect addrs + where + tryToConnect addr = + bracketOnError + (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)) + (sClose) -- only done if there's an error + (\sock -> do + connect sock (addrAddress addr) + socketToHandle sock ReadWriteMode + ) +#endif + +-- | Creates the server side socket which has been bound to the +-- specified port. +-- +-- NOTE: To avoid the \"Address already in use\" +-- problems popped up several times on the GHC-Users mailing list we +-- set the 'ReuseAddr' socket option on the listening socket. If you +-- don't want this behaviour, please use the lower level +-- 'Network.Socket.listen' instead. +-- +-- If available, the 'IPv6Only' socket option is set to 0 +-- so that both IPv4 and IPv6 can be accepted with this socket. + +listenOn :: PortID -- ^ Port Identifier + -> IO Socket -- ^ Connected Socket + +#if defined(IPV6_SOCKET_SUPPORT) +-- IPv6 and IPv4. + +listenOn (Service serv) = listen' serv + +listenOn (PortNumber port) = listen' (show port) +#else +-- IPv4 only. + +listenOn (Service serv) = do + proto <- getProtocolNumber "tcp" + bracketOnError + (socket AF_INET Stream proto) + (sClose) + (\sock -> do + port <- getServicePortNumber serv + setSocketOption sock ReuseAddr 1 + bindSocket sock (SockAddrInet port iNADDR_ANY) + listen sock maxListenQueue + return sock + ) + +listenOn (PortNumber port) = do + proto <- getProtocolNumber "tcp" + bracketOnError + (socket AF_INET Stream proto) + (sClose) + (\sock -> do + setSocketOption sock ReuseAddr 1 + bindSocket sock (SockAddrInet port iNADDR_ANY) + listen sock maxListenQueue + return sock + ) +#endif + +#if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) && !defined(_WIN32) +listenOn (UnixSocket path) = + bracketOnError + (socket AF_UNIX Stream 0) + (sClose) + (\sock -> do + setSocketOption sock ReuseAddr 1 + bindSocket sock (SockAddrUnix path) + listen sock maxListenQueue + return sock + ) +#endif + +#if defined(IPV6_SOCKET_SUPPORT) +listen' :: ServiceName -> IO Socket + +listen' serv = do + proto <- getProtocolNumber "tcp" + -- We should probably specify addrFamily = AF_INET6 and the filter + -- code below should be removed. AI_ADDRCONFIG is probably not + -- necessary. But this code is well-tested. So, let's keep it. + let hints = defaultHints { addrFlags = [AI_ADDRCONFIG, AI_PASSIVE] + , addrSocketType = Stream + , addrProtocol = proto } + addrs <- getAddrInfo (Just hints) Nothing (Just serv) + -- Choose an IPv6 socket if exists. This ensures the socket can + -- handle both IPv4 and IPv6 if v6only is false. + let addrs' = filter (\x -> addrFamily x == AF_INET6) addrs + addr = if null addrs' then head addrs else head addrs' + bracketOnError + (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)) + (sClose) + (\sock -> do + setSocketOption sock ReuseAddr 1 + bindSocket sock (addrAddress addr) + listen sock maxListenQueue + return sock + ) +#endif + +-- ----------------------------------------------------------------------------- +-- accept + +-- | Accept a connection on a socket created by 'listenOn'. Normal +-- I\/O operations (see "System.IO") can be used on the 'Handle' +-- returned to communicate with the client. +-- Notice that although you can pass any Socket to Network.accept, +-- only sockets of either AF_UNIX, AF_INET, or AF_INET6 will work +-- (this shouldn't be a problem, though). When using AF_UNIX, HostName +-- will be set to the path of the socket and PortNumber to -1. +-- +accept :: Socket -- ^ Listening Socket + -> IO (Handle, + HostName, + PortNumber) -- ^ Triple of: read\/write 'Handle' for + -- communicating with the client, + -- the 'HostName' of the peer socket, and + -- the 'PortNumber' of the remote connection. +accept sock@(MkSocket _ AF_INET _ _ _) = do + ~(sock', (SockAddrInet port haddr)) <- Socket.accept sock + peer <- catchIO + (do + (HostEntry peer _ _ _) <- getHostByAddr AF_INET haddr + return peer + ) + (\_e -> inet_ntoa haddr) + -- if getHostByName fails, we fall back to the IP address + handle <- socketToHandle sock' ReadWriteMode + return (handle, peer, port) +#if defined(IPV6_SOCKET_SUPPORT) +accept sock@(MkSocket _ AF_INET6 _ _ _) = do + (sock', addr) <- Socket.accept sock + peer <- catchIO ((fromJust . fst) `liftM` getNameInfo [] True False addr) $ + \_ -> case addr of + SockAddrInet _ a -> inet_ntoa a + SockAddrInet6 _ _ a _ -> return (show a) +# if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) && !defined(_WIN32) + SockAddrUnix a -> return a +# endif + handle <- socketToHandle sock' ReadWriteMode + let port = case addr of + SockAddrInet p _ -> p + SockAddrInet6 p _ _ _ -> p + _ -> -1 + return (handle, peer, port) +#endif +#if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) && !defined(_WIN32) +accept sock@(MkSocket _ AF_UNIX _ _ _) = do + ~(sock', (SockAddrUnix path)) <- Socket.accept sock + handle <- socketToHandle sock' ReadWriteMode + return (handle, path, -1) +#endif +accept (MkSocket _ family _ _ _) = + error $ "Sorry, address family " ++ (show family) ++ " is not supported!" + +-- ----------------------------------------------------------------------------- +-- sendTo/recvFrom + +{-$sendrecv +Send and receive data from\/to the given host and port number. These +should normally only be used where the socket will not be required for +further calls. Also, note that due to the use of 'hGetContents' in 'recvFrom' +the socket will remain open (i.e. not available) even if the function already +returned. Their use is strongly discouraged except for small test-applications +or invocations from the command line. +-} + +sendTo :: HostName -- Hostname + -> PortID -- Port Number + -> String -- Message to send + -> IO () +sendTo h p msg = do + s <- connectTo h p + hPutStr s msg + hClose s + +recvFrom :: HostName -- Hostname + -> PortID -- Port Number + -> IO String -- Received Data + +#if defined(IPV6_SOCKET_SUPPORT) +recvFrom host port = do + proto <- getProtocolNumber "tcp" + let hints = defaultHints { addrFlags = [AI_ADDRCONFIG] + , addrProtocol = proto + , addrSocketType = Stream } + allowed <- map addrAddress `liftM` getAddrInfo (Just hints) (Just host) + Nothing + s <- listenOn port + let waiting = do + (s', addr) <- Socket.accept s + if not (addr `oneOf` allowed) + then sClose s' >> waiting + else socketToHandle s' ReadMode >>= hGetContents + waiting + where + a@(SockAddrInet _ ha) `oneOf` ((SockAddrInet _ hb):bs) + | ha == hb = True + | otherwise = a `oneOf` bs + a@(SockAddrInet6 _ _ ha _) `oneOf` ((SockAddrInet6 _ _ hb _):bs) + | ha == hb = True + | otherwise = a `oneOf` bs + _ `oneOf` _ = False +#else +recvFrom host port = do + ip <- getHostByName host + let ipHs = hostAddresses ip + s <- listenOn port + let + waiting = do + ~(s', SockAddrInet _ haddr) <- Socket.accept s + he <- getHostByAddr AF_INET haddr + if not (any (`elem` ipHs) (hostAddresses he)) + then do + sClose s' + waiting + else do + h <- socketToHandle s' ReadMode + msg <- hGetContents h + return msg + + message <- waiting + return message +#endif + +-- --------------------------------------------------------------------------- +-- Access function returning the port type/id of socket. + +-- | Returns the 'PortID' associated with a given socket. +socketPort :: Socket -> IO PortID +socketPort s = do + sockaddr <- getSocketName s + return (portID sockaddr) + where + portID sa = + case sa of + SockAddrInet port _ -> PortNumber port +#if defined(IPV6_SOCKET_SUPPORT) + SockAddrInet6 port _ _ _ -> PortNumber port +#endif +#if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) && !defined(_WIN32) + SockAddrUnix path -> UnixSocket path +#endif + +-- --------------------------------------------------------------------------- +-- Utils + +-- Like bracket, but only performs the final action if there was an +-- exception raised by the middle bit. +bracketOnError + :: IO a -- ^ computation to run first (\"acquire resource\") + -> (a -> IO b) -- ^ computation to run last (\"release resource\") + -> (a -> IO c) -- ^ computation to run in-between + -> IO c -- returns the value from the in-between computation +#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 606 +bracketOnError before after thing = + Exception.block (do + a <- before + r <- Exception.catch + (Exception.unblock (thing a)) + (\e -> do { after a; Exception.throw e }) + return r + ) +#else +bracketOnError = Exception.bracketOnError +#endif + +----------------------------------------------------------------------------- +-- Extra documentation + +{-$buffering + +The 'Handle' returned by 'connectTo' and 'accept' is block-buffered by +default. For an interactive application you may want to set the +buffering mode on the 'Handle' to +'LineBuffering' or 'NoBuffering', like so: + +> h <- connectTo host port +> hSetBuffering h LineBuffering +-} + +{-$performance + +For really fast I\/O, it might be worth looking at the 'hGetBuf' and +'hPutBuf' family of functions in "System.IO". +-} + +{-$sigpipe + +On Unix, when writing to a socket and the reading end is +closed by the remote client, the program is normally sent a +@SIGPIPE@ signal by the operating system. The +default behaviour when a @SIGPIPE@ is received is +to terminate the program silently, which can be somewhat confusing +if you haven't encountered this before. The solution is to +specify that @SIGPIPE@ is to be ignored, using +the POSIX library: + +> import Posix +> main = do installHandler sigPIPE Ignore Nothing; ... +-} + +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 + +-- Returns the first action from a list which does not throw an exception. +-- If all the actions throw exceptions (and the list of actions is not empty), +-- the last exception is thrown. +firstSuccessful :: [IO a] -> IO a +firstSuccessful [] = error "firstSuccessful: empty list" +firstSuccessful (p:ps) = catchIO p $ \e -> + case ps of + [] -> Exception.throw e + _ -> firstSuccessful ps diff --git a/Network/BSD.hsc b/Network/BSD.hsc new file mode 100644 --- /dev/null +++ b/Network/BSD.hsc @@ -0,0 +1,587 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} +----------------------------------------------------------------------------- +-- | +-- Module : Network.BSD +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/network/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- The "Network.BSD" module defines Haskell bindings to network +-- programming functionality provided by BSD Unix derivatives. +-- +----------------------------------------------------------------------------- + +#include "HsNet.h" + +-- NOTE: ##, we want this interpreted when compiling the .hs, not by hsc2hs. +##include "Typeable.h" + +module Network.BSD + ( + -- * Host names + HostName + , getHostName + + , HostEntry(..) + , getHostByName + , getHostByAddr + , hostAddress + +#if defined(HAVE_GETHOSTENT) && !defined(cygwin32_HOST_OS) && !defined(mingw32_HOST_OS) && !defined(_WIN32) + , getHostEntries + + -- ** Low level functionality + , setHostEntry + , getHostEntry + , endHostEntry +#endif + + -- * Service names + , ServiceEntry(..) + , ServiceName + , getServiceByName + , getServiceByPort + , getServicePortNumber + +#if !defined(cygwin32_HOST_OS) && !defined(mingw32_HOST_OS) && !defined(_WIN32) + , getServiceEntries + + -- ** Low level functionality + , getServiceEntry + , setServiceEntry + , endServiceEntry +#endif + + -- * Protocol names + , ProtocolName + , ProtocolNumber + , ProtocolEntry(..) + , getProtocolByName + , getProtocolByNumber + , getProtocolNumber + , defaultProtocol + +#if !defined(cygwin32_HOST_OS) && !defined(mingw32_HOST_OS) && !defined(_WIN32) + , getProtocolEntries + -- ** Low level functionality + , setProtocolEntry + , getProtocolEntry + , endProtocolEntry +#endif + + -- * Port numbers + , PortNumber + + -- * Network names + , NetworkName + , NetworkAddr + , NetworkEntry(..) + +#if !defined(cygwin32_HOST_OS) && !defined(mingw32_HOST_OS) && !defined(_WIN32) + , getNetworkByName + , getNetworkByAddr + , getNetworkEntries + -- ** Low level functionality + , setNetworkEntry + , getNetworkEntry + , endNetworkEntry +#endif + ) where + +#ifdef __HUGS__ +import Hugs.Prelude (IOException(..), IOErrorType(..)) +#endif +import Network.Socket + +import Control.Concurrent (MVar, newMVar, withMVar) +import Control.Exception (catch) +import Foreign.C.String (CString, peekCString, withCString) +#if defined(HAVE_WINSOCK2_H) && !defined(cygwin32_HOST_OS) +import Foreign.C.Types ( CShort ) +#endif +#if __GLASGOW_HASKELL__ >= 703 +import Foreign.C.Types ( CInt(..), CULong(..), CSize(..) ) +#else +import Foreign.C.Types ( CInt, CULong, CSize ) +#endif +import Foreign.Ptr (Ptr, nullPtr) +import Foreign.Storable (Storable(..)) +import Foreign.Marshal.Array (allocaArray0, peekArray0) +import Foreign.Marshal.Utils (with, fromBool) +import Data.Typeable +import Prelude hiding (catch) +import System.IO.Error (ioeSetErrorString, mkIOError) +import System.IO.Unsafe (unsafePerformIO) + +#ifdef __GLASGOW_HASKELL__ +# if __GLASGOW_HASKELL__ >= 611 +import GHC.IO.Exception +# else +import GHC.IOBase +# endif +#endif + +import Control.Monad (liftM) + +-- --------------------------------------------------------------------------- +-- Basic Types + +type ProtocolName = String + +-- --------------------------------------------------------------------------- +-- Service Database Access + +-- Calling getServiceByName for a given service and protocol returns +-- the systems service entry. This should be used to find the port +-- numbers for standard protocols such as SMTP and FTP. The remaining +-- three functions should be used for browsing the service database +-- sequentially. + +-- Calling setServiceEntry with True indicates that the service +-- database should be left open between calls to getServiceEntry. To +-- close the database a call to endServiceEntry is required. This +-- database file is usually stored in the file /etc/services. + +data ServiceEntry = + ServiceEntry { + serviceName :: ServiceName, -- Official Name + serviceAliases :: [ServiceName], -- aliases + servicePort :: PortNumber, -- Port Number ( network byte order ) + serviceProtocol :: ProtocolName -- Protocol + } deriving (Show, Typeable) + +instance Storable ServiceEntry where + sizeOf _ = #const sizeof(struct servent) + alignment _ = alignment (undefined :: CInt) -- ??? + + peek p = do + s_name <- (#peek struct servent, s_name) p >>= peekCString + s_aliases <- (#peek struct servent, s_aliases) p + >>= peekArray0 nullPtr + >>= mapM peekCString + s_port <- (#peek struct servent, s_port) p + s_proto <- (#peek struct servent, s_proto) p >>= peekCString + return (ServiceEntry { + serviceName = s_name, + serviceAliases = s_aliases, +#if defined(HAVE_WINSOCK2_H) && !defined(cygwin32_HOST_OS) + servicePort = PortNum (fromIntegral (s_port :: CShort)), +#else + -- s_port is already in network byte order, but it + -- might be the wrong size. + servicePort = PortNum (fromIntegral (s_port :: CInt)), +#endif + serviceProtocol = s_proto + }) + + poke _p = error "Storable.poke(BSD.ServiceEntry) not implemented" + + +-- | Get service by name. +getServiceByName :: ServiceName -- Service Name + -> ProtocolName -- Protocol Name + -> IO ServiceEntry -- Service Entry +getServiceByName name proto = withLock $ do + withCString name $ \ cstr_name -> do + withCString proto $ \ cstr_proto -> do + throwNoSuchThingIfNull "getServiceByName" "no such service entry" + $ (trySysCall (c_getservbyname cstr_name cstr_proto)) + >>= peek + +foreign import CALLCONV unsafe "getservbyname" + c_getservbyname :: CString -> CString -> IO (Ptr ServiceEntry) + +-- | Get the service given a 'PortNumber' and 'ProtocolName'. +getServiceByPort :: PortNumber -> ProtocolName -> IO ServiceEntry +getServiceByPort (PortNum port) proto = withLock $ do + withCString proto $ \ cstr_proto -> do + throwNoSuchThingIfNull "getServiceByPort" "no such service entry" + $ (trySysCall (c_getservbyport (fromIntegral port) cstr_proto)) + >>= peek + +foreign import CALLCONV unsafe "getservbyport" + c_getservbyport :: CInt -> CString -> IO (Ptr ServiceEntry) + +-- | Get the 'PortNumber' corresponding to the 'ServiceName'. +getServicePortNumber :: ServiceName -> IO PortNumber +getServicePortNumber name = do + (ServiceEntry _ _ port _) <- getServiceByName name "tcp" + return port + +#if !defined(cygwin32_HOST_OS) && !defined(mingw32_HOST_OS) && !defined(_WIN32) +getServiceEntry :: IO ServiceEntry +getServiceEntry = withLock $ do + throwNoSuchThingIfNull "getServiceEntry" "no such service entry" + $ trySysCall c_getservent + >>= peek + +foreign import ccall unsafe "getservent" c_getservent :: IO (Ptr ServiceEntry) + +setServiceEntry :: Bool -> IO () +setServiceEntry flg = withLock $ trySysCall $ c_setservent (fromBool flg) + +foreign import ccall unsafe "setservent" c_setservent :: CInt -> IO () + +endServiceEntry :: IO () +endServiceEntry = withLock $ trySysCall $ c_endservent + +foreign import ccall unsafe "endservent" c_endservent :: IO () + +getServiceEntries :: Bool -> IO [ServiceEntry] +getServiceEntries stayOpen = do + setServiceEntry stayOpen + getEntries (getServiceEntry) (endServiceEntry) +#endif + +-- --------------------------------------------------------------------------- +-- Protocol Entries + +-- The following relate directly to the corresponding UNIX C +-- calls for returning the protocol entries. The protocol entry is +-- represented by the Haskell type ProtocolEntry. + +-- As for setServiceEntry above, calling setProtocolEntry. +-- determines whether or not the protocol database file, usually +-- @/etc/protocols@, is to be kept open between calls of +-- getProtocolEntry. Similarly, + +data ProtocolEntry = + ProtocolEntry { + protoName :: ProtocolName, -- Official Name + protoAliases :: [ProtocolName], -- aliases + protoNumber :: ProtocolNumber -- Protocol Number + } deriving (Read, Show, Typeable) + +instance Storable ProtocolEntry where + sizeOf _ = #const sizeof(struct protoent) + alignment _ = alignment (undefined :: CInt) -- ??? + + peek p = do + p_name <- (#peek struct protoent, p_name) p >>= peekCString + p_aliases <- (#peek struct protoent, p_aliases) p + >>= peekArray0 nullPtr + >>= mapM peekCString +#if defined(HAVE_WINSOCK2_H) && !defined(cygwin32_HOST_OS) + -- With WinSock, the protocol number is only a short; + -- hoist it in as such, but represent it on the Haskell side + -- as a CInt. + p_proto_short <- (#peek struct protoent, p_proto) p + let p_proto = fromIntegral (p_proto_short :: CShort) +#else + p_proto <- (#peek struct protoent, p_proto) p +#endif + return (ProtocolEntry { + protoName = p_name, + protoAliases = p_aliases, + protoNumber = p_proto + }) + + poke _p = error "Storable.poke(BSD.ProtocolEntry) not implemented" + +getProtocolByName :: ProtocolName -> IO ProtocolEntry +getProtocolByName name = withLock $ do + withCString name $ \ name_cstr -> do + throwNoSuchThingIfNull "getProtocolByName" ("no such protocol name: " ++ name) + $ (trySysCall.c_getprotobyname) name_cstr + >>= peek + +foreign import CALLCONV unsafe "getprotobyname" + c_getprotobyname :: CString -> IO (Ptr ProtocolEntry) + + +getProtocolByNumber :: ProtocolNumber -> IO ProtocolEntry +getProtocolByNumber num = withLock $ do + throwNoSuchThingIfNull "getProtocolByNumber" ("no such protocol number: " ++ show num) + $ (trySysCall.c_getprotobynumber) (fromIntegral num) + >>= peek + +foreign import CALLCONV unsafe "getprotobynumber" + c_getprotobynumber :: CInt -> IO (Ptr ProtocolEntry) + + +getProtocolNumber :: ProtocolName -> IO ProtocolNumber +getProtocolNumber proto = do + (ProtocolEntry _ _ num) <- getProtocolByName proto + return num + +#if !defined(cygwin32_HOST_OS) && !defined(mingw32_HOST_OS) && !defined(_WIN32) +getProtocolEntry :: IO ProtocolEntry -- Next Protocol Entry from DB +getProtocolEntry = withLock $ do + ent <- throwNoSuchThingIfNull "getProtocolEntry" "no such protocol entry" + $ trySysCall c_getprotoent + peek ent + +foreign import ccall unsafe "getprotoent" c_getprotoent :: IO (Ptr ProtocolEntry) + +setProtocolEntry :: Bool -> IO () -- Keep DB Open ? +setProtocolEntry flg = withLock $ trySysCall $ c_setprotoent (fromBool flg) + +foreign import ccall unsafe "setprotoent" c_setprotoent :: CInt -> IO () + +endProtocolEntry :: IO () +endProtocolEntry = withLock $ trySysCall $ c_endprotoent + +foreign import ccall unsafe "endprotoent" c_endprotoent :: IO () + +getProtocolEntries :: Bool -> IO [ProtocolEntry] +getProtocolEntries stayOpen = withLock $ do + setProtocolEntry stayOpen + getEntries (getProtocolEntry) (endProtocolEntry) +#endif + +-- --------------------------------------------------------------------------- +-- Host lookups + +data HostEntry = + HostEntry { + hostName :: HostName, -- Official Name + hostAliases :: [HostName], -- aliases + hostFamily :: Family, -- Host Type (currently AF_INET) + hostAddresses :: [HostAddress] -- Set of Network Addresses (in network byte order) + } deriving (Read, Show, Typeable) + +instance Storable HostEntry where + sizeOf _ = #const sizeof(struct hostent) + alignment _ = alignment (undefined :: CInt) -- ??? + + peek p = do + h_name <- (#peek struct hostent, h_name) p >>= peekCString + h_aliases <- (#peek struct hostent, h_aliases) p + >>= peekArray0 nullPtr + >>= mapM peekCString + h_addrtype <- (#peek struct hostent, h_addrtype) p + -- h_length <- (#peek struct hostent, h_length) p + h_addr_list <- (#peek struct hostent, h_addr_list) p + >>= peekArray0 nullPtr + >>= mapM peek + return (HostEntry { + hostName = h_name, + hostAliases = h_aliases, +#if defined(HAVE_WINSOCK2_H) && !defined(cygwin32_HOST_OS) + hostFamily = unpackFamily (fromIntegral (h_addrtype :: CShort)), +#else + hostFamily = unpackFamily h_addrtype, +#endif + hostAddresses = h_addr_list + }) + + poke _p = error "Storable.poke(BSD.ServiceEntry) not implemented" + + +-- convenience function: +hostAddress :: HostEntry -> HostAddress +hostAddress (HostEntry nm _ _ ls) = + case ls of + [] -> error ("BSD.hostAddress: empty network address list for " ++ nm) + (x:_) -> x + +-- getHostByName must use the same lock as the *hostent functions +-- may cause problems if called concurrently. + +-- | Resolve a 'HostName' to IPv4 address. +getHostByName :: HostName -> IO HostEntry +getHostByName name = withLock $ do + withCString name $ \ name_cstr -> do + ent <- throwNoSuchThingIfNull "getHostByName" "no such host entry" + $ trySysCall $ c_gethostbyname name_cstr + peek ent + +foreign import CALLCONV safe "gethostbyname" + c_gethostbyname :: CString -> IO (Ptr HostEntry) + + +-- The locking of gethostbyaddr is similar to gethostbyname. +-- | Get a 'HostEntry' corresponding to the given address and family. +-- Note that only IPv4 is currently supported. +getHostByAddr :: Family -> HostAddress -> IO HostEntry +getHostByAddr family addr = do + with addr $ \ ptr_addr -> withLock $ do + throwNoSuchThingIfNull "getHostByAddr" "no such host entry" + $ trySysCall $ c_gethostbyaddr ptr_addr (fromIntegral (sizeOf addr)) (packFamily family) + >>= peek + +foreign import CALLCONV safe "gethostbyaddr" + c_gethostbyaddr :: Ptr HostAddress -> CInt -> CInt -> IO (Ptr HostEntry) + +#if defined(HAVE_GETHOSTENT) && !defined(cygwin32_HOST_OS) && !defined(mingw32_HOST_OS) && !defined(_WIN32) +getHostEntry :: IO HostEntry +getHostEntry = withLock $ do + throwNoSuchThingIfNull "getHostEntry" "unable to retrieve host entry" + $ trySysCall $ c_gethostent + >>= peek + +foreign import ccall unsafe "gethostent" c_gethostent :: IO (Ptr HostEntry) + +setHostEntry :: Bool -> IO () +setHostEntry flg = withLock $ trySysCall $ c_sethostent (fromBool flg) + +foreign import ccall unsafe "sethostent" c_sethostent :: CInt -> IO () + +endHostEntry :: IO () +endHostEntry = withLock $ c_endhostent + +foreign import ccall unsafe "endhostent" c_endhostent :: IO () + +getHostEntries :: Bool -> IO [HostEntry] +getHostEntries stayOpen = do + setHostEntry stayOpen + getEntries (getHostEntry) (endHostEntry) +#endif + +-- --------------------------------------------------------------------------- +-- Accessing network information + +-- Same set of access functions as for accessing host,protocol and +-- service system info, this time for the types of networks supported. + +-- network addresses are represented in host byte order. +type NetworkAddr = CULong + +type NetworkName = String + +data NetworkEntry = + NetworkEntry { + networkName :: NetworkName, -- official name + networkAliases :: [NetworkName], -- aliases + networkFamily :: Family, -- type + networkAddress :: NetworkAddr + } deriving (Read, Show, Typeable) + +instance Storable NetworkEntry where + sizeOf _ = #const sizeof(struct hostent) + alignment _ = alignment (undefined :: CInt) -- ??? + + peek p = do + n_name <- (#peek struct netent, n_name) p >>= peekCString + n_aliases <- (#peek struct netent, n_aliases) p + >>= peekArray0 nullPtr + >>= mapM peekCString + n_addrtype <- (#peek struct netent, n_addrtype) p + n_net <- (#peek struct netent, n_net) p + return (NetworkEntry { + networkName = n_name, + networkAliases = n_aliases, + networkFamily = unpackFamily (fromIntegral + (n_addrtype :: CInt)), + networkAddress = n_net + }) + + poke _p = error "Storable.poke(BSD.NetEntry) not implemented" + + +#if !defined(cygwin32_HOST_OS) && !defined(mingw32_HOST_OS) && !defined(_WIN32) +getNetworkByName :: NetworkName -> IO NetworkEntry +getNetworkByName name = withLock $ do + withCString name $ \ name_cstr -> do + throwNoSuchThingIfNull "getNetworkByName" "no such network entry" + $ trySysCall $ c_getnetbyname name_cstr + >>= peek + +foreign import ccall unsafe "getnetbyname" + c_getnetbyname :: CString -> IO (Ptr NetworkEntry) + +getNetworkByAddr :: NetworkAddr -> Family -> IO NetworkEntry +getNetworkByAddr addr family = withLock $ do + throwNoSuchThingIfNull "getNetworkByAddr" "no such network entry" + $ trySysCall $ c_getnetbyaddr addr (packFamily family) + >>= peek + +foreign import ccall unsafe "getnetbyaddr" + c_getnetbyaddr :: NetworkAddr -> CInt -> IO (Ptr NetworkEntry) + +getNetworkEntry :: IO NetworkEntry +getNetworkEntry = withLock $ do + throwNoSuchThingIfNull "getNetworkEntry" "no more network entries" + $ trySysCall $ c_getnetent + >>= peek + +foreign import ccall unsafe "getnetent" c_getnetent :: IO (Ptr NetworkEntry) + +-- | Open the network name database. The parameter specifies +-- whether a connection is maintained open between various +-- networkEntry calls +setNetworkEntry :: Bool -> IO () +setNetworkEntry flg = withLock $ trySysCall $ c_setnetent (fromBool flg) + +foreign import ccall unsafe "setnetent" c_setnetent :: CInt -> IO () + +-- | Close the connection to the network name database. +endNetworkEntry :: IO () +endNetworkEntry = withLock $ trySysCall $ c_endnetent + +foreign import ccall unsafe "endnetent" c_endnetent :: IO () + +-- | Get the list of network entries. +getNetworkEntries :: Bool -> IO [NetworkEntry] +getNetworkEntries stayOpen = do + setNetworkEntry stayOpen + getEntries (getNetworkEntry) (endNetworkEntry) +#endif + +-- Mutex for name service lockdown + +{-# NOINLINE lock #-} +lock :: MVar () +lock = unsafePerformIO $ newMVar () + +withLock :: IO a -> IO a +withLock act = withMVar lock (\_ -> act) + +-- --------------------------------------------------------------------------- +-- Miscellaneous Functions + +-- | Calling getHostName returns the standard host name for the current +-- processor, as set at boot time. + +getHostName :: IO HostName +getHostName = do + let size = 256 + allocaArray0 size $ \ cstr -> do + throwSocketErrorIfMinus1_ "getHostName" $ c_gethostname cstr (fromIntegral size) + peekCString cstr + +foreign import CALLCONV unsafe "gethostname" + c_gethostname :: CString -> CSize -> IO CInt + +-- Helper function used by the exported functions that provides a +-- Haskellised view of the enumerator functions: + +getEntries :: IO a -- read + -> IO () -- at end + -> IO [a] +getEntries getOne atEnd = loop + where + loop = do + vv <- catch (liftM Just getOne) + (\ e -> let _types = e :: IOException in return Nothing) + case vv of + Nothing -> return [] + Just v -> loop >>= \ vs -> atEnd >> return (v:vs) + + +-- --------------------------------------------------------------------------- +-- Winsock only: +-- The BSD API networking calls made locally return NULL upon failure. +-- That failure may very well be due to WinSock not being initialised, +-- so if NULL is seen try init'ing and repeat the call. +#if !defined(mingw32_HOST_OS) && !defined(_WIN32) +trySysCall :: IO a -> IO a +trySysCall act = act +#else +trySysCall :: IO (Ptr a) -> IO (Ptr a) +trySysCall act = do + ptr <- act + if (ptr == nullPtr) + then withSocketsDo act + else return ptr +#endif + +throwNoSuchThingIfNull :: String -> String -> IO (Ptr a) -> IO (Ptr a) +throwNoSuchThingIfNull loc desc act = do + ptr <- act + if (ptr == nullPtr) + then ioError (ioeSetErrorString (mkIOError NoSuchThing loc Nothing Nothing) desc) + else return ptr diff --git a/Network/Browser.hs b/Network/Browser.hs new file mode 100644 --- /dev/null +++ b/Network/Browser.hs @@ -0,0 +1,1062 @@ +{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, CPP #-} +{- | + +Module : Network.Browser +Copyright : See LICENSE file +License : BSD + +Maintainer : Ganesh Sittampalam +Stability : experimental +Portability : non-portable (not tested) + +Session-level interactions over HTTP. + +The "Network.Browser" goes beyond the basic "Network.HTTP" functionality in +providing support for more involved, and real, request/response interactions over +HTTP. Additional features supported are: + +* HTTP Authentication handling + +* Transparent handling of redirects + +* Cookie stores + transmission. + +* Transaction logging + +* Proxy-mediated connections. + +Example use: + +> do +> (_, rsp) +> <- Network.Browser.browse $ do +> setAllowRedirects True -- handle HTTP redirects +> request $ getRequest "http://www.haskell.org/" +> return (take 100 (rspBody rsp)) + +-} +module Network.Browser + ( BrowserState + , BrowserAction -- browser monad, effectively a state monad. + , Proxy(..) + + , browse -- :: BrowserAction a -> IO a + , request -- :: Request -> BrowserAction Response + + , getBrowserState -- :: BrowserAction t (BrowserState t) + , withBrowserState -- :: BrowserState t -> BrowserAction t a -> BrowserAction t a + + , setAllowRedirects -- :: Bool -> BrowserAction t () + , getAllowRedirects -- :: BrowserAction t Bool + + , setMaxRedirects -- :: Int -> BrowserAction t () + , getMaxRedirects -- :: BrowserAction t (Maybe Int) + + , Authority(..) + , getAuthorities + , setAuthorities + , addAuthority + , Challenge(..) + , Qop(..) + , Algorithm(..) + + , getAuthorityGen + , setAuthorityGen + , setAllowBasicAuth + , getAllowBasicAuth + + , setMaxErrorRetries -- :: Maybe Int -> BrowserAction t () + , getMaxErrorRetries -- :: BrowserAction t (Maybe Int) + + , setMaxPoolSize -- :: Int -> BrowserAction t () + , getMaxPoolSize -- :: BrowserAction t (Maybe Int) + + , setMaxAuthAttempts -- :: Maybe Int -> BrowserAction t () + , getMaxAuthAttempts -- :: BrowserAction t (Maybe Int) + + , setCookieFilter -- :: (URI -> Cookie -> IO Bool) -> BrowserAction t () + , getCookieFilter -- :: BrowserAction t (URI -> Cookie -> IO Bool) + , defaultCookieFilter -- :: URI -> Cookie -> IO Bool + , userCookieFilter -- :: URI -> Cookie -> IO Bool + + , Cookie(..) + , getCookies -- :: BrowserAction t [Cookie] + , setCookies -- :: [Cookie] -> BrowserAction t () + , addCookie -- :: Cookie -> BrowserAction t () + + , setErrHandler -- :: (String -> IO ()) -> BrowserAction t () + , setOutHandler -- :: (String -> IO ()) -> BrowserAction t () + + , setEventHandler -- :: (BrowserEvent -> BrowserAction t ()) -> BrowserAction t () + + , BrowserEvent(..) + , BrowserEventType(..) + , RequestID + + , setProxy -- :: Proxy -> BrowserAction t () + , getProxy -- :: BrowserAction t Proxy + + , setCheckForProxy -- :: Bool -> BrowserAction t () + , getCheckForProxy -- :: BrowserAction t Bool + + , setDebugLog -- :: Maybe String -> BrowserAction t () + + , getUserAgent -- :: BrowserAction t String + , setUserAgent -- :: String -> BrowserAction t () + + , out -- :: String -> BrowserAction t () + , err -- :: String -> BrowserAction t () + , ioAction -- :: IO a -> BrowserAction a + + , defaultGETRequest + , defaultGETRequest_ + + , formToRequest + , uriDefaultTo + + -- old and half-baked; don't use: + , Form(..) + , FormVar + ) where + +import Network.URI + ( URI(..) + , URIAuth(..) + , parseURI, parseURIReference, relativeTo + ) +import Network.StreamDebugger (debugByteStream) +import Network.HTTP hiding ( sendHTTP_notify ) +import Network.HTTP.HandleStream ( sendHTTP_notify ) +import Network.HTTP.Auth +import Network.HTTP.Cookie +import Network.HTTP.Proxy + +import Network.Stream ( ConnError(..), Result ) +import Network.BufferType + +import Data.Char (toLower) +import Data.List (isPrefixOf) +import Data.Maybe (fromMaybe, listToMaybe, catMaybes ) +import Control.Applicative (Applicative (..), (<$>)) +#ifdef MTL1 +import Control.Monad (filterM, when, ap) +#else +import Control.Monad (filterM, when) +#endif +import Control.Monad.State (StateT (..), MonadIO (..), modify, gets, withStateT, evalStateT, MonadState (..)) + +import qualified System.IO + ( hSetBuffering, hPutStr, stdout, stdin, hGetChar + , BufferMode(NoBuffering, LineBuffering) + ) +import System.Time ( ClockTime, getClockTime ) + + +------------------------------------------------------------------ +----------------------- Cookie Stuff ----------------------------- +------------------------------------------------------------------ + +-- | @defaultCookieFilter@ is the initial cookie acceptance filter. +-- It welcomes them all into the store @:-)@ +defaultCookieFilter :: URI -> Cookie -> IO Bool +defaultCookieFilter _url _cky = return True + +-- | @userCookieFilter@ is a handy acceptance filter, asking the +-- user if he/she is willing to accept an incoming cookie before +-- adding it to the store. +userCookieFilter :: URI -> Cookie -> IO Bool +userCookieFilter url cky = do + do putStrLn ("Set-Cookie received when requesting: " ++ show url) + case ckComment cky of + Nothing -> return () + Just x -> putStrLn ("Cookie Comment:\n" ++ x) + let pth = maybe "" ('/':) (ckPath cky) + putStrLn ("Domain/Path: " ++ ckDomain cky ++ pth) + putStrLn (ckName cky ++ '=' : ckValue cky) + System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering + System.IO.hSetBuffering System.IO.stdin System.IO.NoBuffering + System.IO.hPutStr System.IO.stdout "Accept [y/n]? " + x <- System.IO.hGetChar System.IO.stdin + System.IO.hSetBuffering System.IO.stdin System.IO.LineBuffering + System.IO.hSetBuffering System.IO.stdout System.IO.LineBuffering + return (toLower x == 'y') + +-- | @addCookie c@ adds a cookie to the browser state, removing duplicates. +addCookie :: Cookie -> BrowserAction t () +addCookie c = modify (\b -> b{bsCookies = c : filter (/=c) (bsCookies b) }) + +-- | @setCookies cookies@ replaces the set of cookies known to +-- the browser to @cookies@. Useful when wanting to restore cookies +-- used across 'browse' invocations. +setCookies :: [Cookie] -> BrowserAction t () +setCookies cs = modify (\b -> b { bsCookies=cs }) + +-- | @getCookies@ returns the current set of cookies known to +-- the browser. +getCookies :: BrowserAction t [Cookie] +getCookies = gets bsCookies + +-- ...get domain specific cookies... +-- ... this needs changing for consistency with rfc2109... +-- ... currently too broad. +getCookiesFor :: String -> String -> BrowserAction t [Cookie] +getCookiesFor dom path = + do cks <- getCookies + return (filter cookiematch cks) + where + cookiematch :: Cookie -> Bool + cookiematch = cookieMatch (dom,path) + + +-- | @setCookieFilter fn@ sets the cookie acceptance filter to @fn@. +setCookieFilter :: (URI -> Cookie -> IO Bool) -> BrowserAction t () +setCookieFilter f = modify (\b -> b { bsCookieFilter=f }) + +-- | @getCookieFilter@ returns the current cookie acceptance filter. +getCookieFilter :: BrowserAction t (URI -> Cookie -> IO Bool) +getCookieFilter = gets bsCookieFilter + +------------------------------------------------------------------ +----------------------- Authorisation Stuff ---------------------- +------------------------------------------------------------------ + +{- + +The browser handles 401 responses in the following manner: + 1) extract all WWW-Authenticate headers from a 401 response + 2) rewrite each as a Challenge object, using "headerToChallenge" + 3) pick a challenge to respond to, usually the strongest + challenge understood by the client, using "pickChallenge" + 4) generate a username/password combination using the browsers + "bsAuthorityGen" function (the default behaviour is to ask + the user) + 5) build an Authority object based upon the challenge and user + data, store this new Authority in the browser state + 6) convert the Authority to a request header and add this + to a request using "withAuthority" + 7) send the amended request + +Note that by default requests are annotated with authority headers +before the first sending, based upon previously generated Authority +objects (which contain domain information). Once a specific authority +is added to a rejected request this predictive annotation is suppressed. + +407 responses are handled in a similar manner, except + a) Authorities are not collected, only a single proxy authority + is kept by the browser + b) If the proxy used by the browser (type Proxy) is NoProxy, then + a 407 response will generate output on the "err" stream and + the response will be returned. + + +Notes: + - digest authentication so far ignores qop, so fails to authenticate + properly with qop=auth-int challenges + - calculates a1 more than necessary + - doesn't reverse authenticate + - doesn't properly receive AuthenticationInfo headers, so fails + to use next-nonce etc + +-} + +-- | Return authorities for a given domain and path. +-- Assumes "dom" is lower case +getAuthFor :: String -> String -> BrowserAction t [Authority] +getAuthFor dom pth = getAuthorities >>= return . (filter match) + where + match :: Authority -> Bool + match au@AuthBasic{} = matchURI (auSite au) + match au@AuthDigest{} = or (map matchURI (auDomain au)) + + matchURI :: URI -> Bool + matchURI s = (uriToAuthorityString s == dom) && (uriPath s `isPrefixOf` pth) + + +-- | @getAuthorities@ return the current set of @Authority@s known +-- to the browser. +getAuthorities :: BrowserAction t [Authority] +getAuthorities = gets bsAuthorities + +-- @setAuthorities as@ replaces the Browser's known set +-- of 'Authority's to @as@. +setAuthorities :: [Authority] -> BrowserAction t () +setAuthorities as = modify (\b -> b { bsAuthorities=as }) + +-- @addAuthority a@ adds 'Authority' @a@ to the Browser's +-- set of known authorities. +addAuthority :: Authority -> BrowserAction t () +addAuthority a = modify (\b -> b { bsAuthorities=a:bsAuthorities b }) + +-- | @getAuthorityGen@ returns the current authority generator +getAuthorityGen :: BrowserAction t (URI -> String -> IO (Maybe (String,String))) +getAuthorityGen = gets bsAuthorityGen + +-- | @setAuthorityGen genAct@ sets the auth generator to @genAct@. +setAuthorityGen :: (URI -> String -> IO (Maybe (String,String))) -> BrowserAction t () +setAuthorityGen f = modify (\b -> b { bsAuthorityGen=f }) + +-- | @setAllowBasicAuth onOff@ enables\/disables HTTP Basic Authentication. +setAllowBasicAuth :: Bool -> BrowserAction t () +setAllowBasicAuth ba = modify (\b -> b { bsAllowBasicAuth=ba }) + +getAllowBasicAuth :: BrowserAction t Bool +getAllowBasicAuth = gets bsAllowBasicAuth + +-- | @setMaxAuthAttempts mbMax@ sets the maximum number of authentication attempts +-- to do. If @Nothing@, rever to default max. +setMaxAuthAttempts :: Maybe Int -> BrowserAction t () +setMaxAuthAttempts mb + | fromMaybe 0 mb < 0 = return () + | otherwise = modify (\ b -> b{bsMaxAuthAttempts=mb}) + +-- | @getMaxAuthAttempts@ returns the current max auth attempts. If @Nothing@, +-- the browser's default is used. +getMaxAuthAttempts :: BrowserAction t (Maybe Int) +getMaxAuthAttempts = gets bsMaxAuthAttempts + +-- | @setMaxErrorRetries mbMax@ sets the maximum number of attempts at +-- transmitting a request. If @Nothing@, rever to default max. +setMaxErrorRetries :: Maybe Int -> BrowserAction t () +setMaxErrorRetries mb + | fromMaybe 0 mb < 0 = return () + | otherwise = modify (\ b -> b{bsMaxErrorRetries=mb}) + +-- | @getMaxErrorRetries@ returns the current max number of error retries. +getMaxErrorRetries :: BrowserAction t (Maybe Int) +getMaxErrorRetries = gets bsMaxErrorRetries + +-- TO BE CHANGED!!! +pickChallenge :: Bool -> [Challenge] -> Maybe Challenge +pickChallenge allowBasic [] + | allowBasic = Just (ChalBasic "/") -- manufacture a challenge if one missing; more robust. +pickChallenge _ ls = listToMaybe ls + +-- | Retrieve a likely looking authority for a Request. +anticipateChallenge :: Request ty -> BrowserAction t (Maybe Authority) +anticipateChallenge rq = + let uri = rqURI rq in + do { authlist <- getAuthFor (uriAuthToString $ reqURIAuth rq) (uriPath uri) + ; return (listToMaybe authlist) + } + +-- | Asking the user to respond to a challenge +challengeToAuthority :: URI -> Challenge -> BrowserAction t (Maybe Authority) +challengeToAuthority uri ch + | not (answerable ch) = return Nothing + | otherwise = do + -- prompt user for authority + prompt <- getAuthorityGen + userdetails <- liftIO $ prompt uri (chRealm ch) + case userdetails of + Nothing -> return Nothing + Just (u,p) -> return (Just $ buildAuth ch u p) + where + answerable :: Challenge -> Bool + answerable ChalBasic{} = True + answerable chall = (chAlgorithm chall) == Just AlgMD5 + + buildAuth :: Challenge -> String -> String -> Authority + buildAuth (ChalBasic r) u p = + AuthBasic { auSite=uri + , auRealm=r + , auUsername=u + , auPassword=p + } + + -- note to self: this is a pretty stupid operation + -- to perform isn't it? ChalX and AuthX are so very + -- similar. + buildAuth (ChalDigest r d n o _stale a q) u p = + AuthDigest { auRealm=r + , auUsername=u + , auPassword=p + , auDomain=d + , auNonce=n + , auOpaque=o + , auAlgorithm=a + , auQop=q + } + + +------------------------------------------------------------------ +------------------ Browser State Actions ------------------------- +------------------------------------------------------------------ + + +-- | @BrowserState@ is the (large) record type tracking the current +-- settings of the browser. +data BrowserState connection + = BS { bsErr, bsOut :: String -> IO () + , bsCookies :: [Cookie] + , bsCookieFilter :: URI -> Cookie -> IO Bool + , bsAuthorityGen :: URI -> String -> IO (Maybe (String,String)) + , bsAuthorities :: [Authority] + , bsAllowRedirects :: Bool + , bsAllowBasicAuth :: Bool + , bsMaxRedirects :: Maybe Int + , bsMaxErrorRetries :: Maybe Int + , bsMaxAuthAttempts :: Maybe Int + , bsMaxPoolSize :: Maybe Int + , bsConnectionPool :: [connection] + , bsCheckProxy :: Bool + , bsProxy :: Proxy + , bsDebug :: Maybe String + , bsEvent :: Maybe (BrowserEvent -> BrowserAction connection ()) + , bsRequestID :: RequestID + , bsUserAgent :: Maybe String + } + +instance Show (BrowserState t) where + show bs = "BrowserState { " + ++ shows (bsCookies bs) ("\n" + {- ++ show (bsAuthorities bs) ++ "\n"-} + ++ "AllowRedirects: " ++ shows (bsAllowRedirects bs) "} ") + +-- | @BrowserAction@ is the IO monad, but carrying along a 'BrowserState'. +newtype BrowserAction conn a + = BA { unBA :: StateT (BrowserState conn) IO a } +#ifdef MTL1 + deriving (Functor, Monad, MonadIO, MonadState (BrowserState conn)) + +instance Applicative (BrowserAction conn) where + pure = return + (<*>) = ap +#else + deriving (Functor, Applicative, Monad, MonadIO, MonadState (BrowserState conn)) +#endif + +runBA :: BrowserState conn -> BrowserAction conn a -> IO a +runBA bs = flip evalStateT bs . unBA + +-- | @browse act@ is the toplevel action to perform a 'BrowserAction'. +-- Example use: @browse (request (getRequest yourURL))@. +browse :: BrowserAction conn a -> IO a +browse = runBA defaultBrowserState + +-- | The default browser state has the settings +defaultBrowserState :: BrowserState t +defaultBrowserState = res + where + res = BS + { bsErr = putStrLn + , bsOut = putStrLn + , bsCookies = [] + , bsCookieFilter = defaultCookieFilter + , bsAuthorityGen = \ _uri _realm -> do + bsErr res "No action for prompting/generating user+password credentials provided (use: setAuthorityGen); returning Nothing" + return Nothing + , bsAuthorities = [] + , bsAllowRedirects = True + , bsAllowBasicAuth = False + , bsMaxRedirects = Nothing + , bsMaxErrorRetries = Nothing + , bsMaxAuthAttempts = Nothing + , bsMaxPoolSize = Nothing + , bsConnectionPool = [] + , bsCheckProxy = defaultAutoProxyDetect + , bsProxy = noProxy + , bsDebug = Nothing + , bsEvent = Nothing + , bsRequestID = 0 + , bsUserAgent = Nothing + } + +{-# DEPRECATED getBrowserState "Use Control.Monad.State.get instead." #-} +-- | @getBrowserState@ returns the current browser config. Useful +-- for restoring state across 'BrowserAction's. +getBrowserState :: BrowserAction t (BrowserState t) +getBrowserState = get + +-- | @withBrowserAction st act@ performs @act@ with 'BrowserState' @st@. +withBrowserState :: BrowserState t -> BrowserAction t a -> BrowserAction t a +withBrowserState bs = BA . withStateT (const bs) . unBA + +-- | @nextRequest act@ performs the browser action @act@ as +-- the next request, i.e., setting up a new request context +-- before doing so. +nextRequest :: BrowserAction t a -> BrowserAction t a +nextRequest act = do + let updReqID st = + let + rid = succ (bsRequestID st) + in + rid `seq` st{bsRequestID=rid} + modify updReqID + act + +-- | Lifts an IO action into the 'BrowserAction' monad. +{-# DEPRECATED ioAction "Use Control.Monad.Trans.liftIO instead." #-} +ioAction :: IO a -> BrowserAction t a +ioAction = liftIO + +-- | @setErrHandler@ sets the IO action to call when +-- the browser reports running errors. To disable any +-- such, set it to @const (return ())@. +setErrHandler :: (String -> IO ()) -> BrowserAction t () +setErrHandler h = modify (\b -> b { bsErr=h }) + +-- | @setErrHandler@ sets the IO action to call when +-- the browser chatters info on its running. To disable any +-- such, set it to @const (return ())@. +setOutHandler :: (String -> IO ()) -> BrowserAction t () +setOutHandler h = modify (\b -> b { bsOut=h }) + +out, err :: String -> BrowserAction t () +out s = do { f <- gets bsOut ; liftIO $ f s } +err s = do { f <- gets bsErr ; liftIO $ f s } + +-- | @setAllowRedirects onOff@ toggles the willingness to +-- follow redirects (HTTP responses with 3xx status codes). +setAllowRedirects :: Bool -> BrowserAction t () +setAllowRedirects bl = modify (\b -> b {bsAllowRedirects=bl}) + +-- | @getAllowRedirects@ returns current setting of the do-chase-redirects flag. +getAllowRedirects :: BrowserAction t Bool +getAllowRedirects = gets bsAllowRedirects + +-- | @setMaxRedirects maxCount@ sets the maxiumum number of forwarding hops +-- we are willing to jump through. A no-op if the count is negative; if zero, +-- the max is set to whatever default applies. Notice that setting the max +-- redirects count does /not/ enable following of redirects itself; use +-- 'setAllowRedirects' to do so. +setMaxRedirects :: Maybe Int -> BrowserAction t () +setMaxRedirects c + | fromMaybe 0 c < 0 = return () + | otherwise = modify (\b -> b{bsMaxRedirects=c}) + +-- | @getMaxRedirects@ returns the current setting for the max-redirect count. +-- If @Nothing@, the "Network.Browser"'s default is used. +getMaxRedirects :: BrowserAction t (Maybe Int) +getMaxRedirects = gets bsMaxRedirects + +-- | @setMaxPoolSize maxCount@ sets the maximum size of the connection pool +-- that is used to cache connections between requests +setMaxPoolSize :: Maybe Int -> BrowserAction t () +setMaxPoolSize c = modify (\b -> b{bsMaxPoolSize=c}) + +-- | @getMaxPoolSize@ gets the maximum size of the connection pool +-- that is used to cache connections between requests. +-- If @Nothing@, the "Network.Browser"'s default is used. +getMaxPoolSize :: BrowserAction t (Maybe Int) +getMaxPoolSize = gets bsMaxPoolSize + +-- | @setProxy p@ will disable proxy usage if @p@ is @NoProxy@. +-- If @p@ is @Proxy proxyURL mbAuth@, then @proxyURL@ is interpreted +-- as the URL of the proxy to use, possibly authenticating via +-- 'Authority' information in @mbAuth@. +setProxy :: Proxy -> BrowserAction t () +setProxy p = + -- Note: if user _explicitly_ sets the proxy, we turn + -- off any auto-detection of proxies. + modify (\b -> b {bsProxy = p, bsCheckProxy=False}) + +-- | @getProxy@ returns the current proxy settings. If +-- the auto-proxy flag is set to @True@, @getProxy@ will +-- perform the necessary +getProxy :: BrowserAction t Proxy +getProxy = do + p <- gets bsProxy + case p of + -- Note: if there is a proxy, no need to perform any auto-detect. + -- Presumably this is the user's explicit and preferred proxy server. + Proxy{} -> return p + NoProxy{} -> do + flg <- gets bsCheckProxy + if not flg + then return p + else do + np <- liftIO $ fetchProxy True{-issue warning on stderr if ill-formed...-} + -- note: this resets the check-proxy flag; a one-off affair. + setProxy np + return np + +-- | @setCheckForProxy flg@ sets the one-time check for proxy +-- flag to @flg@. If @True@, the session will try to determine +-- the proxy server is locally configured. See 'Network.HTTP.Proxy.fetchProxy' +-- for details of how this done. +setCheckForProxy :: Bool -> BrowserAction t () +setCheckForProxy flg = modify (\ b -> b{bsCheckProxy=flg}) + +-- | @getCheckForProxy@ returns the current check-proxy setting. +-- Notice that this may not be equal to @True@ if the session has +-- set it to that via 'setCheckForProxy' and subsequently performed +-- some HTTP protocol interactions. i.e., the flag return represents +-- whether a proxy will be checked for again before any future protocol +-- interactions. +getCheckForProxy :: BrowserAction t Bool +getCheckForProxy = gets bsCheckProxy + +-- | @setDebugLog mbFile@ turns off debug logging iff @mbFile@ +-- is @Nothing@. If set to @Just fStem@, logs of browser activity +-- is appended to files of the form @fStem-url-authority@, i.e., +-- @fStem@ is just the prefix for a set of log files, one per host/authority. +setDebugLog :: Maybe String -> BrowserAction t () +setDebugLog v = modify (\b -> b {bsDebug=v}) + +-- | @setUserAgent ua@ sets the current @User-Agent:@ string to @ua@. It +-- will be used if no explicit user agent header is found in subsequent requests. +-- +-- A common form of user agent string is @\"name\/version (details)\"@. For +-- example @\"cabal-install/0.10.2 (HTTP 4000.1.2)\"@. Including the version +-- of this HTTP package can be helpful if you ever need to track down HTTP +-- compatability quirks. This version is available via 'httpPackageVersion'. +-- For more info see . +-- +setUserAgent :: String -> BrowserAction t () +setUserAgent ua = modify (\b -> b{bsUserAgent=Just ua}) + +-- | @getUserAgent@ returns the current @User-Agent:@ default string. +getUserAgent :: BrowserAction t String +getUserAgent = do + n <- gets bsUserAgent + return (maybe defaultUserAgent id n) + +-- | @RequestState@ is an internal tallying type keeping track of various +-- per-connection counters, like the number of authorization attempts and +-- forwards we've gone through. +data RequestState + = RequestState + { reqDenies :: Int -- ^ number of 401 responses so far + , reqRedirects :: Int -- ^ number of redirects so far + , reqRetries :: Int -- ^ number of retries so far + , reqStopOnDeny :: Bool -- ^ whether to pre-empt 401 response + } + +type RequestID = Int -- yeah, it will wrap around. + +nullRequestState :: RequestState +nullRequestState = RequestState + { reqDenies = 0 + , reqRedirects = 0 + , reqRetries = 0 + , reqStopOnDeny = True + } + +-- | @BrowserEvent@ is the event record type that a user-defined handler, set +-- via 'setEventHandler', will be passed. It indicates various state changes +-- encountered in the processing of a given 'RequestID', along with timestamps +-- at which they occurred. +data BrowserEvent + = BrowserEvent + { browserTimestamp :: ClockTime + , browserRequestID :: RequestID + , browserRequestURI :: {-URI-}String + , browserEventType :: BrowserEventType + } + +-- | 'BrowserEventType' is the enumerated list of events that the browser +-- internals will report to a user-defined event handler. +data BrowserEventType + = OpenConnection + | ReuseConnection + | RequestSent + | ResponseEnd ResponseData + | ResponseFinish +{- not yet, you will have to determine these via the ResponseEnd event. + | Redirect + | AuthChallenge + | AuthResponse +-} + +-- | @setEventHandler onBrowserEvent@ configures event handling. +-- If @onBrowserEvent@ is @Nothing@, event handling is turned off; +-- setting it to @Just onEv@ causes the @onEv@ IO action to be +-- notified of browser events during the processing of a request +-- by the Browser pipeline. +setEventHandler :: Maybe (BrowserEvent -> BrowserAction ty ()) -> BrowserAction ty () +setEventHandler mbH = modify (\b -> b { bsEvent=mbH}) + +buildBrowserEvent :: BrowserEventType -> {-URI-}String -> RequestID -> IO BrowserEvent +buildBrowserEvent bt uri reqID = do + ct <- getClockTime + return BrowserEvent + { browserTimestamp = ct + , browserRequestID = reqID + , browserRequestURI = uri + , browserEventType = bt + } + +reportEvent :: BrowserEventType -> {-URI-}String -> BrowserAction t () +reportEvent bt uri = do + st <- get + case bsEvent st of + Nothing -> return () + Just evH -> do + evt <- liftIO $ buildBrowserEvent bt uri (bsRequestID st) + evH evt -- if it fails, we fail. + +-- | The default number of hops we are willing not to go beyond for +-- request forwardings. +defaultMaxRetries :: Int +defaultMaxRetries = 4 + +-- | The default number of error retries we are willing to perform. +defaultMaxErrorRetries :: Int +defaultMaxErrorRetries = 4 + +-- | The default maximum HTTP Authentication attempts we will make for +-- a single request. +defaultMaxAuthAttempts :: Int +defaultMaxAuthAttempts = 2 + +-- | The default setting for auto-proxy detection. +-- You may change this within a session via 'setAutoProxyDetect'. +-- To avoid initial backwards compatibility issues, leave this as @False@. +defaultAutoProxyDetect :: Bool +defaultAutoProxyDetect = False + +-- | @request httpRequest@ tries to submit the 'Request' @httpRequest@ +-- to some HTTP server (possibly going via a /proxy/, see 'setProxy'.) +-- Upon successful delivery, the URL where the response was fetched from +-- is returned along with the 'Response' itself. +request :: HStream ty + => Request ty + -> BrowserAction (HandleStream ty) (URI,Response ty) +request req = nextRequest $ do + res <- request' nullVal initialState req + reportEvent ResponseFinish (show (rqURI req)) + case res of + Right r -> return r + Left e -> do + let errStr = ("Network.Browser.request: Error raised " ++ show e) + err errStr + fail errStr + where + initialState = nullRequestState + nullVal = buf_empty bufferOps + +-- | Internal helper function, explicitly carrying along per-request +-- counts. +request' :: HStream ty + => ty + -> RequestState + -> Request ty + -> BrowserAction (HandleStream ty) (Result (URI,Response ty)) +request' nullVal rqState rq = do + let uri = rqURI rq + failHTTPS uri + let uria = reqURIAuth rq + -- add cookies to request + cookies <- getCookiesFor (uriAuthToString uria) (uriPath uri) +{- Not for now: + (case uriUserInfo uria of + "" -> id + xs -> + case chopAtDelim ':' xs of + (_,[]) -> id + (usr,pwd) -> withAuth + AuthBasic{ auUserName = usr + , auPassword = pwd + , auRealm = "/" + , auSite = uri + }) $ do +-} + when (not $ null cookies) + (out $ "Adding cookies to request. Cookie names: " ++ unwords (map ckName cookies)) + -- add credentials to request + rq' <- + if not (reqStopOnDeny rqState) + then return rq + else do + auth <- anticipateChallenge rq + case auth of + Nothing -> return rq + Just x -> return (insertHeader HdrAuthorization (withAuthority x rq) rq) + let rq'' = if not $ null cookies then insertHeaders [cookiesToHeader cookies] rq' else rq' + p <- getProxy + def_ua <- gets bsUserAgent + let defaultOpts = + case p of + NoProxy -> defaultNormalizeRequestOptions{normUserAgent=def_ua} + Proxy _ ath -> + defaultNormalizeRequestOptions + { normForProxy = True + , normUserAgent = def_ua + , normCustoms = + maybe [] + (\ authS -> [\ _ r -> insertHeader HdrProxyAuthorization (withAuthority authS r) r]) + ath + } + let final_req = normalizeRequest defaultOpts rq'' + out ("Sending:\n" ++ show final_req) + e_rsp <- + case p of + NoProxy -> dorequest (reqURIAuth rq'') final_req + Proxy str _ath -> do + let notURI + | null pt || null hst = + URIAuth{ uriUserInfo = "" + , uriRegName = str + , uriPort = "" + } + | otherwise = + URIAuth{ uriUserInfo = "" + , uriRegName = hst + , uriPort = pt + } + -- If the ':' is dropped from port below, dorequest will assume port 80. Leave it! + where (hst, pt) = span (':'/=) str + -- Proxy can take multiple forms - look for http://host:port first, + -- then host:port. Fall back to just the string given (probably a host name). + let proxyURIAuth = + maybe notURI + (\parsed -> maybe notURI id (uriAuthority parsed)) + (parseURI str) + + out $ "proxy uri host: " ++ uriRegName proxyURIAuth ++ ", port: " ++ uriPort proxyURIAuth + dorequest proxyURIAuth final_req + mbMx <- getMaxErrorRetries + case e_rsp of + Left v + | (reqRetries rqState < fromMaybe defaultMaxErrorRetries mbMx) && + (v == ErrorReset || v == ErrorClosed) -> + request' nullVal rqState{reqRetries=succ (reqRetries rqState)} rq + | otherwise -> + return (Left v) + Right rsp -> do + out ("Received:\n" ++ show rsp) + -- add new cookies to browser state + handleCookies uri (uriAuthToString $ reqURIAuth rq) + (retrieveHeaders HdrSetCookie rsp) + mbMxAuths <- getMaxAuthAttempts + case rspCode rsp of + (4,0,1) -- Credentials not sent or refused. + | reqDenies rqState > fromMaybe defaultMaxAuthAttempts mbMxAuths -> do + out "401 - credentials again refused; exceeded retry count (2)" + return (Right (uri,rsp)) + | otherwise -> do + out "401 - credentials not supplied or refused; retrying.." + let hdrs = retrieveHeaders HdrWWWAuthenticate rsp + flg <- getAllowBasicAuth + case pickChallenge flg (catMaybes $ map (headerToChallenge uri) hdrs) of + Nothing -> do + out "no challenge" + return (Right (uri,rsp)) {- do nothing -} + Just x -> do + au <- challengeToAuthority uri x + case au of + Nothing -> do + out "no auth" + return (Right (uri,rsp)) {- do nothing -} + Just au' -> do + out "Retrying request with new credentials" + request' nullVal + rqState{ reqDenies = succ(reqDenies rqState) + , reqStopOnDeny = False + } + (insertHeader HdrAuthorization (withAuthority au' rq) rq) + + (4,0,7) -- Proxy Authentication required + | reqDenies rqState > fromMaybe defaultMaxAuthAttempts mbMxAuths -> do + out "407 - proxy authentication required; max deny count exceeeded (2)" + return (Right (uri,rsp)) + | otherwise -> do + out "407 - proxy authentication required" + let hdrs = retrieveHeaders HdrProxyAuthenticate rsp + flg <- getAllowBasicAuth + case pickChallenge flg (catMaybes $ map (headerToChallenge uri) hdrs) of + Nothing -> return (Right (uri,rsp)) {- do nothing -} + Just x -> do + au <- challengeToAuthority uri x + case au of + Nothing -> return (Right (uri,rsp)) {- do nothing -} + Just au' -> do + pxy <- gets bsProxy + case pxy of + NoProxy -> do + err "Proxy authentication required without proxy!" + return (Right (uri,rsp)) + Proxy px _ -> do + out "Retrying with proxy authentication" + setProxy (Proxy px (Just au')) + request' nullVal + rqState{ reqDenies = succ(reqDenies rqState) + , reqStopOnDeny = False + } + rq + + (3,0,x) | x `elem` [2,3,1,7] -> do + out ("30" ++ show x ++ " - redirect") + allow_redirs <- allowRedirect rqState + case allow_redirs of + False -> return (Right (uri,rsp)) + _ -> do + case retrieveHeaders HdrLocation rsp of + [] -> do + err "No Location: header in redirect response" + return (Right (uri,rsp)) + (Header _ u:_) -> + case parseURIReference u of + Nothing -> do + err ("Parse of Location: header in a redirect response failed: " ++ u) + return (Right (uri,rsp)) + Just newURI + | {-uriScheme newURI_abs /= uriScheme uri && -}(not (supportedScheme newURI_abs)) -> do + err ("Unable to handle redirect, unsupported scheme: " ++ show newURI_abs) + return (Right (uri, rsp)) + | otherwise -> do + out ("Redirecting to " ++ show newURI_abs ++ " ...") + + -- Redirect using GET request method, depending on + -- response code. + let toGet = x `elem` [2,3] + method = if toGet then GET else rqMethod rq + rq1 = rq { rqMethod=method, rqURI=newURI_abs } + rq2 = if toGet then (replaceHeader HdrContentLength "0") (rq1 {rqBody = nullVal}) else rq1 + + request' nullVal + rqState{ reqDenies = 0 + , reqRedirects = succ(reqRedirects rqState) + , reqStopOnDeny = True + } + rq2 + where + newURI_abs = maybe newURI id (newURI `relativeTo` uri) + + (3,0,5) -> + case retrieveHeaders HdrLocation rsp of + [] -> do + err "No Location header in proxy redirect response." + return (Right (uri,rsp)) + (Header _ u:_) -> + case parseURIReference u of + Nothing -> do + err ("Parse of Location header in a proxy redirect response failed: " ++ u) + return (Right (uri,rsp)) + Just newuri -> do + out ("Retrying with proxy " ++ show newuri ++ "...") + setProxy (Proxy (uriToAuthorityString newuri) Nothing) + request' nullVal rqState{ reqDenies = 0 + , reqRedirects = 0 + , reqRetries = succ (reqRetries rqState) + , reqStopOnDeny = True + } + rq + _ -> return (Right (uri,rsp)) + +-- | The internal request handling state machine. +dorequest :: (HStream ty) + => URIAuth + -> Request ty + -> BrowserAction (HandleStream ty) + (Result (Response ty)) +dorequest hst rqst = do + pool <- gets bsConnectionPool + let uPort = uriAuthPort Nothing{-ToDo: feed in complete URL-} hst + conn <- liftIO $ filterM (\c -> c `isTCPConnectedTo` EndPoint (uriRegName hst) uPort) pool + rsp <- + case conn of + [] -> do + out ("Creating new connection to " ++ uriAuthToString hst) + reportEvent OpenConnection (show (rqURI rqst)) + c <- liftIO $ openStream (uriRegName hst) uPort + updateConnectionPool c + dorequest2 c rqst + (c:_) -> do + out ("Recovering connection to " ++ uriAuthToString hst) + reportEvent ReuseConnection (show (rqURI rqst)) + dorequest2 c rqst + case rsp of + Right (Response a b c _) -> + reportEvent (ResponseEnd (a,b,c)) (show (rqURI rqst)) ; _ -> return () + return rsp + where + dorequest2 c r = do + dbg <- gets bsDebug + st <- get + let + onSendComplete = + maybe (return ()) + (\evh -> do + x <- buildBrowserEvent RequestSent (show (rqURI r)) (bsRequestID st) + runBA st (evh x) + return ()) + (bsEvent st) + liftIO $ + maybe (sendHTTP_notify c r onSendComplete) + (\ f -> do + c' <- debugByteStream (f++'-': uriAuthToString hst) c + sendHTTP_notify c' r onSendComplete) + dbg + +updateConnectionPool :: HStream hTy + => HandleStream hTy + -> BrowserAction (HandleStream hTy) () +updateConnectionPool c = do + pool <- gets bsConnectionPool + let len_pool = length pool + maxPoolSize <- fromMaybe defaultMaxPoolSize <$> gets bsMaxPoolSize + when (len_pool > maxPoolSize) + (liftIO $ close (last pool)) + let pool' + | len_pool > maxPoolSize = init pool + | otherwise = pool + when (maxPoolSize > 0) $ modify (\b -> b { bsConnectionPool=c:pool' }) + return () + +-- | Default maximum number of open connections we are willing to have active. +defaultMaxPoolSize :: Int +defaultMaxPoolSize = 5 + +handleCookies :: URI -> String -> [Header] -> BrowserAction t () +handleCookies _ _ [] = return () -- cut short the silliness. +handleCookies uri dom cookieHeaders = do + when (not $ null errs) + (err $ unlines ("Errors parsing these cookie values: ":errs)) + when (not $ null newCookies) + (out $ foldl (\x y -> x ++ "\n " ++ show y) "Cookies received:" newCookies) + filterfn <- getCookieFilter + newCookies' <- liftIO (filterM (filterfn uri) newCookies) + when (not $ null newCookies') + (out $ "Accepting cookies with names: " ++ unwords (map ckName newCookies')) + mapM_ addCookie newCookies' + where + (errs, newCookies) = processCookieHeaders dom cookieHeaders + +------------------------------------------------------------------ +----------------------- Miscellaneous ---------------------------- +------------------------------------------------------------------ + +allowRedirect :: RequestState -> BrowserAction t Bool +allowRedirect rqState = do + rd <- getAllowRedirects + mbMxRetries <- getMaxRedirects + return (rd && (reqRedirects rqState <= fromMaybe defaultMaxRetries mbMxRetries)) + +-- | Return @True@ iff the package is able to handle requests and responses +-- over it. +supportedScheme :: URI -> Bool +supportedScheme u = uriScheme u == "http:" + +-- | @uriDefaultTo a b@ returns a URI that is consistent with the first +-- argument URI @a@ when read in the context of the second URI @b@. +-- If the second argument is not sufficient context for determining +-- a full URI then anarchy reins. +uriDefaultTo :: URI -> URI -> URI +uriDefaultTo a b = maybe a id (a `relativeTo` b) + + +-- This form junk is completely untested... + +type FormVar = (String,String) + +data Form = Form RequestMethod URI [FormVar] + +formToRequest :: Form -> Request_String +formToRequest (Form m u vs) = + let enc = urlEncodeVars vs + in case m of + GET -> Request { rqMethod=GET + , rqHeaders=[ Header HdrContentLength "0" ] + , rqBody="" + , rqURI=u { uriQuery= '?' : enc } -- What about old query? + } + POST -> Request { rqMethod=POST + , rqHeaders=[ Header HdrContentType "application/x-www-form-urlencoded", + Header HdrContentLength (show $ length enc) ] + , rqBody=enc + , rqURI=u + } + _ -> error ("unexpected request: " ++ show m) + + diff --git a/Network/BufferType.hs b/Network/BufferType.hs new file mode 100644 --- /dev/null +++ b/Network/BufferType.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE TypeSynonymInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Network.BufferType +-- Description : Abstract representation of request and response buffer types. +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- In order to give the user freedom in how request and response content +-- is represented, a sufficiently abstract representation is needed of +-- these internally. The "Network.BufferType" module provides this, defining +-- the 'BufferType' class and its ad-hoc representation of buffer operations +-- via the 'BufferOp' record. +-- +-- This module provides definitions for the standard buffer types that the +-- package supports, i.e., for @String@ and @ByteString@ (strict and lazy.) +-- +----------------------------------------------------------------------------- +module Network.BufferType + ( + BufferType(..) + + , BufferOp(..) + , strictBufferOp + , lazyBufferOp + , stringBufferOp + ) where + + +import qualified Data.ByteString as Strict hiding ( unpack, pack, span ) +import qualified Data.ByteString.Char8 as Strict ( unpack, pack, span ) +import qualified Data.ByteString.Lazy as Lazy hiding ( pack, unpack,span ) +import qualified Data.ByteString.Lazy.Char8 as Lazy ( pack, unpack, span ) +import System.IO ( Handle ) +import Data.Word ( Word8 ) + +import Network.HTTP.Utils ( crlf, lf ) + +-- | The @BufferType@ class encodes, in a mixed-mode way, the interface +-- that the library requires to operate over data embedded in HTTP +-- requests and responses. That is, we use explicit dictionaries +-- for the operations, but overload the name of the dicts themselves. +-- +class BufferType bufType where + bufferOps :: BufferOp bufType + +instance BufferType Lazy.ByteString where + bufferOps = lazyBufferOp + +instance BufferType Strict.ByteString where + bufferOps = strictBufferOp + +instance BufferType String where + bufferOps = stringBufferOp + +-- | @BufferOp@ encodes the I/O operations of the underlying buffer over +-- a Handle in an (explicit) dictionary type. May not be needed, but gives +-- us flexibility in explicit overriding and wrapping up of these methods. +-- +-- Along with IO operations is an ad-hoc collection of functions for working +-- with these abstract buffers, as needed by the internals of the code +-- that processes requests and responses. +-- +-- We supply three default @BufferOp@ values, for @String@ along with the +-- strict and lazy versions of @ByteString@. To add others, provide @BufferOp@ +-- definitions for +data BufferOp a + = BufferOp + { buf_hGet :: Handle -> Int -> IO a + , buf_hGetContents :: Handle -> IO a + , buf_hPut :: Handle -> a -> IO () + , buf_hGetLine :: Handle -> IO a + , buf_empty :: a + , buf_append :: a -> a -> a + , buf_concat :: [a] -> a + , buf_fromStr :: String -> a + , buf_toStr :: a -> String + , buf_snoc :: a -> Word8 -> a + , buf_splitAt :: Int -> a -> (a,a) + , buf_span :: (Char -> Bool) -> a -> (a,a) + , buf_isLineTerm :: a -> Bool + , buf_isEmpty :: a -> Bool + } + +instance Eq (BufferOp a) where + _ == _ = False + +-- | @strictBufferOp@ is the 'BufferOp' definition over @ByteString@s, +-- the non-lazy kind. +strictBufferOp :: BufferOp Strict.ByteString +strictBufferOp = + BufferOp + { buf_hGet = Strict.hGet + , buf_hGetContents = Strict.hGetContents + , buf_hPut = Strict.hPut + , buf_hGetLine = Strict.hGetLine + , buf_append = Strict.append + , buf_concat = Strict.concat + , buf_fromStr = Strict.pack + , buf_toStr = Strict.unpack + , buf_snoc = Strict.snoc + , buf_splitAt = Strict.splitAt + , buf_span = Strict.span + , buf_empty = Strict.empty + , buf_isLineTerm = \ b -> Strict.length b == 2 && p_crlf == b || + Strict.length b == 1 && p_lf == b + , buf_isEmpty = Strict.null + } + where + p_crlf = Strict.pack crlf + p_lf = Strict.pack lf + +-- | @lazyBufferOp@ is the 'BufferOp' definition over @ByteString@s, +-- the non-strict kind. +lazyBufferOp :: BufferOp Lazy.ByteString +lazyBufferOp = + BufferOp + { buf_hGet = Lazy.hGet + , buf_hGetContents = Lazy.hGetContents + , buf_hPut = Lazy.hPut + , buf_hGetLine = \ h -> Strict.hGetLine h >>= \ l -> return (Lazy.fromChunks [l]) + , buf_append = Lazy.append + , buf_concat = Lazy.concat + , buf_fromStr = Lazy.pack + , buf_toStr = Lazy.unpack + , buf_snoc = Lazy.snoc + , buf_splitAt = \ i x -> Lazy.splitAt (fromIntegral i) x + , buf_span = Lazy.span + , buf_empty = Lazy.empty + , buf_isLineTerm = \ b -> Lazy.length b == 2 && p_crlf == b || + Lazy.length b == 1 && p_lf == b + , buf_isEmpty = Lazy.null + } + where + p_crlf = Lazy.pack crlf + p_lf = Lazy.pack lf + +-- | @stringBufferOp@ is the 'BufferOp' definition over @String@s. +-- It is defined in terms of @strictBufferOp@ operations, +-- unpacking/converting to @String@ when needed. +stringBufferOp :: BufferOp String +stringBufferOp =BufferOp + { buf_hGet = \ h n -> buf_hGet strictBufferOp h n >>= return . Strict.unpack + , buf_hGetContents = \ h -> buf_hGetContents strictBufferOp h >>= return . Strict.unpack + , buf_hPut = \ h s -> buf_hPut strictBufferOp h (Strict.pack s) + , buf_hGetLine = \ h -> buf_hGetLine strictBufferOp h >>= return . Strict.unpack + , buf_append = (++) + , buf_concat = concat + , buf_fromStr = id + , buf_toStr = id + , buf_snoc = \ a x -> a ++ [toEnum (fromIntegral x)] + , buf_splitAt = splitAt + , buf_span = \ p a -> + case Strict.span p (Strict.pack a) of + (x,y) -> (Strict.unpack x, Strict.unpack y) + , buf_empty = [] + , buf_isLineTerm = \ b -> b == crlf || b == lf + , buf_isEmpty = null + } + diff --git a/Network/HTTP.hs b/Network/HTTP.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP.hs @@ -0,0 +1,229 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- The 'Network.HTTP' module provides a simple interface for sending and +-- receiving content over HTTP in Haskell. Here's how to fetch a document from +-- a URL and return it as a String: +-- +-- > +-- > simpleHTTP (getRequest "http://www.haskell.org/") >>= fmap (take 100) . getResponseBody +-- > -- fetch document and return it (as a 'String'.) +-- +-- Other functions let you control the submission and transfer of HTTP +-- 'Request's and 'Response's more carefully, letting you integrate the use +-- of 'Network.HTTP' functionality into your application. +-- +-- The module also exports the main types of the package, 'Request' and 'Response', +-- along with 'Header' and functions for working with these. +-- +-- The actual functionality is implemented by modules in the @Network.HTTP.*@ +-- namespace, letting you either use the default implementation here +-- by importing @Network.HTTP@ or, for more specific uses, selectively +-- import the modules in @Network.HTTP.*@. To wit, more than one kind of +-- representation of the bulk data that flows across a HTTP connection is +-- supported. (see "Network.HTTP.HandleStream".) +-- +-- /NOTE:/ The 'Request' send actions will normalize the @Request@ prior to transmission. +-- Normalization such as having the request path be in the expected form and, possibly, +-- introduce a default @Host:@ header if one isn't already present. If you do not +-- want the requests tampered with, but sent as-is, please import and use the +-- the "Network.HTTP.HandleStream" or "Network.HTTP.Stream" modules instead. They +-- export the same functions, but leaves construction and any normalization of +-- @Request@s to the user. +-- +-- /NOTE:/ This package only supports HTTP; it does not support HTTPS. +-- Attempts to use HTTPS result in an error. +----------------------------------------------------------------------------- +module Network.HTTP + ( module Network.HTTP.Base + , module Network.HTTP.Headers + + {- the functionality that the implementation modules, + Network.HTTP.HandleStream and Network.HTTP.Stream, + exposes: + -} + , simpleHTTP -- :: Request -> IO (Result Response) + , simpleHTTP_ -- :: Stream s => s -> Request -> IO (Result Response) + , sendHTTP -- :: Stream s => s -> Request -> IO (Result Response) + , sendHTTP_notify -- :: Stream s => s -> Request -> IO () -> IO (Result Response) + , receiveHTTP -- :: Stream s => s -> IO (Result Request) + , respondHTTP -- :: Stream s => s -> Response -> IO () + + , module Network.TCP + + , getRequest -- :: String -> Request_String + , postRequest -- :: String -> Request_String + , postRequestWithBody -- :: String -> String -> String -> Request_String + + , getResponseBody -- :: Requesty ty -> ty + ) where + +----------------------------------------------------------------- +------------------ Imports -------------------------------------- +----------------------------------------------------------------- + +import Network.HTTP.Headers +import Network.HTTP.Base +import qualified Network.HTTP.HandleStream as S +-- old implementation: import Network.HTTP.Stream +import Network.TCP +import Network.Stream ( Result ) +import Network.URI ( parseURI ) + +import Data.Maybe ( fromMaybe ) + +{- + Note: if you switch over/back to using Network.HTTP.Stream here, you'll + have to wrap the results from 'openStream' as Connections via 'hstreamToConnection' + prior to delegating to the Network.HTTP.Stream functions. +-} + +-- | @simpleHTTP req@ transmits the 'Request' @req@ by opening a /direct/, non-persistent +-- connection to the HTTP server that @req@ is destined for, followed by transmitting +-- it and gathering up the response as a 'Result'. Prior to sending the request, +-- it is normalized (via 'normalizeRequest'). If you have to mediate the request +-- via an HTTP proxy, you will have to normalize the request yourself. Or switch to +-- using 'Network.Browser' instead. +-- +-- Examples: +-- +-- > simpleHTTP (getRequest "http://hackage.haskell.org/") +-- > simpleHTTP (getRequest "http://hackage.haskell.org:8012/") + +simpleHTTP :: (HStream ty) => Request ty -> IO (Result (Response ty)) +simpleHTTP r = do + auth <- getAuth r + failHTTPS (rqURI r) + c <- openStream (host auth) (fromMaybe 80 (port auth)) + let norm_r = normalizeRequest defaultNormalizeRequestOptions{normDoClose=True} r + simpleHTTP_ c norm_r + +-- | Identical to 'simpleHTTP', but acting on an already opened stream. +simpleHTTP_ :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty)) +simpleHTTP_ s r = do + let norm_r = normalizeRequest defaultNormalizeRequestOptions{normDoClose=True} r + S.sendHTTP s norm_r + +-- | @sendHTTP hStream httpRequest@ transmits @httpRequest@ (after normalization) over +-- @hStream@, but does not alter the status of the connection, nor request it to be +-- closed upon receiving the response. +sendHTTP :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty)) +sendHTTP conn rq = do + let norm_r = normalizeRequest defaultNormalizeRequestOptions rq + S.sendHTTP conn norm_r + +-- | @sendHTTP_notify hStream httpRequest action@ behaves like 'sendHTTP', but +-- lets you supply an IO @action@ to execute once the request has been successfully +-- transmitted over the connection. Useful when you want to set up tracing of +-- request transmission and its performance. +sendHTTP_notify :: HStream ty + => HandleStream ty + -> Request ty + -> IO () + -> IO (Result (Response ty)) +sendHTTP_notify conn rq onSendComplete = do + let norm_r = normalizeRequest defaultNormalizeRequestOptions rq + S.sendHTTP_notify conn norm_r onSendComplete + +-- | @receiveHTTP hStream@ reads a 'Request' from the 'HandleStream' @hStream@ +receiveHTTP :: HStream ty => HandleStream ty -> IO (Result (Request ty)) +receiveHTTP conn = S.receiveHTTP conn + +-- | @respondHTTP hStream httpResponse@ transmits an HTTP 'Response' over +-- the 'HandleStream' @hStream@. It could be used to implement simple web +-- server interactions, performing the dual role to 'sendHTTP'. +respondHTTP :: HStream ty => HandleStream ty -> Response ty -> IO () +respondHTTP conn rsp = S.respondHTTP conn rsp + +-- | @getRequest urlString@ is convenience constructor for basic GET 'Request's. If +-- @urlString@ isn't a syntactically valid URL, the function raises an error. +getRequest :: String -> Request_String +getRequest urlString = + case parseURI urlString of + Nothing -> error ("getRequest: Not a valid URL - " ++ urlString) + Just u -> mkRequest GET u + +-- | @postRequest urlString@ is convenience constructor for POST 'Request's. If +-- @urlString@ isn\'t a syntactically valid URL, the function raises an error. +postRequest :: String -> Request_String +postRequest urlString = + case parseURI urlString of + Nothing -> error ("postRequest: Not a valid URL - " ++ urlString) + Just u -> mkRequest POST u + +-- | @postRequestWithBody urlString typ body@ is convenience constructor for +-- POST 'Request's. It constructs a request and sets the body as well as +-- the Content-Type and Content-Length headers. The contents of the body +-- are forced to calculate the value for the Content-Length header. +-- If @urlString@ isn\'t a syntactically valid URL, the function raises +-- an error. +postRequestWithBody :: String -> String -> String -> Request_String +postRequestWithBody urlString typ body = + case parseURI urlString of + Nothing -> error ("postRequestWithBody: Not a valid URL - " ++ urlString) + Just u -> setRequestBody (mkRequest POST u) (typ, body) + +-- | @getResponseBody response@ takes the response of a HTTP requesting action and +-- tries to extricate the body of the 'Response' @response@. If the request action +-- returned an error, an IO exception is raised. +getResponseBody :: Result (Response ty) -> IO ty +getResponseBody (Left err) = fail (show err) +getResponseBody (Right r) = return (rspBody r) + +-- +-- * TODO +-- - request pipelining +-- - https upgrade (includes full TLS, i.e. SSL, implementation) +-- - use of Stream classes will pay off +-- - consider C implementation of encryption\/decryption +-- - comm timeouts +-- - MIME & entity stuff (happening in separate module) +-- - support \"*\" uri-request-string for OPTIONS request method +-- +-- +-- * Header notes: +-- +-- [@Host@] +-- Required by HTTP\/1.1, if not supplied as part +-- of a request a default Host value is extracted +-- from the request-uri. +-- +-- [@Connection@] +-- If this header is present in any request or +-- response, and it's value is "close", then +-- the current request\/response is the last +-- to be allowed on that connection. +-- +-- [@Expect@] +-- Should a request contain a body, an Expect +-- header will be added to the request. The added +-- header has the value \"100-continue\". After +-- a 417 \"Expectation Failed\" response the request +-- is attempted again without this added Expect +-- header. +-- +-- [@TransferEncoding,ContentLength,...@] +-- if request is inconsistent with any of these +-- header values then you may not receive any response +-- or will generate an error response (probably 4xx). +-- +-- +-- * Response code notes +-- Some response codes induce special behaviour: +-- +-- [@1xx@] \"100 Continue\" will cause any unsent request body to be sent. +-- \"101 Upgrade\" will be returned. +-- Other 1xx responses are ignored. +-- +-- [@417@] The reason for this code is \"Expectation failed\", indicating +-- that the server did not like the Expect \"100-continue\" header +-- added to a request. Receipt of 417 will induce another +-- request attempt (without Expect header), unless no Expect header +-- had been added (in which case 417 response is returned). diff --git a/Network/HTTP/Auth.hs b/Network/HTTP/Auth.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Auth.hs @@ -0,0 +1,216 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.Auth +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- Representing HTTP Auth values in Haskell. +-- Right now, it contains mostly functionality needed by 'Network.Browser'. +-- +----------------------------------------------------------------------------- +module Network.HTTP.Auth + ( Authority(..) + , Algorithm(..) + , Challenge(..) + , Qop(..) + + , headerToChallenge -- :: URI -> Header -> Maybe Challenge + , withAuthority -- :: Authority -> Request ty -> String + ) where + +import Network.URI +import Network.HTTP.Base +import Network.HTTP.Utils +import Network.HTTP.Headers ( Header(..) ) +import qualified Network.HTTP.MD5Aux as MD5 (md5s, Str(Str)) +import qualified Network.HTTP.Base64 as Base64 (encode) +import Text.ParserCombinators.Parsec + ( Parser, char, many, many1, satisfy, parse, spaces, sepBy1 ) + +import Data.Char +import Data.Maybe +import Data.Word ( Word8 ) + +-- | @Authority@ specifies the HTTP Authentication method to use for +-- a given domain/realm; @Basic@ or @Digest@. +data Authority + = AuthBasic { auRealm :: String + , auUsername :: String + , auPassword :: String + , auSite :: URI + } + | AuthDigest{ auRealm :: String + , auUsername :: String + , auPassword :: String + , auNonce :: String + , auAlgorithm :: Maybe Algorithm + , auDomain :: [URI] + , auOpaque :: Maybe String + , auQop :: [Qop] + } + + +data Challenge + = ChalBasic { chRealm :: String } + | ChalDigest { chRealm :: String + , chDomain :: [URI] + , chNonce :: String + , chOpaque :: Maybe String + , chStale :: Bool + , chAlgorithm ::Maybe Algorithm + , chQop :: [Qop] + } + +-- | @Algorithm@ controls the digest algorithm to, @MD5@ or @MD5Session@. +data Algorithm = AlgMD5 | AlgMD5sess + deriving(Eq) + +instance Show Algorithm where + show AlgMD5 = "md5" + show AlgMD5sess = "md5-sess" + +-- | +data Qop = QopAuth | QopAuthInt + deriving(Eq,Show) + +-- | @withAuthority auth req@ generates a credentials value from the @auth@ 'Authority', +-- in the context of the given request. +-- +-- If a client nonce was to be used then this function might need to be of type ... -> BrowserAction String +withAuthority :: Authority -> Request ty -> String +withAuthority a rq = case a of + AuthBasic{} -> "Basic " ++ base64encode (auUsername a ++ ':' : auPassword a) + AuthDigest{} -> + "Digest " ++ + concat [ "username=" ++ quo (auUsername a) + , ",realm=" ++ quo (auRealm a) + , ",nonce=" ++ quo (auNonce a) + , ",uri=" ++ quo digesturi + , ",response=" ++ quo rspdigest + -- plus optional stuff: + , fromMaybe "" (fmap (\ alg -> ",algorithm=" ++ quo (show alg)) (auAlgorithm a)) + , fromMaybe "" (fmap (\ o -> ",opaque=" ++ quo o) (auOpaque a)) + , if null (auQop a) then "" else ",qop=auth" + ] + where + quo s = '"':s ++ "\"" + + rspdigest = map toLower (kd (md5 a1) (noncevalue ++ ":" ++ md5 a2)) + + a1, a2 :: String + a1 = auUsername a ++ ":" ++ auRealm a ++ ":" ++ auPassword a + + {- + If the "qop" directive's value is "auth" or is unspecified, then A2 + is: + A2 = Method ":" digest-uri-value + If the "qop" value is "auth-int", then A2 is: + A2 = Method ":" digest-uri-value ":" H(entity-body) + -} + a2 = show (rqMethod rq) ++ ":" ++ digesturi + + digesturi = show (rqURI rq) + noncevalue = auNonce a + +type Octet = Word8 + +-- FIXME: these probably only work right for latin-1 strings +stringToOctets :: String -> [Octet] +stringToOctets = map (fromIntegral . fromEnum) + +base64encode :: String -> String +base64encode = Base64.encode . stringToOctets + +md5 :: String -> String +md5 = MD5.md5s . MD5.Str + +kd :: String -> String -> String +kd a b = md5 (a ++ ":" ++ b) + + + + +-- | @headerToChallenge base www_auth@ tries to convert the @WWW-Authenticate@ header +-- @www_auth@ into a 'Challenge' value. +headerToChallenge :: URI -> Header -> Maybe Challenge +headerToChallenge baseURI (Header _ str) = + case parse challenge "" str of + Left{} -> Nothing + Right (name,props) -> case name of + "basic" -> mkBasic props + "digest" -> mkDigest props + _ -> Nothing + where + challenge :: Parser (String,[(String,String)]) + challenge = + do { nme <- word + ; spaces + ; pps <- cprops + ; return (map toLower nme,pps) + } + + cprops = sepBy1 cprop comma + + comma = do { spaces ; _ <- char ',' ; spaces } + + cprop = + do { nm <- word + ; _ <- char '=' + ; val <- quotedstring + ; return (map toLower nm,val) + } + + mkBasic, mkDigest :: [(String,String)] -> Maybe Challenge + + mkBasic params = fmap ChalBasic (lookup "realm" params) + + mkDigest params = + -- with Maybe monad + do { r <- lookup "realm" params + ; n <- lookup "nonce" params + ; return $ + ChalDigest { chRealm = r + , chDomain = (annotateURIs + $ map parseURI + $ words + $ fromMaybe [] + $ lookup "domain" params) + , chNonce = n + , chOpaque = lookup "opaque" params + , chStale = "true" == (map toLower + $ fromMaybe "" (lookup "stale" params)) + , chAlgorithm= readAlgorithm (fromMaybe "MD5" $ lookup "algorithm" params) + , chQop = readQop (fromMaybe "" $ lookup "qop" params) + } + } + + annotateURIs :: [Maybe URI] -> [URI] + annotateURIs = (map (\u -> fromMaybe u (u `relativeTo` baseURI))) . catMaybes + + -- Change These: + readQop :: String -> [Qop] + readQop = catMaybes . (map strToQop) . (splitBy ',') + + strToQop qs = case map toLower (trim qs) of + "auth" -> Just QopAuth + "auth-int" -> Just QopAuthInt + _ -> Nothing + + readAlgorithm astr = case map toLower (trim astr) of + "md5" -> Just AlgMD5 + "md5-sess" -> Just AlgMD5sess + _ -> Nothing + +word, quotedstring :: Parser String +quotedstring = + do { _ <- char '"' -- " + ; str <- many (satisfy $ not . (=='"')) + ; _ <- char '"' + ; return str + } + +word = many1 (satisfy (\x -> isAlphaNum x || x=='_' || x=='.' || x=='-' || x==':')) diff --git a/Network/HTTP/Base.hs b/Network/HTTP/Base.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Base.hs @@ -0,0 +1,895 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.Base +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- Definitions of @Request@ and @Response@ types along with functions +-- for normalizing them. It is assumed to be an internal module; user +-- code should, if possible, import @Network.HTTP@ to access the functionality +-- that this module provides. +-- +-- Additionally, the module exports internal functions for working with URLs, +-- and for handling the processing of requests and responses coming back. +-- +----------------------------------------------------------------------------- +module Network.HTTP.Base + ( + -- ** Constants + httpVersion -- :: String + + -- ** HTTP + , Request(..) + , Response(..) + , RequestMethod(..) + + , Request_String + , Response_String + , HTTPRequest + , HTTPResponse + + -- ** URL Encoding + , urlEncode + , urlDecode + , urlEncodeVars + + -- ** URI authority parsing + , URIAuthority(..) + , parseURIAuthority + + -- internal + , uriToAuthorityString -- :: URI -> String + , uriAuthToString -- :: URIAuth -> String + , uriAuthPort -- :: Maybe URI -> URIAuth -> Int + , reqURIAuth -- :: Request ty -> URIAuth + + , parseResponseHead -- :: [String] -> Result ResponseData + , parseRequestHead -- :: [String] -> Result RequestData + + , ResponseNextStep(..) + , matchResponse + , ResponseData + , ResponseCode + , RequestData + + , NormalizeRequestOptions(..) + , defaultNormalizeRequestOptions -- :: NormalizeRequestOptions ty + , RequestNormalizer + + , normalizeRequest -- :: NormalizeRequestOptions ty -> Request ty -> Request ty + + , splitRequestURI + + , getAuth + , normalizeRequestURI + , normalizeHostHeader + , findConnClose + + -- internal export (for the use by Network.HTTP.{Stream,ByteStream} ) + , linearTransfer + , hopefulTransfer + , chunkedTransfer + , uglyDeathTransfer + , readTillEmpty1 + , readTillEmpty2 + + , defaultGETRequest + , defaultGETRequest_ + , mkRequest + , setRequestBody + + , defaultUserAgent + , httpPackageVersion + , libUA {- backwards compatibility, will disappear..soon -} + + , catchIO + , catchIO_ + , responseParseError + + , getRequestVersion + , getResponseVersion + , setRequestVersion + , setResponseVersion + + , failHTTPS + + ) where + +import Network.URI + ( URI(uriAuthority, uriPath, uriScheme) + , URIAuth(URIAuth, uriUserInfo, uriRegName, uriPort) + , parseURIReference + ) + +import Control.Monad ( guard ) +import Control.Monad.Error () +import Data.Char ( digitToInt, intToDigit, toLower, isDigit, + isAscii, isAlphaNum ) +import Data.List ( partition, find ) +import Data.Maybe ( listToMaybe, fromMaybe ) +import Numeric ( readHex ) + +import Network.Stream +import Network.BufferType ( BufferOp(..), BufferType(..) ) +import Network.HTTP.Headers +import Network.HTTP.Utils ( trim, crlf, sp, readsOne ) + +import Text.Read.Lex (readDecP) +import Text.ParserCombinators.ReadP + ( ReadP, readP_to_S, char, (<++), look, munch ) + +import Control.Exception as Exception (IOException) + +import qualified Paths_cabal_install_bundle as Self (version) +import Data.Version (showVersion) + +----------------------------------------------------------------- +------------------ URI Authority parsing ------------------------ +----------------------------------------------------------------- + +data URIAuthority = URIAuthority { user :: Maybe String, + password :: Maybe String, + host :: String, + port :: Maybe Int + } deriving (Eq,Show) + +-- | Parse the authority part of a URL. +-- +-- > RFC 1732, section 3.1: +-- > +-- > //:@:/ +-- > Some or all of the parts ":@", ":", +-- > ":", and "/" may be excluded. +parseURIAuthority :: String -> Maybe URIAuthority +parseURIAuthority s = listToMaybe (map fst (readP_to_S pURIAuthority s)) + + +pURIAuthority :: ReadP URIAuthority +pURIAuthority = do + (u,pw) <- (pUserInfo `before` char '@') + <++ return (Nothing, Nothing) + h <- munch (/=':') + p <- orNothing (char ':' >> readDecP) + look >>= guard . null + return URIAuthority{ user=u, password=pw, host=h, port=p } + +pUserInfo :: ReadP (Maybe String, Maybe String) +pUserInfo = do + u <- orNothing (munch (`notElem` ":@")) + p <- orNothing (char ':' >> munch (/='@')) + return (u,p) + +before :: Monad m => m a -> m b -> m a +before a b = a >>= \x -> b >> return x + +orNothing :: ReadP a -> ReadP (Maybe a) +orNothing p = fmap Just p <++ return Nothing + +-- This function duplicates old Network.URI.authority behaviour. +uriToAuthorityString :: URI -> String +uriToAuthorityString u = maybe "" uriAuthToString (uriAuthority u) + +uriAuthToString :: URIAuth -> String +uriAuthToString ua = + concat [ uriUserInfo ua + , uriRegName ua + , uriPort ua + ] + +uriAuthPort :: Maybe URI -> URIAuth -> Int +uriAuthPort mbURI u = + case uriPort u of + (':':s) -> readsOne id (default_port mbURI) s + _ -> default_port mbURI + where + default_port Nothing = default_http + default_port (Just url) = + case map toLower $ uriScheme url of + "http:" -> default_http + "https:" -> default_https + -- todo: refine + _ -> default_http + + default_http = 80 + default_https = 443 + +failHTTPS :: Monad m => URI -> m () +failHTTPS uri + | map toLower (uriScheme uri) == "https:" = fail "https not supported" + | otherwise = return () + +-- Fish out the authority from a possibly normalized Request, i.e., +-- the information may either be in the request's URI or inside +-- the Host: header. +reqURIAuth :: Request ty -> URIAuth +reqURIAuth req = + case uriAuthority (rqURI req) of + Just ua -> ua + _ -> case lookupHeader HdrHost (rqHeaders req) of + Nothing -> error ("reqURIAuth: no URI authority for: " ++ show req) + Just h -> + case toHostPort h of + (ht,p) -> URIAuth { uriUserInfo = "" + , uriRegName = ht + , uriPort = p + } + where + -- Note: just in case you're wondering..the convention is to include the ':' + -- in the port part.. + toHostPort h = break (==':') h + +----------------------------------------------------------------- +------------------ HTTP Messages -------------------------------- +----------------------------------------------------------------- + + +-- Protocol version +httpVersion :: String +httpVersion = "HTTP/1.1" + + +-- | The HTTP request method, to be used in the 'Request' object. +-- We are missing a few of the stranger methods, but these are +-- not really necessary until we add full TLS. +data RequestMethod = HEAD | PUT | GET | POST | DELETE | OPTIONS | TRACE | CONNECT | Custom String + deriving(Eq) + +instance Show RequestMethod where + show x = + case x of + HEAD -> "HEAD" + PUT -> "PUT" + GET -> "GET" + POST -> "POST" + DELETE -> "DELETE" + OPTIONS -> "OPTIONS" + TRACE -> "TRACE" + CONNECT -> "CONNECT" + Custom c -> c + +rqMethodMap :: [(String, RequestMethod)] +rqMethodMap = [("HEAD", HEAD), + ("PUT", PUT), + ("GET", GET), + ("POST", POST), + ("DELETE", DELETE), + ("OPTIONS", OPTIONS), + ("TRACE", TRACE), + ("CONNECT", CONNECT)] + +-- +-- for backwards-ish compatibility; suggest +-- migrating to new Req/Resp by adding type param. +-- +type Request_String = Request String +type Response_String = Response String + +-- Hmm..I really want to use these for the record +-- type, but it will upset codebases wanting to +-- migrate (and live with using pre-HTTPbis versions.) +type HTTPRequest a = Request a +type HTTPResponse a = Response a + +-- | An HTTP Request. +-- The 'Show' instance of this type is used for message serialisation, +-- which means no body data is output. +data Request a = + Request { rqURI :: URI -- ^ might need changing in future + -- 1) to support '*' uri in OPTIONS request + -- 2) transparent support for both relative + -- & absolute uris, although this should + -- already work (leave scheme & host parts empty). + , rqMethod :: RequestMethod + , rqHeaders :: [Header] + , rqBody :: a + } + +-- Notice that request body is not included, +-- this show function is used to serialise +-- a request for the transport link, we send +-- the body separately where possible. +instance Show (Request a) where + show req@(Request u m h _) = + show m ++ sp ++ alt_uri ++ sp ++ ver ++ crlf + ++ foldr (++) [] (map show (dropHttpVersion h)) ++ crlf + where + ver = fromMaybe httpVersion (getRequestVersion req) + alt_uri = show $ if null (uriPath u) || head (uriPath u) /= '/' + then u { uriPath = '/' : uriPath u } + else u + +instance HasHeaders (Request a) where + getHeaders = rqHeaders + setHeaders rq hdrs = rq { rqHeaders=hdrs } + +-- | For easy pattern matching, HTTP response codes @xyz@ are +-- represented as @(x,y,z)@. +type ResponseCode = (Int,Int,Int) + +-- | @ResponseData@ contains the head of a response payload; +-- HTTP response code, accompanying text description + header +-- fields. +type ResponseData = (ResponseCode,String,[Header]) + +-- | @RequestData@ contains the head of a HTTP request; method, +-- its URL along with the auxillary/supporting header data. +type RequestData = (RequestMethod,URI,[Header]) + +-- | An HTTP Response. +-- The 'Show' instance of this type is used for message serialisation, +-- which means no body data is output, additionally the output will +-- show an HTTP version of 1.1 instead of the actual version returned +-- by a server. +data Response a = + Response { rspCode :: ResponseCode + , rspReason :: String + , rspHeaders :: [Header] + , rspBody :: a + } + +-- This is an invalid representation of a received response, +-- since we have made the assumption that all responses are HTTP/1.1 +instance Show (Response a) where + show rsp@(Response (a,b,c) reason headers _) = + ver ++ ' ' : map intToDigit [a,b,c] ++ ' ' : reason ++ crlf + ++ foldr (++) [] (map show (dropHttpVersion headers)) ++ crlf + where + ver = fromMaybe httpVersion (getResponseVersion rsp) + +instance HasHeaders (Response a) where + getHeaders = rspHeaders + setHeaders rsp hdrs = rsp { rspHeaders=hdrs } + + +------------------------------------------------------------------ +------------------ Request Building ------------------------------ +------------------------------------------------------------------ + +-- | Deprecated. Use 'defaultUserAgent' +libUA :: String +libUA = "hs-HTTP-4000.0.9" +{-# DEPRECATED libUA "Use defaultUserAgent instead (but note the user agent name change)" #-} + +-- | A default user agent string. The string is @\"haskell-HTTP/$version\"@ +-- where @$version@ is the version of this HTTP package. +-- +defaultUserAgent :: String +defaultUserAgent = "haskell-HTTP/" ++ httpPackageVersion + +-- | The version of this HTTP package as a string, e.g. @\"4000.1.2\"@. This +-- may be useful to include in a user agent string so that you can determine +-- from server logs what version of this package HTTP clients are using. +-- This can be useful for tracking down HTTP compatibility quirks. +-- +httpPackageVersion :: String +httpPackageVersion = showVersion Self.version + +defaultGETRequest :: URI -> Request_String +defaultGETRequest uri = defaultGETRequest_ uri + +defaultGETRequest_ :: BufferType a => URI -> Request a +defaultGETRequest_ uri = mkRequest GET uri + +-- | 'mkRequest method uri' constructs a well formed +-- request for the given HTTP method and URI. It does not +-- normalize the URI for the request _nor_ add the required +-- Host: header. That is done either explicitly by the user +-- or when requests are normalized prior to transmission. +mkRequest :: BufferType ty => RequestMethod -> URI -> Request ty +mkRequest meth uri = req + where + req = + Request { rqURI = uri + , rqBody = empty + , rqHeaders = [ Header HdrContentLength "0" + , Header HdrUserAgent defaultUserAgent + ] + , rqMethod = meth + } + + empty = buf_empty (toBufOps req) + +-- set rqBody, Content-Type and Content-Length headers. +setRequestBody :: Request_String -> (String, String) -> Request_String +setRequestBody req (typ, body) = req' { rqBody=body } + where + req' = replaceHeader HdrContentType typ . + replaceHeader HdrContentLength (show $ length body) $ + req + +{- + -- stub out the user info. + updAuth = fmap (\ x -> x{uriUserInfo=""}) (uriAuthority uri) + + withHost = + case uriToAuthorityString uri{uriAuthority=updAuth} of + "" -> id + h -> ((Header HdrHost h):) + + uri_req + | forProxy = uri + | otherwise = snd (splitRequestURI uri) +-} + + +toBufOps :: BufferType a => Request a -> BufferOp a +toBufOps _ = bufferOps + +----------------------------------------------------------------- +------------------ Parsing -------------------------------------- +----------------------------------------------------------------- + +-- Parsing a request +parseRequestHead :: [String] -> Result RequestData +parseRequestHead [] = Left ErrorClosed +parseRequestHead (com:hdrs) = do + (version,rqm,uri) <- requestCommand com (words com) + hdrs' <- parseHeaders hdrs + return (rqm,uri,withVer version hdrs') + where + withVer [] hs = hs + withVer (h:_) hs = withVersion h hs + + requestCommand l _yes@(rqm:uri:version) = + case (parseURIReference uri, lookup rqm rqMethodMap) of + (Just u, Just r) -> return (version,r,u) + (Just u, Nothing) -> return (version,Custom rqm,u) + _ -> parse_err l + requestCommand l _ + | null l = failWith ErrorClosed + | otherwise = parse_err l + + parse_err l = responseParseError "parseRequestHead" + ("Request command line parse failure: " ++ l) + +-- Parsing a response +parseResponseHead :: [String] -> Result ResponseData +parseResponseHead [] = failWith ErrorClosed +parseResponseHead (sts:hdrs) = do + (version,code,reason) <- responseStatus sts (words sts) + hdrs' <- parseHeaders hdrs + return (code,reason, withVersion version hdrs') + where + responseStatus _l _yes@(version:code:reason) = + return (version,match code,concatMap (++" ") reason) + responseStatus l _no + | null l = failWith ErrorClosed -- an assumption + | otherwise = parse_err l + + parse_err l = + responseParseError + "parseResponseHead" + ("Response status line parse failure: " ++ l) + + match [a,b,c] = (digitToInt a, + digitToInt b, + digitToInt c) + match _ = (-1,-1,-1) -- will create appropriate behaviour + +-- To avoid changing the @RequestData@ and @ResponseData@ types +-- just for this (and the upstream backwards compat. woes that +-- will result in), encode version info as a custom header. +-- Used by 'parseResponseData' and 'parseRequestData'. +-- +-- Note: the Request and Response types do not currently represent +-- the version info explicitly in their record types. You have to use +-- {get,set}{Request,Response}Version for that. +withVersion :: String -> [Header] -> [Header] +withVersion v hs + | v == httpVersion = hs -- don't bother adding it if the default. + | otherwise = (Header (HdrCustom "X-HTTP-Version") v) : hs + +-- | @getRequestVersion req@ returns the HTTP protocol version of +-- the request @req@. If @Nothing@, the default 'httpVersion' can be assumed. +getRequestVersion :: Request a -> Maybe String +getRequestVersion r = getHttpVersion r + +-- | @setRequestVersion v req@ returns a new request, identical to +-- @req@, but with its HTTP version set to @v@. +setRequestVersion :: String -> Request a -> Request a +setRequestVersion s r = setHttpVersion r s + + +-- | @getResponseVersion rsp@ returns the HTTP protocol version of +-- the response @rsp@. If @Nothing@, the default 'httpVersion' can be +-- assumed. +getResponseVersion :: Response a -> Maybe String +getResponseVersion r = getHttpVersion r + +-- | @setResponseVersion v rsp@ returns a new response, identical to +-- @rsp@, but with its HTTP version set to @v@. +setResponseVersion :: String -> Response a -> Response a +setResponseVersion s r = setHttpVersion r s + +-- internal functions for accessing HTTP-version info in +-- requests and responses. Not exported as it exposes ho +-- version info is represented internally. + +getHttpVersion :: HasHeaders a => a -> Maybe String +getHttpVersion r = + fmap toVersion $ + find isHttpVersion $ + getHeaders r + where + toVersion (Header _ x) = x + +setHttpVersion :: HasHeaders a => a -> String -> a +setHttpVersion r v = + setHeaders r $ + withVersion v $ + dropHttpVersion $ + getHeaders r + +dropHttpVersion :: [Header] -> [Header] +dropHttpVersion hs = filter (not.isHttpVersion) hs + +isHttpVersion :: Header -> Bool +isHttpVersion (Header (HdrCustom "X-HTTP-Version") _) = True +isHttpVersion _ = False + + + +----------------------------------------------------------------- +------------------ HTTP Send / Recv ---------------------------------- +----------------------------------------------------------------- + +data ResponseNextStep + = Continue + | Retry + | Done + | ExpectEntity + | DieHorribly String + +matchResponse :: RequestMethod -> ResponseCode -> ResponseNextStep +matchResponse rqst rsp = + case rsp of + (1,0,0) -> Continue + (1,0,1) -> Done -- upgrade to TLS + (1,_,_) -> Continue -- default + (2,0,4) -> Done + (2,0,5) -> Done + (2,_,_) -> ans + (3,0,4) -> Done + (3,0,5) -> Done + (3,_,_) -> ans + (4,1,7) -> Retry -- Expectation failed + (4,_,_) -> ans + (5,_,_) -> ans + (a,b,c) -> DieHorribly ("Response code " ++ map intToDigit [a,b,c] ++ " not recognised") + where + ans | rqst == HEAD = Done + | otherwise = ExpectEntity + + + +----------------------------------------------------------------- +------------------ A little friendly funtionality --------------- +----------------------------------------------------------------- + + +{- + I had a quick look around but couldn't find any RFC about + the encoding of data on the query string. I did find an + IETF memo, however, so this is how I justify the urlEncode + and urlDecode methods. + + Doc name: draft-tiwari-appl-wxxx-forms-01.txt (look on www.ietf.org) + + Reserved chars: ";", "/", "?", ":", "@", "&", "=", "+", ",", and "$" are reserved. + Unwise: "{" | "}" | "|" | "\" | "^" | "[" | "]" | "`" + URI delims: "<" | ">" | "#" | "%" | <"> + Unallowed ASCII: + + Also unallowed: any non-us-ascii character + + Escape method: char -> '%' a b where a, b :: Hex digits +-} + +urlDecode :: String -> String +urlDecode ('%':a:b:rest) = toEnum (16 * digitToInt a + digitToInt b) + : urlDecode rest +urlDecode (h:t) = h : urlDecode t +urlDecode [] = [] + + +urlEncode :: String -> String +urlEncode [] = [] +urlEncode (ch:t) + | (isAscii ch && isAlphaNum ch) || ch `elem` "-_.~" = ch : urlEncode t + | not (isAscii ch) = foldr escape (urlEncode t) (eightBs [] (fromEnum ch)) + | otherwise = escape (fromEnum ch) (urlEncode t) + where + escape b rs = '%':showH (b `div` 16) (showH (b `mod` 16) rs) + + showH x xs + | x <= 9 = toEnum (o_0 + x) : xs + | otherwise = toEnum (o_A + (x-10)) : xs + where + o_0 = fromEnum '0' + o_A = fromEnum 'A' + + eightBs :: [Int] -> Int -> [Int] + eightBs acc x + | x <= 0xff = (x:acc) + | otherwise = eightBs ((x `mod` 256) : acc) (x `div` 256) + +-- Encode form variables, useable in either the +-- query part of a URI, or the body of a POST request. +-- I have no source for this information except experience, +-- this sort of encoding worked fine in CGI programming. +urlEncodeVars :: [(String,String)] -> String +urlEncodeVars ((n,v):t) = + let (same,diff) = partition ((==n) . fst) t + in urlEncode n ++ '=' : foldl (\x y -> x ++ ',' : urlEncode y) (urlEncode $ v) (map snd same) + ++ urlEncodeRest diff + where urlEncodeRest [] = [] + urlEncodeRest diff = '&' : urlEncodeVars diff +urlEncodeVars [] = [] + +-- | @getAuth req@ fishes out the authority portion of the URL in a request's @Host@ +-- header. +getAuth :: Monad m => Request ty -> m URIAuthority +getAuth r = + -- ToDo: verify that Network.URI functionality doesn't take care of this (now.) + case parseURIAuthority auth of + Just x -> return x + Nothing -> fail $ "Network.HTTP.Base.getAuth: Error parsing URI authority '" ++ auth ++ "'" + where + auth = maybe (uriToAuthorityString uri) id (findHeader HdrHost r) + uri = rqURI r + +{-# DEPRECATED normalizeRequestURI "Please use Network.HTTP.Base.normalizeRequest instead" #-} +normalizeRequestURI :: Bool{-do close-} -> {-URI-}String -> Request ty -> Request ty +normalizeRequestURI doClose h r = + (if doClose then replaceHeader HdrConnection "close" else id) $ + insertHeaderIfMissing HdrHost h $ + r { rqURI = (rqURI r){ uriScheme = "" + , uriAuthority = Nothing + }} + +-- | @NormalizeRequestOptions@ brings together the various defaulting\/normalization options +-- over 'Request's. Use 'defaultNormalizeRequestOptions' for the standard selection of option +data NormalizeRequestOptions ty + = NormalizeRequestOptions + { normDoClose :: Bool + , normForProxy :: Bool + , normUserAgent :: Maybe String + , normCustoms :: [RequestNormalizer ty] + } + +-- | @RequestNormalizer@ is the shape of a (pure) function that rewrites +-- a request into some normalized form. +type RequestNormalizer ty = NormalizeRequestOptions ty -> Request ty -> Request ty + +defaultNormalizeRequestOptions :: NormalizeRequestOptions ty +defaultNormalizeRequestOptions = NormalizeRequestOptions + { normDoClose = False + , normForProxy = False + , normUserAgent = Just defaultUserAgent + , normCustoms = [] + } + +-- | @normalizeRequest opts req@ is the entry point to use to normalize your +-- request prior to transmission (or other use.) Normalization is controlled +-- via the @NormalizeRequestOptions@ record. +normalizeRequest :: NormalizeRequestOptions ty + -> Request ty + -> Request ty +normalizeRequest opts req = foldr (\ f -> f opts) req normalizers + where + --normalizers :: [RequestNormalizer ty] + normalizers = + ( normalizeHostURI + : normalizeConnectionClose + : normalizeUserAgent + : normCustoms opts + ) + +-- | @normalizeUserAgent ua x req@ augments the request @req@ with +-- a @User-Agent: ua@ header if @req@ doesn't already have a +-- a @User-Agent:@ set. +normalizeUserAgent :: RequestNormalizer ty +normalizeUserAgent opts req = + case normUserAgent opts of + Nothing -> req + Just ua -> + case findHeader HdrUserAgent req of + Just u | u /= defaultUserAgent -> req + _ -> replaceHeader HdrUserAgent ua req + +-- | @normalizeConnectionClose opts req@ sets the header @Connection: close@ +-- to indicate one-shot behavior iff @normDoClose@ is @True@. i.e., it then +-- _replaces_ any an existing @Connection:@ header in @req@. +normalizeConnectionClose :: RequestNormalizer ty +normalizeConnectionClose opts req + | normDoClose opts = replaceHeader HdrConnection "close" req + | otherwise = req + +-- | @normalizeHostURI forProxy req@ rewrites your request to have it +-- follow the expected formats by the receiving party (proxy or server.) +-- +normalizeHostURI :: RequestNormalizer ty +normalizeHostURI opts req = + case splitRequestURI uri of + ("",_uri_abs) + | forProxy -> + case findHeader HdrHost req of + Nothing -> req -- no host/authority in sight..not much we can do. + Just h -> req{rqURI=uri{ uriAuthority=Just URIAuth{uriUserInfo="", uriRegName=hst, uriPort=pNum} + , uriScheme=if (null (uriScheme uri)) then "http" else uriScheme uri + }} + where + hst = case span (/='@') user_hst of + (as,'@':bs) -> + case span (/=':') as of + (_,_:_) -> bs + _ -> user_hst + _ -> user_hst + + (user_hst, pNum) = + case span isDigit (reverse h) of + (ds,':':bs) -> (reverse bs, ':':reverse ds) + _ -> (h,"") + | otherwise -> + case findHeader HdrHost req of + Nothing -> req -- no host/authority in sight..not much we can do...complain? + Just{} -> req + (h,uri_abs) + | forProxy -> insertHeaderIfMissing HdrHost h req + | otherwise -> replaceHeader HdrHost h req{rqURI=uri_abs} -- Note: _not_ stubbing out user:pass + where + uri0 = rqURI req + -- stub out the user:pass + uri = uri0{uriAuthority=fmap (\ x -> x{uriUserInfo=""}) (uriAuthority uri0)} + + forProxy = normForProxy opts + +{- Comments re: above rewriting: + RFC 2616, section 5.1.2: + "The most common form of Request-URI is that used to identify a + resource on an origin server or gateway. In this case the absolute + path of the URI MUST be transmitted (see section 3.2.1, abs_path) as + the Request-URI, and the network location of the URI (authority) MUST + be transmitted in a Host header field." + We assume that this is the case, so we take the host name from + the Host header if there is one, otherwise from the request-URI. + Then we make the request-URI an abs_path and make sure that there + is a Host header. +-} + +splitRequestURI :: URI -> ({-authority-}String, URI) +splitRequestURI uri = (uriToAuthorityString uri, uri{uriScheme="", uriAuthority=Nothing}) + +-- Adds a Host header if one is NOT ALREADY PRESENT.. +{-# DEPRECATED normalizeHostHeader "Please use Network.HTTP.Base.normalizeRequest instead" #-} +normalizeHostHeader :: Request ty -> Request ty +normalizeHostHeader rq = + insertHeaderIfMissing HdrHost + (uriToAuthorityString $ rqURI rq) + rq + +-- Looks for a "Connection" header with the value "close". +-- Returns True when this is found. +findConnClose :: [Header] -> Bool +findConnClose hdrs = + maybe False + (\ x -> map toLower (trim x) == "close") + (lookupHeader HdrConnection hdrs) + +-- | Used when we know exactly how many bytes to expect. +linearTransfer :: (Int -> IO (Result a)) -> Int -> IO (Result ([Header],a)) +linearTransfer readBlk n = fmapE (\str -> Right ([],str)) (readBlk n) + +-- | Used when nothing about data is known, +-- Unfortunately waiting for a socket closure +-- causes bad behaviour. Here we just +-- take data once and give up the rest. +hopefulTransfer :: BufferOp a + -> IO (Result a) + -> [a] + -> IO (Result ([Header],a)) +hopefulTransfer bufOps readL strs + = readL >>= + either (\v -> return $ Left v) + (\more -> if (buf_isEmpty bufOps more) + then return (Right ([],foldr (flip (buf_append bufOps)) (buf_empty bufOps) strs)) + else hopefulTransfer bufOps readL (more:strs)) + +-- | A necessary feature of HTTP\/1.1 +-- Also the only transfer variety likely to +-- return any footers. +chunkedTransfer :: BufferOp a + -> IO (Result a) + -> (Int -> IO (Result a)) + -> IO (Result ([Header], a)) +chunkedTransfer bufOps readL readBlk = chunkedTransferC bufOps readL readBlk [] 0 + +chunkedTransferC :: BufferOp a + -> IO (Result a) + -> (Int -> IO (Result a)) + -> [a] + -> Int + -> IO (Result ([Header], a)) +chunkedTransferC bufOps readL readBlk acc n = do + v <- readL + case v of + Left e -> return (Left e) + Right line + | size == 0 -> + -- last chunk read; look for trailing headers.. + fmapE (\ strs -> do + ftrs <- parseHeaders (map (buf_toStr bufOps) strs) + -- insert (computed) Content-Length header. + let ftrs' = Header HdrContentLength (show n) : ftrs + return (ftrs',buf_concat bufOps (reverse acc))) + + (readTillEmpty2 bufOps readL []) + + | otherwise -> do + some <- readBlk size + case some of + Left e -> return (Left e) + Right cdata -> do + _ <- readL -- CRLF is mandated after the chunk block; ToDo: check that the line is empty.? + chunkedTransferC bufOps readL readBlk (cdata:acc) (n+size) + where + size + | buf_isEmpty bufOps line = 0 + | otherwise = + case readHex (buf_toStr bufOps line) of + (hx,_):_ -> hx + _ -> 0 + +-- | Maybe in the future we will have a sensible thing +-- to do here, at that time we might want to change +-- the name. +uglyDeathTransfer :: String -> IO (Result ([Header],a)) +uglyDeathTransfer loc = return (responseParseError loc "Unknown Transfer-Encoding") + +-- | Remove leading crlfs then call readTillEmpty2 (not required by RFC) +readTillEmpty1 :: BufferOp a + -> IO (Result a) + -> IO (Result [a]) +readTillEmpty1 bufOps readL = + readL >>= + either (return . Left) + (\ s -> + if buf_isLineTerm bufOps s + then readTillEmpty1 bufOps readL + else readTillEmpty2 bufOps readL [s]) + +-- | Read lines until an empty line (CRLF), +-- also accepts a connection close as end of +-- input, which is not an HTTP\/1.1 compliant +-- thing to do - so probably indicates an +-- error condition. +readTillEmpty2 :: BufferOp a + -> IO (Result a) + -> [a] + -> IO (Result [a]) +readTillEmpty2 bufOps readL list = + readL >>= + either (return . Left) + (\ s -> + if buf_isLineTerm bufOps s || buf_isEmpty bufOps s + then return (Right $ reverse (s:list)) + else readTillEmpty2 bufOps readL (s:list)) + +-- +-- Misc +-- + +-- | @catchIO a h@ handles IO action exceptions throughout codebase; version-specific +-- tweaks better go here. +catchIO :: IO a -> (IOException -> IO a) -> IO a +catchIO a h = Prelude.catch a h + +catchIO_ :: IO a -> IO a -> IO a +catchIO_ a h = Prelude.catch a (const h) + +responseParseError :: String -> String -> Result a +responseParseError loc v = failWith (ErrorParse (loc ++ ' ':v)) diff --git a/Network/HTTP/Base64.hs b/Network/HTTP/Base64.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Base64.hs @@ -0,0 +1,282 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Codec.Binary.Base64 +-- Copyright : (c) Dominic Steinitz 2005, Warrick Gray 2002 +-- License : BSD-style (see the file ReadMe.tex) +-- +-- Maintainer : dominic.steinitz@blueyonder.co.uk +-- Stability : experimental +-- Portability : portable +-- +-- Base64 encoding and decoding functions provided by Warwick Gray. +-- See +-- and . +-- +----------------------------------------------------------------------------- + +module Network.HTTP.Base64 + ( encode + , decode + , chop72 + , Octet + ) where + +{------------------------------------------------------------------------ +This is what RFC2045 had to say: + +6.8. Base64 Content-Transfer-Encoding + + The Base64 Content-Transfer-Encoding is designed to represent + arbitrary sequences of octets in a form that need not be humanly + readable. The encoding and decoding algorithms are simple, but the + encoded data are consistently only about 33 percent larger than the + unencoded data. This encoding is virtually identical to the one used + in Privacy Enhanced Mail (PEM) applications, as defined in RFC 1421. + + A 65-character subset of US-ASCII is used, enabling 6 bits to be + represented per printable character. (The extra 65th character, "=", + is used to signify a special processing function.) + + NOTE: This subset has the important property that it is represented + identically in all versions of ISO 646, including US-ASCII, and all + characters in the subset are also represented identically in all + versions of EBCDIC. Other popular encodings, such as the encoding + used by the uuencode utility, Macintosh binhex 4.0 [RFC-1741], and + the base85 encoding specified as part of Level 2 PostScript, do not + share these properties, and thus do not fulfill the portability + requirements a binary transport encoding for mail must meet. + + The encoding process represents 24-bit groups of input bits as output + strings of 4 encoded characters. Proceeding from left to right, a + 24-bit input group is formed by concatenating 3 8bit input groups. + These 24 bits are then treated as 4 concatenated 6-bit groups, each + of which is translated into a single digit in the base64 alphabet. + When encoding a bit stream via the base64 encoding, the bit stream + must be presumed to be ordered with the most-significant-bit first. + That is, the first bit in the stream will be the high-order bit in + the first 8bit byte, and the eighth bit will be the low-order bit in + the first 8bit byte, and so on. + + Each 6-bit group is used as an index into an array of 64 printable + characters. The character referenced by the index is placed in the + output string. These characters, identified in Table 1, below, are + selected so as to be universally representable, and the set excludes + characters with particular significance to SMTP (e.g., ".", CR, LF) + and to the multipart boundary delimiters defined in RFC 2046 (e.g., + "-"). + + + + Table 1: The Base64 Alphabet + + Value Encoding Value Encoding Value Encoding Value Encoding + 0 A 17 R 34 i 51 z + 1 B 18 S 35 j 52 0 + 2 C 19 T 36 k 53 1 + 3 D 20 U 37 l 54 2 + 4 E 21 V 38 m 55 3 + 5 F 22 W 39 n 56 4 + 6 G 23 X 40 o 57 5 + 7 H 24 Y 41 p 58 6 + 8 I 25 Z 42 q 59 7 + 9 J 26 a 43 r 60 8 + 10 K 27 b 44 s 61 9 + 11 L 28 c 45 t 62 + + 12 M 29 d 46 u 63 / + 13 N 30 e 47 v + 14 O 31 f 48 w (pad) = + 15 P 32 g 49 x + 16 Q 33 h 50 y + + The encoded output stream must be represented in lines of no more + than 76 characters each. All line breaks or other characters not + found in Table 1 must be ignored by decoding software. In base64 + data, characters other than those in Table 1, line breaks, and other + white space probably indicate a transmission error, about which a + warning message or even a message rejection might be appropriate + under some circumstances. + + Special processing is performed if fewer than 24 bits are available + at the end of the data being encoded. A full encoding quantum is + always completed at the end of a body. When fewer than 24 input bits + are available in an input group, zero bits are added (on the right) + to form an integral number of 6-bit groups. Padding at the end of + the data is performed using the "=" character. Since all base64 + input is an integral number of octets, only the following cases can + arise: (1) the final quantum of encoding input is an integral + multiple of 24 bits; here, the final unit of encoded output will be + an integral multiple of 4 characters with no "=" padding, (2) the + final quantum of encoding input is exactly 8 bits; here, the final + unit of encoded output will be two characters followed by two "=" + padding characters, or (3) the final quantum of encoding input is + exactly 16 bits; here, the final unit of encoded output will be three + characters followed by one "=" padding character. + + Because it is used only for padding at the end of the data, the + occurrence of any "=" characters may be taken as evidence that the + end of the data has been reached (without truncation in transit). No + such assurance is possible, however, when the number of octets + transmitted was a multiple of three and no "=" characters are + present. + + Any characters outside of the base64 alphabet are to be ignored in + base64-encoded data. + + Care must be taken to use the proper octets for line breaks if base64 + encoding is applied directly to text material that has not been + converted to canonical form. In particular, text line breaks must be + converted into CRLF sequences prior to base64 encoding. The + important thing to note is that this may be done directly by the + encoder rather than in a prior canonicalization step in some + implementations. + + NOTE: There is no need to worry about quoting potential boundary + delimiters within base64-encoded bodies within multipart entities + because no hyphen characters are used in the base64 encoding. + +----------------------------------------------------------------------------} + +{- + +The following properties should hold: + + decode . encode = id + decode . chop72 . encode = id + +I.E. Both "encode" and "chop72 . encode" are valid methods of encoding input, +the second variation corresponds better with the RFC above, but outside of +MIME applications might be undesireable. + + +But: The Haskell98 Char type is at least 16bits (and often 32), these implementations assume only + 8 significant bits, which is more than enough for US-ASCII. +-} + + +import Data.Array (Array, array, (!)) +import Data.Bits (shiftL, shiftR, (.&.), (.|.)) +import Data.Char (chr, ord) +import Data.Word (Word8) + +type Octet = Word8 + +encodeArray :: Array Int Char +encodeArray = array (0,64) + [ (0,'A'), (1,'B'), (2,'C'), (3,'D'), (4,'E'), (5,'F') + , (6,'G'), (7,'H'), (8,'I'), (9,'J'), (10,'K'), (11,'L') + , (12,'M'), (13,'N'), (14,'O'), (15,'P'), (16,'Q'), (17,'R') + , (18,'S'), (19,'T'), (20,'U'), (21,'V'), (22,'W'), (23,'X') + , (24,'Y'), (25,'Z'), (26,'a'), (27,'b'), (28,'c'), (29,'d') + , (30,'e'), (31,'f'), (32,'g'), (33,'h'), (34,'i'), (35,'j') + , (36,'k'), (37,'l'), (38,'m'), (39,'n'), (40,'o'), (41,'p') + , (42,'q'), (43,'r'), (44,'s'), (45,'t'), (46,'u'), (47,'v') + , (48,'w'), (49,'x'), (50,'y'), (51,'z'), (52,'0'), (53,'1') + , (54,'2'), (55,'3'), (56,'4'), (57,'5'), (58,'6'), (59,'7') + , (60,'8'), (61,'9'), (62,'+'), (63,'/') ] + + +-- Convert between 4 base64 (6bits ea) integers and 1 ordinary integer (32 bits) +-- clearly the upmost/leftmost 8 bits of the answer are 0. +-- Hack Alert: In the last entry of the answer, the upper 8 bits encode +-- the integer number of 6bit groups encoded in that integer, ie 1, 2, 3. +-- 0 represents a 4 :( +int4_char3 :: [Int] -> [Char] +int4_char3 (a:b:c:d:t) = + let n = (a `shiftL` 18 .|. b `shiftL` 12 .|. c `shiftL` 6 .|. d) + in (chr (n `shiftR` 16 .&. 0xff)) + : (chr (n `shiftR` 8 .&. 0xff)) + : (chr (n .&. 0xff)) : int4_char3 t + +int4_char3 [a,b,c] = + let n = (a `shiftL` 18 .|. b `shiftL` 12 .|. c `shiftL` 6) + in [ (chr (n `shiftR` 16 .&. 0xff)) + , (chr (n `shiftR` 8 .&. 0xff)) ] + +int4_char3 [a,b] = + let n = (a `shiftL` 18 .|. b `shiftL` 12) + in [ (chr (n `shiftR` 16 .&. 0xff)) ] + +int4_char3 [_] = error "Network.HTTP.Base64.int4_char3: impossible number of Ints." + +int4_char3 [] = [] + + + + +-- Convert triplets of characters to +-- 4 base64 integers. The last entries +-- in the list may not produce 4 integers, +-- a trailing 2 character group gives 3 integers, +-- while a trailing single character gives 2 integers. +char3_int4 :: [Char] -> [Int] +char3_int4 (a:b:c:t) + = let n = (ord a `shiftL` 16 .|. ord b `shiftL` 8 .|. ord c) + in (n `shiftR` 18 .&. 0x3f) : (n `shiftR` 12 .&. 0x3f) : (n `shiftR` 6 .&. 0x3f) : (n .&. 0x3f) : char3_int4 t + +char3_int4 [a,b] + = let n = (ord a `shiftL` 16 .|. ord b `shiftL` 8) + in [ (n `shiftR` 18 .&. 0x3f) + , (n `shiftR` 12 .&. 0x3f) + , (n `shiftR` 6 .&. 0x3f) ] + +char3_int4 [a] + = let n = (ord a `shiftL` 16) + in [(n `shiftR` 18 .&. 0x3f),(n `shiftR` 12 .&. 0x3f)] + +char3_int4 [] = [] + + +-- Retrieve base64 char, given an array index integer in the range [0..63] +enc1 :: Int -> Char +enc1 ch = encodeArray!ch + + +-- | Cut up a string into 72 char lines, each line terminated by CRLF. + +chop72 :: String -> String +chop72 str = let (bgn,end) = splitAt 70 str + in if null end then bgn else "\r\n" ++ chop72 end + + +-- Pads a base64 code to a multiple of 4 characters, using the special +-- '=' character. +quadruplets :: [Char] -> [Char] +quadruplets (a:b:c:d:t) = a:b:c:d:quadruplets t +quadruplets [a,b,c] = [a,b,c,'='] -- 16bit tail unit +quadruplets [a,b] = [a,b,'=','='] -- 8bit tail unit +quadruplets [_] = error "Network.HTTP.Base64.quadruplets: impossible number of characters." +quadruplets [] = [] -- 24bit tail unit + + +enc :: [Int] -> [Char] +enc = quadruplets . map enc1 + + +dcd :: String -> [Int] +dcd [] = [] +dcd (h:t) + | h <= 'Z' && h >= 'A' = ord h - ord 'A' : dcd t + | h >= '0' && h <= '9' = ord h - ord '0' + 52 : dcd t + | h >= 'a' && h <= 'z' = ord h - ord 'a' + 26 : dcd t + | h == '+' = 62 : dcd t + | h == '/' = 63 : dcd t + | h == '=' = [] -- terminate data stream + | otherwise = dcd t + + +-- Principal encoding and decoding functions. + +encode :: [Octet] -> String +encode = enc . char3_int4 . (map (chr .fromIntegral)) + +{- +prop_base64 os = + os == (f . g . h) os + where types = (os :: [Word8]) + f = map (fromIntegral. ord) + g = decode . encode + h = map (chr . fromIntegral) +-} + +decode :: String -> [Octet] +decode = (map (fromIntegral . ord)) . int4_char3 . dcd diff --git a/Network/HTTP/Cookie.hs b/Network/HTTP/Cookie.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Cookie.hs @@ -0,0 +1,141 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.Cookie +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- This module provides the data types and functions for working with HTTP cookies. +-- Right now, it contains mostly functionality needed by 'Network.Browser'. +-- +----------------------------------------------------------------------------- +module Network.HTTP.Cookie + ( Cookie(..) + , cookieMatch -- :: (String,String) -> Cookie -> Bool + + -- functions for translating cookies and headers. + , cookiesToHeader -- :: [Cookie] -> Header + , processCookieHeaders -- :: String -> [Header] -> ([String], [Cookie]) + ) where + +import Network.HTTP.Headers + +import Data.Char +import Data.List +import Data.Maybe + +import Text.ParserCombinators.Parsec + ( Parser, char, many, many1, satisfy, parse, option, try + , (<|>), sepBy1 + ) + +------------------------------------------------------------------ +----------------------- Cookie Stuff ----------------------------- +------------------------------------------------------------------ + +-- | @Cookie@ is the Haskell representation of HTTP cookie values. +-- See its relevant specs for authoritative details. +data Cookie + = MkCookie + { ckDomain :: String + , ckName :: String + , ckValue :: String + , ckPath :: Maybe String + , ckComment :: Maybe String + , ckVersion :: Maybe String + } + deriving(Show,Read) + +instance Eq Cookie where + a == b = ckDomain a == ckDomain b + && ckName a == ckName b + && ckPath a == ckPath b + +-- | @cookieToHeaders ck@ serialises @Cookie@s to an HTTP request header. +cookiesToHeader :: [Cookie] -> Header +cookiesToHeader cs = Header HdrCookie (mkCookieHeaderValue cs) + +-- | Turn a list of cookies into a key=value pair list, separated by +-- semicolons. +mkCookieHeaderValue :: [Cookie] -> String +mkCookieHeaderValue = intercalate "; " . map mkCookieHeaderValue1 + where + mkCookieHeaderValue1 c = ckName c ++ "=" ++ ckValue c + +-- | @cookieMatch (domain,path) ck@ performs the standard cookie +-- match wrt the given domain and path. +cookieMatch :: (String, String) -> Cookie -> Bool +cookieMatch (dom,path) ck = + ckDomain ck `isSuffixOf` dom && + case ckPath ck of + Nothing -> True + Just p -> p `isPrefixOf` path + + +-- | @processCookieHeaders dom hdrs@ +processCookieHeaders :: String -> [Header] -> ([String], [Cookie]) +processCookieHeaders dom hdrs = foldr (headerToCookies dom) ([],[]) hdrs + +-- | @headerToCookies dom hdr acc@ +headerToCookies :: String -> Header -> ([String], [Cookie]) -> ([String], [Cookie]) +headerToCookies dom (Header HdrSetCookie val) (accErr, accCookie) = + case parse cookies "" val of + Left{} -> (val:accErr, accCookie) + Right x -> (accErr, x ++ accCookie) + where + cookies :: Parser [Cookie] + cookies = sepBy1 cookie (char ',') + + cookie :: Parser Cookie + cookie = + do name <- word + _ <- spaces_l + _ <- char '=' + _ <- spaces_l + val1 <- cvalue + args <- cdetail + return $ mkCookie name val1 args + + cvalue :: Parser String + + spaces_l = many (satisfy isSpace) + + cvalue = quotedstring <|> many1 (satisfy $ not . (==';')) <|> return "" + + -- all keys in the result list MUST be in lower case + cdetail :: Parser [(String,String)] + cdetail = many $ + try (do _ <- spaces_l + _ <- char ';' + _ <- spaces_l + s1 <- word + _ <- spaces_l + s2 <- option "" (char '=' >> spaces_l >> cvalue) + return (map toLower s1,s2) + ) + + mkCookie :: String -> String -> [(String,String)] -> Cookie + mkCookie nm cval more = + MkCookie { ckName = nm + , ckValue = cval + , ckDomain = map toLower (fromMaybe dom (lookup "domain" more)) + , ckPath = lookup "path" more + , ckVersion = lookup "version" more + , ckComment = lookup "comment" more + } +headerToCookies _ _ acc = acc + + + + +word, quotedstring :: Parser String +quotedstring = + do _ <- char '"' -- " + str <- many (satisfy $ not . (=='"')) + _ <- char '"' + return str + +word = many1 (satisfy (\x -> isAlphaNum x || x=='_' || x=='.' || x=='-' || x==':')) diff --git a/Network/HTTP/HandleStream.hs b/Network/HTTP/HandleStream.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/HandleStream.hs @@ -0,0 +1,246 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.HandleStream +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- A 'HandleStream'-based version of "Network.HTTP" interface. +-- +-- For more detailed information about what the individual exports do, please consult +-- the documentation for "Network.HTTP". /Notice/ however that the functions here do +-- not perform any kind of normalization prior to transmission (or receipt); you are +-- responsible for doing any such yourself, or, if you prefer, just switch to using +-- "Network.HTTP" function instead. +-- +----------------------------------------------------------------------------- +module Network.HTTP.HandleStream + ( simpleHTTP -- :: Request ty -> IO (Result (Response ty)) + , simpleHTTP_ -- :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty)) + , sendHTTP -- :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty)) + , sendHTTP_notify -- :: HStream ty => HandleStream ty -> Request ty -> IO () -> IO (Result (Response ty)) + , receiveHTTP -- :: HStream ty => HandleStream ty -> IO (Result (Request ty)) + , respondHTTP -- :: HStream ty => HandleStream ty -> Response ty -> IO () + + , simpleHTTP_debug -- :: FilePath -> Request DebugString -> IO (Response DebugString) + ) where + +----------------------------------------------------------------- +------------------ Imports -------------------------------------- +----------------------------------------------------------------- + +import Network.BufferType +import Network.Stream ( fmapE, Result ) +import Network.StreamDebugger ( debugByteStream ) +import Network.TCP (HStream(..), HandleStream ) + +import Network.HTTP.Base +import Network.HTTP.Headers +import Network.HTTP.Utils ( trim, readsOne ) + +import Data.Char (toLower) +import Data.Maybe (fromMaybe) +import Control.Monad (when) + +----------------------------------------------------------------- +------------------ Misc ----------------------------------------- +----------------------------------------------------------------- + +-- | @simpleHTTP@ transmits a resource across a non-persistent connection. +simpleHTTP :: HStream ty => Request ty -> IO (Result (Response ty)) +simpleHTTP r = do + auth <- getAuth r + failHTTPS (rqURI r) + c <- openStream (host auth) (fromMaybe 80 (port auth)) + simpleHTTP_ c r + +-- | @simpleHTTP_debug debugFile req@ behaves like 'simpleHTTP', but logs +-- the HTTP operation via the debug file @debugFile@. +simpleHTTP_debug :: HStream ty => FilePath -> Request ty -> IO (Result (Response ty)) +simpleHTTP_debug httpLogFile r = do + auth <- getAuth r + failHTTPS (rqURI r) + c0 <- openStream (host auth) (fromMaybe 80 (port auth)) + c <- debugByteStream httpLogFile c0 + simpleHTTP_ c r + +-- | Like 'simpleHTTP', but acting on an already opened stream. +simpleHTTP_ :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty)) +simpleHTTP_ s r = sendHTTP s r + +-- | @sendHTTP hStream httpRequest@ transmits @httpRequest@ over +-- @hStream@, but does not alter the status of the connection, nor request it to be +-- closed upon receiving the response. +sendHTTP :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty)) +sendHTTP conn rq = sendHTTP_notify conn rq (return ()) + +-- | @sendHTTP_notify hStream httpRequest action@ behaves like 'sendHTTP', but +-- lets you supply an IO @action@ to execute once the request has been successfully +-- transmitted over the connection. Useful when you want to set up tracing of +-- request transmission and its performance. +sendHTTP_notify :: HStream ty + => HandleStream ty + -> Request ty + -> IO () + -> IO (Result (Response ty)) +sendHTTP_notify conn rq onSendComplete = do + when providedClose $ (closeOnEnd conn True) + catchIO (sendMain conn rq onSendComplete) + (\e -> do { close conn; ioError e }) + where + providedClose = findConnClose (rqHeaders rq) + +-- From RFC 2616, section 8.2.3: +-- 'Because of the presence of older implementations, the protocol allows +-- ambiguous situations in which a client may send "Expect: 100- +-- continue" without receiving either a 417 (Expectation Failed) status +-- or a 100 (Continue) status. Therefore, when a client sends this +-- header field to an origin server (possibly via a proxy) from which it +-- has never seen a 100 (Continue) status, the client SHOULD NOT wait +-- for an indefinite period before sending the request body.' +-- +-- Since we would wait forever, I have disabled use of 100-continue for now. +sendMain :: HStream ty + => HandleStream ty + -> Request ty + -> (IO ()) + -> IO (Result (Response ty)) +sendMain conn rqst onSendComplete = do + --let str = if null (rqBody rqst) + -- then show rqst + -- else show (insertHeader HdrExpect "100-continue" rqst) + writeBlock conn (buf_fromStr bufferOps $ show rqst) + -- write body immediately, don't wait for 100 CONTINUE + writeBlock conn (rqBody rqst) + onSendComplete + rsp <- getResponseHead conn + switchResponse conn True False rsp rqst + + -- Hmmm, this could go bad if we keep getting "100 Continue" + -- responses... Except this should never happen according + -- to the RFC. + +switchResponse :: HStream ty + => HandleStream ty + -> Bool {- allow retry? -} + -> Bool {- is body sent? -} + -> Result ResponseData + -> Request ty + -> IO (Result (Response ty)) +switchResponse _ _ _ (Left e) _ = return (Left e) + -- retry on connreset? + -- if we attempt to use the same socket then there is an excellent + -- chance that the socket is not in a completely closed state. + +switchResponse conn allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst = + case matchResponse (rqMethod rqst) cd of + Continue + | not bdy_sent -> do {- Time to send the body -} + writeBlock conn (rqBody rqst) >>= either (return . Left) + (\ _ -> do + rsp <- getResponseHead conn + switchResponse conn allow_retry True rsp rqst) + | otherwise -> do {- keep waiting -} + rsp <- getResponseHead conn + switchResponse conn allow_retry bdy_sent rsp rqst + + Retry -> do {- Request with "Expect" header failed. + Trouble is the request contains Expects + other than "100-Continue" -} + writeBlock conn ((buf_append bufferOps) + (buf_fromStr bufferOps (show rqst)) + (rqBody rqst)) + rsp <- getResponseHead conn + switchResponse conn False bdy_sent rsp rqst + + Done -> do + when (findConnClose hdrs) + (closeOnEnd conn True) + return (Right $ Response cd rn hdrs (buf_empty bufferOps)) + + DieHorribly str -> do + close conn + return (responseParseError "Invalid response:" str) + ExpectEntity -> do + r <- fmapE (\ (ftrs,bdy) -> Right (Response cd rn (hdrs++ftrs) bdy)) $ + maybe (maybe (hopefulTransfer bo (readLine conn) []) + (\ x -> + readsOne (linearTransfer (readBlock conn)) + (return$responseParseError "unrecognized content-length value" x) + x) + cl) + (ifChunked (chunkedTransfer bo (readLine conn) (readBlock conn)) + (uglyDeathTransfer "sendHTTP")) + tc + case r of + Left{} -> do + close conn + return r + Right (Response _ _ hs _) -> do + when (findConnClose hs) + (closeOnEnd conn True) + return r + + where + tc = lookupHeader HdrTransferEncoding hdrs + cl = lookupHeader HdrContentLength hdrs + bo = bufferOps + +-- reads and parses headers +getResponseHead :: HStream ty => HandleStream ty -> IO (Result ResponseData) +getResponseHead conn = + fmapE (\es -> parseResponseHead (map (buf_toStr bufferOps) es)) + (readTillEmpty1 bufferOps (readLine conn)) + +-- | @receiveHTTP hStream@ reads a 'Request' from the 'HandleStream' @hStream@ +receiveHTTP :: HStream bufTy => HandleStream bufTy -> IO (Result (Request bufTy)) +receiveHTTP conn = getRequestHead >>= either (return . Left) processRequest + where + -- reads and parses headers + getRequestHead :: IO (Result RequestData) + getRequestHead = do + fmapE (\es -> parseRequestHead (map (buf_toStr bufferOps) es)) + (readTillEmpty1 bufferOps (readLine conn)) + + processRequest (rm,uri,hdrs) = + fmapE (\ (ftrs,bdy) -> Right (Request uri rm (hdrs++ftrs) bdy)) $ + maybe + (maybe (return (Right ([], buf_empty bo))) -- hopefulTransfer "" + (\ x -> readsOne (linearTransfer (readBlock conn)) + (return$responseParseError "unrecognized Content-Length value" x) + x) + + cl) + (ifChunked (chunkedTransfer bo (readLine conn) (readBlock conn)) + (uglyDeathTransfer "receiveHTTP")) + tc + where + -- FIXME : Also handle 100-continue. + tc = lookupHeader HdrTransferEncoding hdrs + cl = lookupHeader HdrContentLength hdrs + bo = bufferOps + +-- | @respondHTTP hStream httpResponse@ transmits an HTTP 'Response' over +-- the 'HandleStream' @hStream@. It could be used to implement simple web +-- server interactions, performing the dual role to 'sendHTTP'. +respondHTTP :: HStream ty => HandleStream ty -> Response ty -> IO () +respondHTTP conn rsp = do + writeBlock conn (buf_fromStr bufferOps $ show rsp) + -- write body immediately, don't wait for 100 CONTINUE + writeBlock conn (rspBody rsp) + return () + +------------------------------------------------------------------------------ + +headerName :: String -> String +headerName x = map toLower (trim x) + +ifChunked :: a -> a -> String -> a +ifChunked a b s = + case headerName s of + "chunked" -> a + _ -> b + diff --git a/Network/HTTP/Headers.hs b/Network/HTTP/Headers.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Headers.hs @@ -0,0 +1,306 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.Headers +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- This module provides the data types for representing HTTP headers, and +-- operations for looking up header values and working with sequences of +-- header values in 'Request's and 'Response's. To avoid having to provide +-- separate set of operations for doing so, we introduce a type class 'HasHeaders' +-- to facilitate writing such processing using overloading instead. +-- +----------------------------------------------------------------------------- +module Network.HTTP.Headers + ( HasHeaders(..) -- type class + + , Header(..) + , mkHeader -- :: HeaderName -> String -> Header + , hdrName -- :: Header -> HeaderName + , hdrValue -- :: Header -> String + + , HeaderName(..) + + , insertHeader -- :: HasHeaders a => HeaderName -> String -> a -> a + , insertHeaderIfMissing -- :: HasHeaders a => HeaderName -> String -> a -> a + , insertHeaders -- :: HasHeaders a => [Header] -> a -> a + , retrieveHeaders -- :: HasHeaders a => HeaderName -> a -> [Header] + , replaceHeader -- :: HasHeaders a => HeaderName -> String -> a -> a + , findHeader -- :: HasHeaders a => HeaderName -> a -> Maybe String + , lookupHeader -- :: HeaderName -> [Header] -> Maybe String + + , parseHeader -- :: parseHeader :: String -> Result Header + , parseHeaders -- :: [String] -> Result [Header] + + , headerMap -- :: [(String, HeaderName)] + + , HeaderSetter + ) where + +import Data.Char (toLower) +import Network.Stream (Result, failParse) +import Network.HTTP.Utils ( trim, split, crlf ) + +-- | The @Header@ data type pairs header names & values. +data Header = Header HeaderName String + +hdrName :: Header -> HeaderName +hdrName (Header h _) = h + +hdrValue :: Header -> String +hdrValue (Header _ v) = v + +-- | Header constructor as a function, hiding above rep. +mkHeader :: HeaderName -> String -> Header +mkHeader = Header + +instance Show Header where + show (Header key value) = shows key (':':' ':value ++ crlf) + +-- | HTTP @HeaderName@ type, a Haskell data constructor for each +-- specification-defined header, prefixed with @Hdr@ and CamelCased, +-- (i.e., eliding the @-@ in the process.) Should you require using +-- a custom header, there's the @HdrCustom@ constructor which takes +-- a @String@ argument. +-- +-- Encoding HTTP header names differently, as Strings perhaps, is an +-- equally fine choice..no decidedly clear winner, but let's stick +-- with data constructors here. +-- +data HeaderName + -- Generic Headers -- + = HdrCacheControl + | HdrConnection + | HdrDate + | HdrPragma + | HdrTransferEncoding + | HdrUpgrade + | HdrVia + -- Request Headers -- + | HdrAccept + | HdrAcceptCharset + | HdrAcceptEncoding + | HdrAcceptLanguage + | HdrAuthorization + | HdrCookie + | HdrExpect + | HdrFrom + | HdrHost + | HdrIfModifiedSince + | HdrIfMatch + | HdrIfNoneMatch + | HdrIfRange + | HdrIfUnmodifiedSince + | HdrMaxForwards + | HdrProxyAuthorization + | HdrRange + | HdrReferer + | HdrUserAgent + -- Response Headers + | HdrAge + | HdrLocation + | HdrProxyAuthenticate + | HdrPublic + | HdrRetryAfter + | HdrServer + | HdrSetCookie + | HdrTE + | HdrTrailer + | HdrVary + | HdrWarning + | HdrWWWAuthenticate + -- Entity Headers + | HdrAllow + | HdrContentBase + | HdrContentEncoding + | HdrContentLanguage + | HdrContentLength + | HdrContentLocation + | HdrContentMD5 + | HdrContentRange + | HdrContentType + | HdrETag + | HdrExpires + | HdrLastModified + -- | MIME entity headers (for sub-parts) + | HdrContentTransferEncoding + -- | Allows for unrecognised or experimental headers. + | HdrCustom String -- not in header map below. + deriving(Eq) + +-- | @headerMap@ is a straight assoc list for translating between header names +-- and values. +headerMap :: [ (String,HeaderName) ] +headerMap = + [ p "Cache-Control" HdrCacheControl + , p "Connection" HdrConnection + , p "Date" HdrDate + , p "Pragma" HdrPragma + , p "Transfer-Encoding" HdrTransferEncoding + , p "Upgrade" HdrUpgrade + , p "Via" HdrVia + , p "Accept" HdrAccept + , p "Accept-Charset" HdrAcceptCharset + , p "Accept-Encoding" HdrAcceptEncoding + , p "Accept-Language" HdrAcceptLanguage + , p "Authorization" HdrAuthorization + , p "Cookie" HdrCookie + , p "Expect" HdrExpect + , p "From" HdrFrom + , p "Host" HdrHost + , p "If-Modified-Since" HdrIfModifiedSince + , p "If-Match" HdrIfMatch + , p "If-None-Match" HdrIfNoneMatch + , p "If-Range" HdrIfRange + , p "If-Unmodified-Since" HdrIfUnmodifiedSince + , p "Max-Forwards" HdrMaxForwards + , p "Proxy-Authorization" HdrProxyAuthorization + , p "Range" HdrRange + , p "Referer" HdrReferer + , p "User-Agent" HdrUserAgent + , p "Age" HdrAge + , p "Location" HdrLocation + , p "Proxy-Authenticate" HdrProxyAuthenticate + , p "Public" HdrPublic + , p "Retry-After" HdrRetryAfter + , p "Server" HdrServer + , p "Set-Cookie" HdrSetCookie + , p "TE" HdrTE + , p "Trailer" HdrTrailer + , p "Vary" HdrVary + , p "Warning" HdrWarning + , p "WWW-Authenticate" HdrWWWAuthenticate + , p "Allow" HdrAllow + , p "Content-Base" HdrContentBase + , p "Content-Encoding" HdrContentEncoding + , p "Content-Language" HdrContentLanguage + , p "Content-Length" HdrContentLength + , p "Content-Location" HdrContentLocation + , p "Content-MD5" HdrContentMD5 + , p "Content-Range" HdrContentRange + , p "Content-Type" HdrContentType + , p "ETag" HdrETag + , p "Expires" HdrExpires + , p "Last-Modified" HdrLastModified + , p "Content-Transfer-Encoding" HdrContentTransferEncoding + ] + where + p a b = (a,b) + +instance Show HeaderName where + show (HdrCustom s) = s + show x = case filter ((==x).snd) headerMap of + [] -> error "headerMap incomplete" + (h:_) -> fst h + +-- | @HasHeaders@ is a type class for types containing HTTP headers, allowing +-- you to write overloaded header manipulation functions +-- for both 'Request' and 'Response' data types, for instance. +class HasHeaders x where + getHeaders :: x -> [Header] + setHeaders :: x -> [Header] -> x + +-- Header manipulation functions + +type HeaderSetter a = HeaderName -> String -> a -> a + +-- | @insertHeader hdr val x@ inserts a header with the given header name +-- and value. Does not check for existing headers with same name, allowing +-- duplicates to be introduce (use 'replaceHeader' if you want to avoid this.) +insertHeader :: HasHeaders a => HeaderSetter a +insertHeader name value x = setHeaders x newHeaders + where + newHeaders = (Header name value) : getHeaders x + +-- | @insertHeaderIfMissing hdr val x@ adds the new header only if no previous +-- header with name @hdr@ exists in @x@. +insertHeaderIfMissing :: HasHeaders a => HeaderSetter a +insertHeaderIfMissing name value x = setHeaders x (newHeaders $ getHeaders x) + where + newHeaders list@(h@(Header n _): rest) + | n == name = list + | otherwise = h : newHeaders rest + newHeaders [] = [Header name value] + +-- | @replaceHeader hdr val o@ replaces the header @hdr@ with the +-- value @val@, dropping any existing +replaceHeader :: HasHeaders a => HeaderSetter a +replaceHeader name value h = setHeaders h newHeaders + where + newHeaders = Header name value : [ x | x@(Header n _) <- getHeaders h, name /= n ] + +-- | @insertHeaders hdrs x@ appends multiple headers to @x@'s existing +-- set. +insertHeaders :: HasHeaders a => [Header] -> a -> a +insertHeaders hdrs x = setHeaders x (getHeaders x ++ hdrs) + +-- | @retrieveHeaders hdrNm x@ gets a list of headers with 'HeaderName' @hdrNm@. +retrieveHeaders :: HasHeaders a => HeaderName -> a -> [Header] +retrieveHeaders name x = filter matchname (getHeaders x) + where + matchname (Header n _) = n == name + +-- | @findHeader hdrNm x@ looks up @hdrNm@ in @x@, returning the first +-- header that matches, if any. +findHeader :: HasHeaders a => HeaderName -> a -> Maybe String +findHeader n x = lookupHeader n (getHeaders x) + +-- | @lookupHeader hdr hdrs@ locates the first header matching @hdr@ in the +-- list @hdrs@. +lookupHeader :: HeaderName -> [Header] -> Maybe String +lookupHeader _ [] = Nothing +lookupHeader v (Header n s:t) + | v == n = Just s + | otherwise = lookupHeader v t + +-- | @parseHeader headerNameAndValueString@ tries to unscramble a +-- @header: value@ pairing and returning it as a 'Header'. +parseHeader :: String -> Result Header +parseHeader str = + case split ':' str of + Nothing -> failParse ("Unable to parse header: " ++ str) + Just (k,v) -> return $ Header (fn k) (trim $ drop 1 v) + where + fn k = case map snd $ filter (match k . fst) headerMap of + [] -> (HdrCustom k) + (h:_) -> h + + match :: String -> String -> Bool + match s1 s2 = map toLower s1 == map toLower s2 + +-- | @parseHeaders hdrs@ takes a sequence of strings holding header +-- information and parses them into a set of headers (preserving their +-- order in the input argument.) Handles header values split up over +-- multiple lines. +parseHeaders :: [String] -> Result [Header] +parseHeaders = catRslts [] . + map (parseHeader . clean) . + joinExtended "" + where + -- Joins consecutive lines where the second line + -- begins with ' ' or '\t'. + joinExtended old [] = [old] + joinExtended old (h : t) + | isLineExtension h = joinExtended (old ++ ' ' : tail h) t + | otherwise = old : joinExtended h t + + isLineExtension (x:_) = x == ' ' || x == '\t' + isLineExtension _ = False + + clean [] = [] + clean (h:t) | h `elem` "\t\r\n" = ' ' : clean t + | otherwise = h : clean t + + -- tolerant of errors? should parse + -- errors here be reported or ignored? + -- currently ignored. + catRslts :: [a] -> [Result a] -> Result [a] + catRslts list (h:t) = + case h of + Left _ -> catRslts list t + Right v -> catRslts (v:list) t + catRslts list [] = Right $ reverse list diff --git a/Network/HTTP/MD5Aux.hs b/Network/HTTP/MD5Aux.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/MD5Aux.hs @@ -0,0 +1,342 @@ +module Network.HTTP.MD5Aux + (md5, md5s, md5i, + MD5(..), ABCD(..), + Zord64, Str(..), BoolList(..), WordList(..)) where + +import Data.Char (ord, chr) +import Data.Bits (rotateL, shiftL, shiftR, (.&.), (.|.), xor, complement) +import Data.Word (Word32, Word64) + +rotL :: Word32 -> Int -> Word32 +rotL x = rotateL x + +type Zord64 = Word64 + +-- ===================== TYPES AND CLASS DEFINTIONS ======================== + + +type XYZ = (Word32, Word32, Word32) +type Rotation = Int +newtype ABCD = ABCD (Word32, Word32, Word32, Word32) deriving (Eq, Show) +newtype Str = Str String +newtype BoolList = BoolList [Bool] +newtype WordList = WordList ([Word32], Word64) + +-- Anything we want to work out the MD5 of must be an instance of class MD5 + +class MD5 a where + get_next :: a -> ([Word32], Int, a) -- get the next blocks worth + -- \ \ \------ the rest of the input + -- \ \--------- the number of bits returned + -- \--------------- the bits returned in 32bit words + len_pad :: Word64 -> a -> a -- append the padding and length + finished :: a -> Bool -- Have we run out of input yet? + + +-- Mainly exists because it's fairly easy to do MD5s on input where the +-- length is not a multiple of 8 + +instance MD5 BoolList where + get_next (BoolList s) = (bools_to_word32s ys, length ys, BoolList zs) + where (ys, zs) = splitAt 512 s + len_pad l (BoolList bs) + = BoolList (bs ++ [True] + ++ replicate (fromIntegral $ (447 - l) .&. 511) False + ++ [l .&. (shiftL 1 x) > 0 | x <- (mangle [0..63])] + ) + where mangle [] = [] + mangle xs = reverse ys ++ mangle zs + where (ys, zs) = splitAt 8 xs + finished (BoolList s) = s == [] + + +-- The string instance is fairly straightforward + +instance MD5 Str where + get_next (Str s) = (string_to_word32s ys, 8 * length ys, Str zs) + where (ys, zs) = splitAt 64 s + len_pad c64 (Str s) = Str (s ++ padding ++ l) + where padding = '\128':replicate (fromIntegral zeros) '\000' + zeros = shiftR ((440 - c64) .&. 511) 3 + l = length_to_chars 8 c64 + finished (Str s) = s == "" + + +-- YA instance that is believed will be useful + +instance MD5 WordList where + get_next (WordList (ws, l)) = (xs, fromIntegral taken, WordList (ys, l - taken)) + where (xs, ys) = splitAt 16 ws + taken = if l > 511 then 512 else l .&. 511 + len_pad c64 (WordList (ws, l)) = WordList (beginning ++ nextish ++ blanks ++ size, newlen) + where beginning = if length ws > 0 then start ++ lastone' else [] + start = init ws + lastone = last ws + offset = c64 .&. 31 + lastone' = [if offset > 0 then lastone + theone else lastone] + theone = shiftL (shiftR 128 (fromIntegral $ offset .&. 7)) + (fromIntegral $ offset .&. (31 - 7)) + nextish = if offset == 0 then [128] else [] + c64' = c64 + (32 - offset) + num_blanks = (fromIntegral $ shiftR ((448 - c64') .&. 511) 5) + blanks = replicate num_blanks 0 + lowsize = fromIntegral $ c64 .&. (shiftL 1 32 - 1) + topsize = fromIntegral $ shiftR c64 32 + size = [lowsize, topsize] + newlen = l .&. (complement 511) + + if c64 .&. 511 >= 448 then 1024 else 512 + finished (WordList (_, z)) = z == 0 + + +instance Num ABCD where + ABCD (a1, b1, c1, d1) + ABCD (a2, b2, c2, d2) = ABCD (a1 + a2, b1 + b2, c1 + c2, d1 + d2) + + (*) = error "(*){ABCD}: no instance method defined" + signum = error "signum{ABCD}: no instance method defined" + fromInteger = error "fromInteger{ABCD}: no instance method defined" + abs = error "abs{ABCD}: no instance method defined" +-- ===================== EXPORTED FUNCTIONS ======================== + + +-- The simplest function, gives you the MD5 of a string as 4-tuple of +-- 32bit words. + +md5 :: (MD5 a) => a -> ABCD +md5 m = md5_main False 0 magic_numbers m + + +-- Returns a hex number ala the md5sum program + +md5s :: (MD5 a) => a -> String +md5s = abcd_to_string . md5 + + +-- Returns an integer equivalent to the above hex number + +md5i :: (MD5 a) => a -> Integer +md5i = abcd_to_integer . md5 + + +-- ===================== THE CORE ALGORITHM ======================== + + +-- Decides what to do. The first argument indicates if padding has been +-- added. The second is the length mod 2^64 so far. Then we have the +-- starting state, the rest of the string and the final state. + +md5_main :: (MD5 a) => + Bool -- Have we added padding yet? + -> Word64 -- The length so far mod 2^64 + -> ABCD -- The initial state + -> a -- The non-processed portion of the message + -> ABCD -- The resulting state +md5_main padded ilen abcd m + = if finished m && padded + then abcd + else md5_main padded' (ilen + 512) (abcd + abcd') m'' + where (m16, l, m') = get_next m + len' = ilen + fromIntegral l + ((m16', _, m''), padded') = if not padded && l < 512 + then (get_next $ len_pad len' m, True) + else ((m16, l, m'), padded) + abcd' = md5_do_block abcd m16' + + +-- md5_do_block processes a 512 bit block by calling md5_round 4 times to +-- apply each round with the correct constants and permutations of the +-- block + +md5_do_block :: ABCD -- Initial state + -> [Word32] -- The block to be processed - 16 32bit words + -> ABCD -- Resulting state +md5_do_block abcd0 w = abcd4 + where (r1, r2, r3, r4) = rounds + {- + map (\x -> w !! x) [1,6,11,0,5,10,15,4,9,14,3,8,13,2,7,12] + -- [(5 * x + 1) `mod` 16 | x <- [0..15]] + map (\x -> w !! x) [5,8,11,14,1,4,7,10,13,0,3,6,9,12,15,2] + -- [(3 * x + 5) `mod` 16 | x <- [0..15]] + map (\x -> w !! x) [0,7,14,5,12,3,10,1,8,15,6,13,4,11,2,9] + -- [(7 * x) `mod` 16 | x <- [0..15]] + -} + perm5 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15] + = [c1,c6,c11,c0,c5,c10,c15,c4,c9,c14,c3,c8,c13,c2,c7,c12] + perm5 _ = error "broke at perm5" + perm3 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15] + = [c5,c8,c11,c14,c1,c4,c7,c10,c13,c0,c3,c6,c9,c12,c15,c2] + perm3 _ = error "broke at perm3" + perm7 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15] + = [c0,c7,c14,c5,c12,c3,c10,c1,c8,c15,c6,c13,c4,c11,c2,c9] + perm7 _ = error "broke at perm7" + abcd1 = md5_round md5_f abcd0 w r1 + abcd2 = md5_round md5_g abcd1 (perm5 w) r2 + abcd3 = md5_round md5_h abcd2 (perm3 w) r3 + abcd4 = md5_round md5_i abcd3 (perm7 w) r4 + + +-- md5_round does one of the rounds. It takes an auxiliary function and foldls +-- (md5_inner_function f) to repeatedly apply it to the initial state with the +-- correct constants + +md5_round :: (XYZ -> Word32) -- Auxiliary function (F, G, H or I + -- for those of you with a copy of + -- the prayer book^W^WRFC) + -> ABCD -- Initial state + -> [Word32] -- The 16 32bit words of input + -> [(Rotation, Word32)] -- The list of 16 rotations and + -- additive constants + -> ABCD -- Resulting state +md5_round f abcd s ns = foldl (md5_inner_function f) abcd ns' + where ns' = zipWith (\x (y, z) -> (y, x + z)) s ns + + +-- Apply one of the functions md5_[fghi] and put the new ABCD together + +md5_inner_function :: (XYZ -> Word32) -- Auxiliary function + -> ABCD -- Initial state + -> (Rotation, Word32) -- The rotation and additive + -- constant (X[i] + T[j]) + -> ABCD -- Resulting state +md5_inner_function f (ABCD (a, b, c, d)) (s, ki) = ABCD (d, a', b, c) + where mid_a = a + f(b,c,d) + ki + rot_a = rotL mid_a s + a' = b + rot_a + + +-- The 4 auxiliary functions + +md5_f :: XYZ -> Word32 +md5_f (x, y, z) = z `xor` (x .&. (y `xor` z)) +{- optimised version of: (x .&. y) .|. ((complement x) .&. z) -} + +md5_g :: XYZ -> Word32 +md5_g (x, y, z) = md5_f (z, x, y) +{- was: (x .&. z) .|. (y .&. (complement z)) -} + +md5_h :: XYZ -> Word32 +md5_h (x, y, z) = x `xor` y `xor` z + +md5_i :: XYZ -> Word32 +md5_i (x, y, z) = y `xor` (x .|. (complement z)) + + +-- The magic numbers from the RFC. + +magic_numbers :: ABCD +magic_numbers = ABCD (0x67452301, 0xefcdab89, 0x98badcfe, 0x10325476) + + +-- The 4 lists of (rotation, additive constant) tuples, one for each round + +rounds :: ([(Rotation, Word32)], + [(Rotation, Word32)], + [(Rotation, Word32)], + [(Rotation, Word32)]) +rounds = (r1, r2, r3, r4) + where r1 = [(s11, 0xd76aa478), (s12, 0xe8c7b756), (s13, 0x242070db), + (s14, 0xc1bdceee), (s11, 0xf57c0faf), (s12, 0x4787c62a), + (s13, 0xa8304613), (s14, 0xfd469501), (s11, 0x698098d8), + (s12, 0x8b44f7af), (s13, 0xffff5bb1), (s14, 0x895cd7be), + (s11, 0x6b901122), (s12, 0xfd987193), (s13, 0xa679438e), + (s14, 0x49b40821)] + r2 = [(s21, 0xf61e2562), (s22, 0xc040b340), (s23, 0x265e5a51), + (s24, 0xe9b6c7aa), (s21, 0xd62f105d), (s22, 0x2441453), + (s23, 0xd8a1e681), (s24, 0xe7d3fbc8), (s21, 0x21e1cde6), + (s22, 0xc33707d6), (s23, 0xf4d50d87), (s24, 0x455a14ed), + (s21, 0xa9e3e905), (s22, 0xfcefa3f8), (s23, 0x676f02d9), + (s24, 0x8d2a4c8a)] + r3 = [(s31, 0xfffa3942), (s32, 0x8771f681), (s33, 0x6d9d6122), + (s34, 0xfde5380c), (s31, 0xa4beea44), (s32, 0x4bdecfa9), + (s33, 0xf6bb4b60), (s34, 0xbebfbc70), (s31, 0x289b7ec6), + (s32, 0xeaa127fa), (s33, 0xd4ef3085), (s34, 0x4881d05), + (s31, 0xd9d4d039), (s32, 0xe6db99e5), (s33, 0x1fa27cf8), + (s34, 0xc4ac5665)] + r4 = [(s41, 0xf4292244), (s42, 0x432aff97), (s43, 0xab9423a7), + (s44, 0xfc93a039), (s41, 0x655b59c3), (s42, 0x8f0ccc92), + (s43, 0xffeff47d), (s44, 0x85845dd1), (s41, 0x6fa87e4f), + (s42, 0xfe2ce6e0), (s43, 0xa3014314), (s44, 0x4e0811a1), + (s41, 0xf7537e82), (s42, 0xbd3af235), (s43, 0x2ad7d2bb), + (s44, 0xeb86d391)] + s11 = 7 + s12 = 12 + s13 = 17 + s14 = 22 + s21 = 5 + s22 = 9 + s23 = 14 + s24 = 20 + s31 = 4 + s32 = 11 + s33 = 16 + s34 = 23 + s41 = 6 + s42 = 10 + s43 = 15 + s44 = 21 + + +-- ===================== CONVERSION FUNCTIONS ======================== + + +-- Turn the 4 32 bit words into a string representing the hex number they +-- represent. + +abcd_to_string :: ABCD -> String +abcd_to_string (ABCD (a,b,c,d)) = concat $ map display_32bits_as_hex [a,b,c,d] + + +-- Split the 32 bit word up, swap the chunks over and convert the numbers +-- to their hex equivalents. + +display_32bits_as_hex :: Word32 -> String +display_32bits_as_hex w = swap_pairs cs + where cs = map (\x -> getc $ (shiftR w (4*x)) .&. 15) [0..7] + getc n = (['0'..'9'] ++ ['a'..'f']) !! (fromIntegral n) + swap_pairs (x1:x2:xs) = x2:x1:swap_pairs xs + swap_pairs _ = [] + +-- Convert to an integer, performing endianness magic as we go + +abcd_to_integer :: ABCD -> Integer +abcd_to_integer (ABCD (a,b,c,d)) = rev_num a * 2^(96 :: Int) + + rev_num b * 2^(64 :: Int) + + rev_num c * 2^(32 :: Int) + + rev_num d + +rev_num :: Word32 -> Integer +rev_num i = toInteger j `mod` (2^(32 :: Int)) + -- NHC's fault ~~~~~~~~~~~~~~~~~~~~~ + where j = foldl (\so_far next -> shiftL so_far 8 + (shiftR i next .&. 255)) + 0 [0,8,16,24] + +-- Used to convert a 64 byte string to 16 32bit words + +string_to_word32s :: String -> [Word32] +string_to_word32s "" = [] +string_to_word32s ss = this:string_to_word32s ss' + where (s, ss') = splitAt 4 ss + this = foldr (\c w -> shiftL w 8 + (fromIntegral.ord) c) 0 s + + +-- Used to convert a list of 512 bools to 16 32bit words + +bools_to_word32s :: [Bool] -> [Word32] +bools_to_word32s [] = [] +bools_to_word32s bs = this:bools_to_word32s rest + where (bs1, bs1') = splitAt 8 bs + (bs2, bs2') = splitAt 8 bs1' + (bs3, bs3') = splitAt 8 bs2' + (bs4, rest) = splitAt 8 bs3' + this = boolss_to_word32 [bs1, bs2, bs3, bs4] + bools_to_word8 = foldl (\w b -> shiftL w 1 + if b then 1 else 0) 0 + boolss_to_word32 = foldr (\w8 w -> shiftL w 8 + bools_to_word8 w8) 0 + + +-- Convert the size into a list of characters used by the len_pad function +-- for strings + +length_to_chars :: Int -> Word64 -> String +length_to_chars 0 _ = [] +length_to_chars p n = this:length_to_chars (p-1) (shiftR n 8) + where this = chr $ fromIntegral $ n .&. 255 + diff --git a/Network/HTTP/Proxy.hs b/Network/HTTP/Proxy.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Proxy.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.Proxy +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- Handling proxy server settings and their resolution. +-- +----------------------------------------------------------------------------- +module Network.HTTP.Proxy + ( Proxy(..) + , noProxy -- :: Proxy + , fetchProxy -- :: Bool -> IO Proxy + , parseProxy -- :: String -> Maybe Proxy + ) where + +import Control.Monad ( when, mplus, join, liftM2) + +import Network.HTTP.Utils ( dropWhileTail, chopAtDelim ) +import Network.HTTP.Auth +import Network.URI + ( URI(..), URIAuth(..), parseAbsoluteURI ) +import System.IO ( hPutStrLn, stderr ) +import System.Environment + +{- +#if !defined(WIN32) && defined(mingw32_HOST_OS) +#define WIN32 1 +#endif +-} + +#if defined(WIN32) +import System.Win32.Types ( DWORD, HKEY ) +import System.Win32.Registry( hKEY_CURRENT_USER, regOpenKey, regCloseKey, regQueryValue, regQueryValueEx ) +import Control.Exception ( bracket ) +import Foreign ( toBool, Storable(peek, sizeOf), castPtr, alloca ) +#endif + +-- | HTTP proxies (or not) are represented via 'Proxy', specifying if a +-- proxy should be used for the request (see 'Network.Browser.setProxy') +data Proxy + = NoProxy -- ^ Don't use a proxy. + | Proxy String + (Maybe Authority) -- ^ Use the proxy given. Should be of the + -- form "http:\/\/host:port", "host", "host:port", or "http:\/\/host". + -- Additionally, an optional 'Authority' for authentication with the proxy. + + +noProxy :: Proxy +noProxy = NoProxy + +-- | @envProxyString@ locates proxy server settings by looking +-- up env variable @HTTP_PROXY@ (or its lower-case equivalent.) +-- If no mapping found, returns @Nothing@. +envProxyString :: IO (Maybe String) +envProxyString = do + env <- getEnvironment + return (lookup "http_proxy" env `mplus` lookup "HTTP_PROXY" env) + +-- | @proxyString@ tries to locate the user's proxy server setting. +-- Consults environment variable, and in case of Windows, by querying +-- the Registry (cf. @registryProxyString@.) +proxyString :: IO (Maybe String) +proxyString = liftM2 mplus envProxyString registryProxyString + +registryProxyString :: IO (Maybe String) +#if !defined(WIN32) +registryProxyString = return Nothing +#else +registryProxyLoc :: (HKEY,String) +registryProxyLoc = (hive, path) + 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" + +-- read proxy settings from the windows registry; this is just a best +-- effort and may not work on all setups. +registryProxyString = Prelude.catch + (bracket (uncurry regOpenKey registryProxyLoc) regCloseKey $ \hkey -> do + enable <- fmap toBool $ regQueryValueDWORD hkey "ProxyEnable" + if enable + then fmap Just $ regQueryValue hkey (Just "ProxyServer") + else return Nothing) + (\_ -> return Nothing) +#endif + +-- | @fetchProxy flg@ gets the local proxy settings and parse the string +-- into a @Proxy@ value. If you want to be informed of ill-formed proxy +-- configuration strings, supply @True@ for @flg@. +-- Proxy settings are sourced from the @HTTP_PROXY@ environment variable, +-- and in the case of Windows platforms, by consulting IE/WinInet's proxy +-- setting in the Registry. +fetchProxy :: Bool -> IO Proxy +fetchProxy warnIfIllformed = do + mstr <- proxyString + case mstr of + Nothing -> return NoProxy + Just str -> case parseProxy str of + Just p -> return p + Nothing -> do + when warnIfIllformed $ System.IO.hPutStrLn System.IO.stderr $ unlines + [ "invalid http proxy uri: " ++ show str + , "proxy uri must be http with a hostname" + , "ignoring http proxy, trying a direct connection" + ] + return NoProxy + +-- | @parseProxy str@ translates a proxy server string into a @Proxy@ value; +-- returns @Nothing@ if not well-formed. +parseProxy :: String -> Maybe Proxy +parseProxy 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 + + -- Note: 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. + -- + +-- | tidy up user portion, don't want the trailing "\@". +fixUserInfo :: URI -> URI +fixUserInfo uri = uri{ uriAuthority = f `fmap` uriAuthority uri } + where + f a@URIAuth{uriUserInfo=s} = a{uriUserInfo=dropWhileTail (=='@') s} + +-- +uri2proxy :: URI -> Maybe Proxy +uri2proxy uri@URI{ uriScheme = "http:" + , uriAuthority = Just (URIAuth auth' hst prt) + } = + Just (Proxy (hst ++ prt) auth) + where + auth = + case auth' of + [] -> Nothing + as -> Just (AuthBasic "" usr pwd uri) + where + (usr,pwd) = chopAtDelim ':' as + +uri2proxy _ = Nothing + +-- utilities +#if defined(WIN32) +regQueryValueDWORD :: HKEY -> String -> IO DWORD +regQueryValueDWORD hkey name = alloca $ \ptr -> do + regQueryValueEx hkey name (castPtr ptr) (sizeOf (undefined :: DWORD)) + peek ptr + +#endif diff --git a/Network/HTTP/Stream.hs b/Network/HTTP/Stream.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Stream.hs @@ -0,0 +1,230 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.Stream +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- Transmitting HTTP requests and responses holding @String@ in their payload bodies. +-- This is one of the implementation modules for the "Network.HTTP" interface, representing +-- request and response content as @String@s and transmitting them in non-packed form +-- (cf. "Network.HTTP.HandleStream" and its use of @ByteString@s.) over 'Stream' handles. +-- It is mostly here for backwards compatibility, representing how requests and responses +-- were transmitted up until the 4.x releases of the HTTP package. +-- +-- For more detailed information about what the individual exports do, please consult +-- the documentation for "Network.HTTP". /Notice/ however that the functions here do +-- not perform any kind of normalization prior to transmission (or receipt); you are +-- responsible for doing any such yourself, or, if you prefer, just switch to using +-- "Network.HTTP" function instead. +-- +----------------------------------------------------------------------------- +module Network.HTTP.Stream + ( module Network.Stream + + , simpleHTTP -- :: Request_String -> IO (Result Response_String) + , simpleHTTP_ -- :: Stream s => s -> Request_String -> IO (Result Response_String) + , sendHTTP -- :: Stream s => s -> Request_String -> IO (Result Response_String) + , sendHTTP_notify -- :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String) + , receiveHTTP -- :: Stream s => s -> IO (Result Request_String) + , respondHTTP -- :: Stream s => s -> Response_String -> IO () + + ) where + +----------------------------------------------------------------- +------------------ Imports -------------------------------------- +----------------------------------------------------------------- + +import Network.Stream +import Network.StreamDebugger (debugStream) +import Network.TCP (openTCPPort) +import Network.BufferType ( stringBufferOp ) + +import Network.HTTP.Base +import Network.HTTP.Headers +import Network.HTTP.Utils ( trim ) + +import Data.Char (toLower) +import Data.Maybe (fromMaybe) +import Control.Monad (when) + + +-- Turn on to enable HTTP traffic logging +debug :: Bool +debug = False + +-- File that HTTP traffic logs go to +httpLogFile :: String +httpLogFile = "http-debug.log" + +----------------------------------------------------------------- +------------------ Misc ----------------------------------------- +----------------------------------------------------------------- + + +-- | Simple way to transmit a resource across a non-persistent connection. +simpleHTTP :: Request_String -> IO (Result Response_String) +simpleHTTP r = do + auth <- getAuth r + c <- openTCPPort (host auth) (fromMaybe 80 (port auth)) + simpleHTTP_ c r + +-- | Like 'simpleHTTP', but acting on an already opened stream. +simpleHTTP_ :: Stream s => s -> Request_String -> IO (Result Response_String) +simpleHTTP_ s r + | not debug = sendHTTP s r + | otherwise = do + s' <- debugStream httpLogFile s + sendHTTP s' r + +sendHTTP :: Stream s => s -> Request_String -> IO (Result Response_String) +sendHTTP conn rq = sendHTTP_notify conn rq (return ()) + +sendHTTP_notify :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String) +sendHTTP_notify conn rq onSendComplete = do + when providedClose $ (closeOnEnd conn True) + catchIO (sendMain conn rq onSendComplete) + (\e -> do { close conn; ioError e }) + where + providedClose = findConnClose (rqHeaders rq) + +-- From RFC 2616, section 8.2.3: +-- 'Because of the presence of older implementations, the protocol allows +-- ambiguous situations in which a client may send "Expect: 100- +-- continue" without receiving either a 417 (Expectation Failed) status +-- or a 100 (Continue) status. Therefore, when a client sends this +-- header field to an origin server (possibly via a proxy) from which it +-- has never seen a 100 (Continue) status, the client SHOULD NOT wait +-- for an indefinite period before sending the request body.' +-- +-- Since we would wait forever, I have disabled use of 100-continue for now. +sendMain :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String) +sendMain conn rqst onSendComplete = do + --let str = if null (rqBody rqst) + -- then show rqst + -- else show (insertHeader HdrExpect "100-continue" rqst) + writeBlock conn (show rqst) + -- write body immediately, don't wait for 100 CONTINUE + writeBlock conn (rqBody rqst) + onSendComplete + rsp <- getResponseHead conn + switchResponse conn True False rsp rqst + +-- reads and parses headers +getResponseHead :: Stream s => s -> IO (Result ResponseData) +getResponseHead conn = do + lor <- readTillEmpty1 stringBufferOp (readLine conn) + return $ lor >>= parseResponseHead + +-- Hmmm, this could go bad if we keep getting "100 Continue" +-- responses... Except this should never happen according +-- to the RFC. +switchResponse :: Stream s + => s + -> Bool {- allow retry? -} + -> Bool {- is body sent? -} + -> Result ResponseData + -> Request_String + -> IO (Result Response_String) +switchResponse _ _ _ (Left e) _ = return (Left e) + -- retry on connreset? + -- if we attempt to use the same socket then there is an excellent + -- chance that the socket is not in a completely closed state. +switchResponse conn allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst = + case matchResponse (rqMethod rqst) cd of + Continue + | not bdy_sent -> {- Time to send the body -} + do { val <- writeBlock conn (rqBody rqst) + ; case val of + Left e -> return (Left e) + Right _ -> + do { rsp <- getResponseHead conn + ; switchResponse conn allow_retry True rsp rqst + } + } + | otherwise -> {- keep waiting -} + do { rsp <- getResponseHead conn + ; switchResponse conn allow_retry bdy_sent rsp rqst + } + + Retry -> {- Request with "Expect" header failed. + Trouble is the request contains Expects + other than "100-Continue" -} + do { writeBlock conn (show rqst ++ rqBody rqst) + ; rsp <- getResponseHead conn + ; switchResponse conn False bdy_sent rsp rqst + } + + Done -> do + when (findConnClose hdrs) + (closeOnEnd conn True) + return (Right $ Response cd rn hdrs "") + + DieHorribly str -> do + close conn + return $ responseParseError "sendHTTP" ("Invalid response: " ++ str) + + ExpectEntity -> + let tc = lookupHeader HdrTransferEncoding hdrs + cl = lookupHeader HdrContentLength hdrs + in + do { rslt <- case tc of + Nothing -> + case cl of + Just x -> linearTransfer (readBlock conn) (read x :: Int) + Nothing -> hopefulTransfer stringBufferOp {-null (++) []-} (readLine conn) [] + Just x -> + case map toLower (trim x) of + "chunked" -> chunkedTransfer stringBufferOp + (readLine conn) (readBlock conn) + _ -> uglyDeathTransfer "sendHTTP" + ; case rslt of + Left e -> close conn >> return (Left e) + Right (ftrs,bdy) -> do + when (findConnClose (hdrs++ftrs)) + (closeOnEnd conn True) + return (Right (Response cd rn (hdrs++ftrs) bdy)) + } + +-- | Receive and parse a HTTP request from the given Stream. Should be used +-- for server side interactions. +receiveHTTP :: Stream s => s -> IO (Result Request_String) +receiveHTTP conn = getRequestHead >>= processRequest + where + -- reads and parses headers + getRequestHead :: IO (Result RequestData) + getRequestHead = + do { lor <- readTillEmpty1 stringBufferOp (readLine conn) + ; return $ lor >>= parseRequestHead + } + + processRequest (Left e) = return $ Left e + processRequest (Right (rm,uri,hdrs)) = + do -- FIXME : Also handle 100-continue. + let tc = lookupHeader HdrTransferEncoding hdrs + cl = lookupHeader HdrContentLength hdrs + rslt <- case tc of + Nothing -> + case cl of + Just x -> linearTransfer (readBlock conn) (read x :: Int) + Nothing -> return (Right ([], "")) -- hopefulTransfer "" + Just x -> + case map toLower (trim x) of + "chunked" -> chunkedTransfer stringBufferOp + (readLine conn) (readBlock conn) + _ -> uglyDeathTransfer "receiveHTTP" + + return $ do + (ftrs,bdy) <- rslt + return (Request uri rm (hdrs++ftrs) bdy) + +-- | Very simple function, send a HTTP response over the given stream. This +-- could be improved on to use different transfer types. +respondHTTP :: Stream s => s -> Response_String -> IO () +respondHTTP conn rsp = do writeBlock conn (show rsp) + -- write body immediately, don't wait for 100 CONTINUE + writeBlock conn (rspBody rsp) + return () diff --git a/Network/HTTP/Utils.hs b/Network/HTTP/Utils.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Utils.hs @@ -0,0 +1,111 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.Utils +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- Set of utility functions and definitions used by package modules. +-- +module Network.HTTP.Utils + ( trim -- :: String -> String + , trimL -- :: String -> String + , trimR -- :: String -> String + + , crlf -- :: String + , lf -- :: String + , sp -- :: String + + , split -- :: Eq a => a -> [a] -> Maybe ([a],[a]) + , splitBy -- :: Eq a => a -> [a] -> [[a]] + + , readsOne -- :: Read a => (a -> b) -> b -> String -> b + + , dropWhileTail -- :: (a -> Bool) -> [a] -> [a] + , chopAtDelim -- :: Eq a => a -> [a] -> ([a],[a]) + + ) where + +import Data.Char +import Data.List ( elemIndex ) +import Data.Maybe ( fromMaybe ) + +-- | @crlf@ is our beloved two-char line terminator. +crlf :: String +crlf = "\r\n" + +-- | @lf@ is a tolerated line terminator, per RFC 2616 section 19.3. +lf :: String +lf = "\n" + +-- | @sp@ lets you save typing one character. +sp :: String +sp = " " + +-- | @split delim ls@ splits a list into two parts, the @delim@ occurring +-- at the head of the second list. If @delim@ isn't in @ls@, @Nothing@ is +-- returned. +split :: Eq a => a -> [a] -> Maybe ([a],[a]) +split delim list = case delim `elemIndex` list of + Nothing -> Nothing + Just x -> Just $ splitAt x list + +-- | @trim str@ removes leading and trailing whitespace from @str@. +trim :: String -> String +trim xs = trimR (trimL xs) + +-- | @trimL str@ removes leading whitespace (as defined by 'Data.Char.isSpace') +-- from @str@. +trimL :: String -> String +trimL xs = dropWhile isSpace xs + +-- | @trimL str@ removes trailing whitespace (as defined by 'Data.Char.isSpace') +-- from @str@. +trimR :: String -> String +trimR str = fromMaybe "" $ foldr trimIt Nothing str + where + trimIt x (Just xs) = Just (x:xs) + trimIt x Nothing + | isSpace x = Nothing + | otherwise = Just [x] + +-- | @splitMany delim ls@ removes the delimiter @delim@ from @ls@. +splitBy :: Eq a => a -> [a] -> [[a]] +splitBy _ [] = [] +splitBy c xs = + case break (==c) xs of + (_,[]) -> [xs] + (as,_:bs) -> as : splitBy c bs + +-- | @readsOne f def str@ tries to 'read' @str@, taking +-- the first result and passing it to @f@. If the 'read' +-- doesn't succeed, return @def@. +readsOne :: Read a => (a -> b) -> b -> String -> b +readsOne f n str = + case reads str of + ((v,_):_) -> f v + _ -> n + + +-- | @dropWhileTail p ls@ chops off trailing elements from @ls@ +-- until @p@ returns @False@. +dropWhileTail :: (a -> Bool) -> [a] -> [a] +dropWhileTail f ls = + case foldr chop Nothing ls of { Just xs -> xs; Nothing -> [] } + where + chop x (Just xs) = Just (x:xs) + chop x _ + | f x = Nothing + | otherwise = Just [x] + +-- | @chopAtDelim elt ls@ breaks up @ls@ into two at first occurrence +-- of @elt@; @elt@ is elided too. If @elt@ does not occur, the second +-- list is empty and the first is equal to @ls@. +chopAtDelim :: Eq a => a -> [a] -> ([a],[a]) +chopAtDelim elt xs = + case break (==elt) xs of + (_,[]) -> (xs,[]) + (as,_:bs) -> (as,bs) diff --git a/Network/Socket.hsc b/Network/Socket.hsc new file mode 100644 --- /dev/null +++ b/Network/Socket.hsc @@ -0,0 +1,2236 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-unused-do-bind #-} +----------------------------------------------------------------------------- +-- | +-- Module : Network.Socket +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/network/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- The "Network.Socket" module is for when you want full control over +-- sockets. Essentially the entire C socket API is exposed through +-- this module; in general the operations follow the behaviour of the C +-- functions of the same name (consult your favourite Unix networking book). +-- +-- A higher level interface to networking operations is provided +-- through the module "Network". +-- +----------------------------------------------------------------------------- + +#include "HsNet.h" + +-- NOTE: ##, we want this interpreted when compiling the .hs, not by hsc2hs. +##include "Typeable.h" + +-- In order to process this file, you need to have CALLCONV defined. + +module Network.Socket + ( + -- * Types + Socket(..) + , Family(..) + , SocketType(..) + , SockAddr(..) + , SocketStatus(..) + , HostAddress +#if defined(IPV6_SOCKET_SUPPORT) + , HostAddress6 + , FlowInfo + , ScopeID +#endif + , ShutdownCmd(..) + , ProtocolNumber + , defaultProtocol + , PortNumber(..) + -- PortNumber is used non-abstractly in Network.BSD. ToDo: remove + -- this use and make the type abstract. + + -- * Address operations + + , HostName + , ServiceName + +#if defined(IPV6_SOCKET_SUPPORT) + , AddrInfo(..) + + , AddrInfoFlag(..) + , addrInfoFlagImplemented + + , defaultHints + + , getAddrInfo + + , NameInfoFlag(..) + + , getNameInfo +#endif + + -- * Socket operations + , socket +#if defined(DOMAIN_SOCKET_SUPPORT) + , socketPair +#endif + , connect + , bindSocket + , listen + , accept + , getPeerName + , getSocketName + +#ifdef HAVE_STRUCT_UCRED + -- get the credentials of our domain socket peer. + , getPeerCred +#endif + + , socketPort + + , socketToHandle + + -- ** Sending and receiving data + -- $sendrecv + , sendTo + , sendBufTo + + , recvFrom + , recvBufFrom + + , send + , recv + , recvLen + + , inet_addr + , inet_ntoa + + , shutdown + , sClose + + -- ** Predicates on sockets + , sIsConnected + , sIsBound + , sIsListening + , sIsReadable + , sIsWritable + + -- * Socket options + , SocketOption(..) + , getSocketOption + , setSocketOption + + -- * File descriptor transmission +#ifdef DOMAIN_SOCKET_SUPPORT + , sendFd + , recvFd + + -- Note: these two will disappear shortly + , sendAncillary + , recvAncillary + +#endif + + -- * Special constants + , aNY_PORT + , iNADDR_ANY +#if defined(IPV6_SOCKET_SUPPORT) + , iN6ADDR_ANY +#endif + , sOMAXCONN + , sOL_SOCKET +#ifdef SCM_RIGHTS + , sCM_RIGHTS +#endif + , maxListenQueue + + -- * Initialisation + , withSocketsDo + + -- * Very low level operations + -- in case you ever want to get at the underlying file descriptor.. + , fdSocket + , mkSocket + + -- * Internal + + -- | The following are exported ONLY for use in the BSD module and + -- should not be used anywhere else. + + , packFamily + , unpackFamily + , packSocketType + , throwSocketErrorIfMinus1_ + ) where + +#ifdef __HUGS__ +import Hugs.Prelude ( IOException(..), IOErrorType(..) ) +import Hugs.IO ( openFd ) + +{-# CFILES cbits/HsNet.c #-} +# if HAVE_STRUCT_MSGHDR_MSG_CONTROL || HAVE_STRUCT_MSGHDR_MSG_ACCRIGHTS +{-# CFILES cbits/ancilData.c #-} +# endif +# if defined(HAVE_WINSOCK2_H) && !defined(__CYGWIN__) +{-# CFILES cbits/initWinSock.c cbits/winSockErr.c #-} +# endif +#endif + +import Data.Bits +import Data.List (foldl') +import Data.Word (Word16, Word32) +import Foreign.Ptr (Ptr, castPtr, nullPtr) +import Foreign.Storable (Storable(..)) +import Foreign.C.Error +import Foreign.C.String (CString, withCString, peekCString, peekCStringLen) +import Foreign.C.Types (CUInt, CChar) +#if __GLASGOW_HASKELL__ >= 703 +import Foreign.C.Types (CInt(..), CSize(..)) +#else +import Foreign.C.Types (CInt, CSize) +#endif +import Foreign.Marshal.Alloc ( alloca, allocaBytes ) +import Foreign.Marshal.Array ( peekArray ) +import Foreign.Marshal.Utils ( maybeWith, with ) + +import System.IO +import Control.Monad (liftM, when) +import Data.Ratio ((%)) + +import qualified Control.Exception +import Control.Concurrent.MVar +import Data.Typeable +import System.IO.Error + +#ifdef __GLASGOW_HASKELL__ +import GHC.Conc (threadWaitRead, threadWaitWrite) +##if MIN_VERSION_base(4,3,1) +import GHC.Conc (closeFdWith) +##endif +# if defined(mingw32_HOST_OS) +import GHC.Conc (asyncDoProc) +import Foreign (FunPtr) +# endif +# if __GLASGOW_HASKELL__ >= 611 +import qualified GHC.IO.Device +import GHC.IO.Handle.FD +import GHC.IO.Exception +import GHC.IO +# else +import GHC.IOBase +import GHC.Handle +# endif +import qualified System.Posix.Internals +#else +import System.IO.Unsafe (unsafePerformIO) +#endif + +# if __GLASGOW_HASKELL__ >= 611 +import GHC.IO.FD +#endif + +import Network.Socket.Internal + +-- | Either a host name e.g., @\"haskell.org\"@ or a numeric host +-- address string consisting of a dotted decimal IPv4 address or an +-- IPv6 address e.g., @\"192.168.0.1\"@. +type HostName = String +type ServiceName = String + +-- ---------------------------------------------------------------------------- +-- On Windows, our sockets are not put in non-blocking mode (non-blocking +-- is not supported for regular file descriptors on Windows, and it would +-- be a pain to support it only for sockets). So there are two cases: +-- +-- - the threaded RTS uses safe calls for socket operations to get +-- non-blocking I/O, just like the rest of the I/O library +-- +-- - with the non-threaded RTS, only some operations on sockets will be +-- non-blocking. Reads and writes go through the normal async I/O +-- system. accept() uses asyncDoProc so is non-blocking. A handful +-- of others (recvFrom, sendFd, recvFd) will block all threads - if this +-- is a problem, -threaded is the workaround. +-- +##if defined(mingw32_HOST_OS) +##define SAFE_ON_WIN safe +##else +##define SAFE_ON_WIN unsafe +##endif + +----------------------------------------------------------------------------- +-- Socket types + +-- There are a few possible ways to do this. The first is convert the +-- structs used in the C library into an equivalent Haskell type. An +-- other possible implementation is to keep all the internals in the C +-- code and use an Int## and a status flag. The second method is used +-- here since a lot of the C structures are not required to be +-- manipulated. + +-- Originally the status was non-mutable so we had to return a new +-- socket each time we changed the status. This version now uses +-- mutable variables to avoid the need to do this. The result is a +-- cleaner interface and better security since the application +-- programmer now can't circumvent the status information to perform +-- invalid operations on sockets. + +data SocketStatus + -- Returned Status Function called + = NotConnected -- socket + | Bound -- bindSocket + | Listening -- listen + | Connected -- connect/accept + | ConvertedToHandle -- is now a Handle, don't touch + | Closed -- sClose + deriving (Eq, Show, Typeable) + +data Socket + = MkSocket + CInt -- File Descriptor + Family + SocketType + ProtocolNumber -- Protocol Number + (MVar SocketStatus) -- Status Flag + deriving Typeable + +#if __GLASGOW_HASKELL__ >= 611 && defined(mingw32_HOST_OS) +socket2FD (MkSocket fd _ _ _ _) = + -- HACK, 1 means True + FD{fdFD = fd,fdIsSocket_ = 1} +#endif + +mkSocket :: CInt + -> Family + -> SocketType + -> ProtocolNumber + -> SocketStatus + -> IO Socket +mkSocket fd fam sType pNum stat = do + mStat <- newMVar stat + return (MkSocket fd fam sType pNum mStat) + +instance Eq Socket where + (MkSocket _ _ _ _ m1) == (MkSocket _ _ _ _ m2) = m1 == m2 + +instance Show Socket where + showsPrec _n (MkSocket fd _ _ _ _) = + showString "" + + +fdSocket :: Socket -> CInt +fdSocket (MkSocket fd _ _ _ _) = fd + +type ProtocolNumber = CInt + +-- | This is the default protocol for a given service. +defaultProtocol :: ProtocolNumber +defaultProtocol = 0 + +---------------------------------------------------------------------------- +-- Port Numbers + +instance Show PortNumber where + showsPrec p pn = showsPrec p (portNumberToInt pn) + +intToPortNumber :: Int -> PortNumber +intToPortNumber v = PortNum (htons (fromIntegral v)) + +portNumberToInt :: PortNumber -> Int +portNumberToInt (PortNum po) = fromIntegral (ntohs po) + +foreign import CALLCONV unsafe "ntohs" ntohs :: Word16 -> Word16 +foreign import CALLCONV unsafe "htons" htons :: Word16 -> Word16 +--foreign import CALLCONV unsafe "ntohl" ntohl :: Word32 -> Word32 +foreign import CALLCONV unsafe "htonl" htonl :: Word32 -> Word32 + +instance Enum PortNumber where + toEnum = intToPortNumber + fromEnum = portNumberToInt + +instance Num PortNumber where + fromInteger i = intToPortNumber (fromInteger i) + -- for completeness. + (+) x y = intToPortNumber (portNumberToInt x + portNumberToInt y) + (-) x y = intToPortNumber (portNumberToInt x - portNumberToInt y) + negate x = intToPortNumber (-portNumberToInt x) + (*) x y = intToPortNumber (portNumberToInt x * portNumberToInt y) + abs n = intToPortNumber (abs (portNumberToInt n)) + signum n = intToPortNumber (signum (portNumberToInt n)) + +instance Real PortNumber where + toRational x = toInteger x % 1 + +instance Integral PortNumber where + quotRem a b = let (c,d) = quotRem (portNumberToInt a) (portNumberToInt b) in + (intToPortNumber c, intToPortNumber d) + toInteger a = toInteger (portNumberToInt a) + +instance Storable PortNumber where + sizeOf _ = sizeOf (undefined :: Word16) + alignment _ = alignment (undefined :: Word16) + poke p (PortNum po) = poke (castPtr p) po + peek p = PortNum `liftM` peek (castPtr p) + +----------------------------------------------------------------------------- +-- SockAddr + +instance Show SockAddr where +#if defined(DOMAIN_SOCKET_SUPPORT) + showsPrec _ (SockAddrUnix str) = showString str +#endif + showsPrec _ (SockAddrInet port ha) + = showString (unsafePerformIO (inet_ntoa ha)) + . showString ":" + . shows port +#if defined(IPV6_SOCKET_SUPPORT) + showsPrec _ addr@(SockAddrInet6 port _ _ _) + = showChar '[' + . showString (unsafePerformIO $ + fst `liftM` getNameInfo [NI_NUMERICHOST] True False addr >>= + maybe (fail "showsPrec: impossible internal error") return) + . showString "]:" + . shows port +#endif + +----------------------------------------------------------------------------- +-- Connection Functions + +-- In the following connection and binding primitives. The names of +-- the equivalent C functions have been preserved where possible. It +-- should be noted that some of these names used in the C library, +-- \tr{bind} in particular, have a different meaning to many Haskell +-- programmers and have thus been renamed by appending the prefix +-- Socket. + +-- | Create a new socket using the given address family, socket type +-- and protocol number. The address family is usually 'AF_INET', +-- 'AF_INET6', or 'AF_UNIX'. The socket type is usually 'Stream' or +-- 'Datagram'. The protocol number is usually 'defaultProtocol'. +-- If 'AF_INET6' is used, the 'IPv6Only' socket option is set to 0 +-- so that both IPv4 and IPv6 can be handled with one socket. +socket :: Family -- Family Name (usually AF_INET) + -> SocketType -- Socket Type (usually Stream) + -> ProtocolNumber -- Protocol Number (getProtocolByName to find value) + -> IO Socket -- Unconnected Socket +socket family stype protocol = do + fd <- throwSocketErrorIfMinus1Retry "socket" $ + c_socket (packFamily family) (packSocketType stype) protocol +#if !defined(__HUGS__) +# if __GLASGOW_HASKELL__ < 611 + System.Posix.Internals.setNonBlockingFD fd +# else + System.Posix.Internals.setNonBlockingFD fd True +# endif +#endif + socket_status <- newMVar NotConnected + let sock = MkSocket fd family stype protocol socket_status +#if HAVE_DECL_IPV6_V6ONLY +# if defined(mingw32_HOST_OS) + -- the IPv6Only option is only supported on Windows Vista and later, + -- so trying to change it might throw an error + when (family == AF_INET6) $ + catch (setSocketOption sock IPv6Only 0) $ const $ return () +# else + when (family == AF_INET6) $ setSocketOption sock IPv6Only 0 +# endif +#endif + return sock + +-- | Build a pair of connected socket objects using the given address +-- family, socket type, and protocol number. Address family, socket +-- type, and protocol number are as for the 'socket' function above. +-- Availability: Unix. +#if defined(DOMAIN_SOCKET_SUPPORT) +socketPair :: Family -- Family Name (usually AF_INET or AF_INET6) + -> SocketType -- Socket Type (usually Stream) + -> ProtocolNumber -- Protocol Number + -> IO (Socket, Socket) -- unnamed and connected. +socketPair family stype protocol = do + allocaBytes (2 * sizeOf (1 :: CInt)) $ \ fdArr -> do + _rc <- throwSocketErrorIfMinus1Retry "socketpair" $ + c_socketpair (packFamily family) + (packSocketType stype) + protocol fdArr + [fd1,fd2] <- peekArray 2 fdArr + s1 <- mkNonBlockingSocket fd1 + s2 <- mkNonBlockingSocket fd2 + return (s1,s2) + where + mkNonBlockingSocket fd = do +#if !defined(__HUGS__) +# if __GLASGOW_HASKELL__ < 611 + System.Posix.Internals.setNonBlockingFD fd +# else + System.Posix.Internals.setNonBlockingFD fd True +# endif +#endif + stat <- newMVar Connected + return (MkSocket fd family stype protocol stat) + +foreign import ccall unsafe "socketpair" + c_socketpair :: CInt -> CInt -> CInt -> Ptr CInt -> IO CInt +#endif + +----------------------------------------------------------------------------- +-- Binding a socket + +-- | Bind the socket to an address. The socket must not already be +-- bound. The 'Family' passed to @bindSocket@ must be the +-- same as that passed to 'socket'. If the special port number +-- 'aNY_PORT' is passed then the system assigns the next available +-- use port. +bindSocket :: Socket -- Unconnected Socket + -> SockAddr -- Address to Bind to + -> IO () +bindSocket (MkSocket s _family _stype _protocol socketStatus) addr = do + modifyMVar_ socketStatus $ \ status -> do + if status /= NotConnected + then + ioError (userError ("bindSocket: can't peform bind on socket in status " ++ + show status)) + else do + withSockAddr addr $ \p_addr sz -> do + _status <- throwSocketErrorIfMinus1Retry "bind" $ c_bind s p_addr (fromIntegral sz) + return Bound + +----------------------------------------------------------------------------- +-- Connecting a socket + +-- | Connect to a remote socket at address. +connect :: Socket -- Unconnected Socket + -> SockAddr -- Socket address stuff + -> IO () +connect sock@(MkSocket s _family _stype _protocol socketStatus) addr = do + modifyMVar_ socketStatus $ \currentStatus -> do + if currentStatus /= NotConnected && currentStatus /= Bound + then + ioError (userError ("connect: can't peform connect on socket in status " ++ + show currentStatus)) + else do + withSockAddr addr $ \p_addr sz -> do + + let connectLoop = do + r <- c_connect s p_addr (fromIntegral sz) + if r == -1 + then do +#if !(defined(HAVE_WINSOCK2_H) && !defined(cygwin32_HOST_OS)) + err <- getErrno + case () of + _ | err == eINTR -> connectLoop + _ | err == eINPROGRESS -> connectBlocked +-- _ | err == eAGAIN -> connectBlocked + _otherwise -> throwSocketError "connect" +#else + rc <- c_getLastError + case rc of + 10093 -> do -- WSANOTINITIALISED + withSocketsDo (return ()) + r <- c_connect s p_addr (fromIntegral sz) + if r == -1 + then throwSocketError "connect" + else return r + _ -> throwSocketError "connect" +#endif + else return r + + connectBlocked = do +#if !defined(__HUGS__) + threadWaitWrite (fromIntegral s) +#endif + err <- getSocketOption sock SoError + if (err == 0) + then return 0 + else do ioError (errnoToIOError "connect" + (Errno (fromIntegral err)) + Nothing Nothing) + + connectLoop + return Connected + +----------------------------------------------------------------------------- +-- Listen + +-- | Listen for connections made to the socket. The second argument +-- specifies the maximum number of queued connections and should be at +-- least 1; the maximum value is system-dependent (usually 5). +listen :: Socket -- Connected & Bound Socket + -> Int -- Queue Length + -> IO () +listen (MkSocket s _family _stype _protocol socketStatus) backlog = do + modifyMVar_ socketStatus $ \ status -> do + if status /= Bound + then + ioError (userError ("listen: can't peform listen on socket in status " ++ + show status)) + else do + throwSocketErrorIfMinus1Retry "listen" (c_listen s (fromIntegral backlog)) + return Listening + +----------------------------------------------------------------------------- +-- Accept +-- +-- A call to `accept' only returns when data is available on the given +-- socket, unless the socket has been set to non-blocking. It will +-- return a new socket which should be used to read the incoming data and +-- should then be closed. Using the socket returned by `accept' allows +-- incoming requests to be queued on the original socket. + +-- | Accept a connection. The socket must be bound to an address and +-- listening for connections. The return value is a pair @(conn, +-- address)@ where @conn@ is a new socket object usable to send and +-- receive data on the connection, and @address@ is the address bound +-- to the socket on the other end of the connection. +accept :: Socket -- Queue Socket + -> IO (Socket, -- Readable Socket + SockAddr) -- Peer details + +accept sock@(MkSocket s family stype protocol status) = do + currentStatus <- readMVar status + okay <- sIsAcceptable sock + if not okay + then + ioError (userError ("accept: can't perform accept on socket (" ++ (show (family,stype,protocol)) ++") in status " ++ + show currentStatus)) + else do + let sz = sizeOfSockAddrByFamily family + allocaBytes sz $ \ sockaddr -> do +#if defined(mingw32_HOST_OS) && defined(__GLASGOW_HASKELL__) + new_sock <- + if threaded + then with (fromIntegral sz) $ \ ptr_len -> + throwErrnoIfMinus1Retry "Network.Socket.accept" $ + c_accept_safe s sockaddr ptr_len + else do + paramData <- c_newAcceptParams s (fromIntegral sz) sockaddr + rc <- asyncDoProc c_acceptDoProc paramData + new_sock <- c_acceptNewSock paramData + c_free paramData + when (rc /= 0) + (ioError (errnoToIOError "Network.Socket.accept" (Errno (fromIntegral rc)) Nothing Nothing)) + return new_sock +#else + with (fromIntegral sz) $ \ ptr_len -> do + new_sock <- +# if !defined(__HUGS__) + throwSocketErrorIfMinus1RetryMayBlock "accept" + (threadWaitRead (fromIntegral s)) +# endif + (c_accept s sockaddr ptr_len) +# if !defined(__HUGS__) +# if __GLASGOW_HASKELL__ < 611 + System.Posix.Internals.setNonBlockingFD new_sock +# else + System.Posix.Internals.setNonBlockingFD new_sock True +# endif +# endif +#endif + addr <- peekSockAddr sockaddr + new_status <- newMVar Connected + return ((MkSocket new_sock family stype protocol new_status), addr) + +#if defined(mingw32_HOST_OS) && !defined(__HUGS__) +foreign import ccall unsafe "HsNet.h acceptNewSock" + c_acceptNewSock :: Ptr () -> IO CInt +foreign import ccall unsafe "HsNet.h newAcceptParams" + c_newAcceptParams :: CInt -> CInt -> Ptr a -> IO (Ptr ()) +foreign import ccall unsafe "HsNet.h &acceptDoProc" + c_acceptDoProc :: FunPtr (Ptr () -> IO Int) +foreign import ccall unsafe "free" + c_free:: Ptr a -> IO () +#endif + +----------------------------------------------------------------------------- +-- ** Sending and reciving data + +-- $sendrecv +-- +-- Do not use the @send@ and @recv@ functions defined in this module +-- in new code, as they incorrectly represent binary data as a Unicode +-- string. As a result, these functions are inefficient and may lead +-- to bugs in the program. Instead use the @send@ and @recv@ +-- functions defined in the 'Network.Socket.ByteString' module. + +----------------------------------------------------------------------------- +-- sendTo & recvFrom + +-- | Send data to the socket. The recipient can be specified +-- explicitly, so the socket need not be in a connected state. +-- Returns the number of bytes sent. Applications are responsible for +-- ensuring that all data has been sent. +-- +-- NOTE: blocking on Windows unless you compile with -threaded (see +-- GHC ticket #1129) +sendTo :: Socket -- (possibly) bound/connected Socket + -> String -- Data to send + -> SockAddr + -> IO Int -- Number of Bytes sent +sendTo sock xs addr = do + withCString xs $ \str -> do + sendBufTo sock str (length xs) addr + +-- | Send data to the socket. The recipient can be specified +-- explicitly, so the socket need not be in a connected state. +-- Returns the number of bytes sent. Applications are responsible for +-- ensuring that all data has been sent. +sendBufTo :: Socket -- (possibly) bound/connected Socket + -> Ptr a -> Int -- Data to send + -> SockAddr + -> IO Int -- Number of Bytes sent +sendBufTo (MkSocket s _family _stype _protocol _status) ptr nbytes addr = do + withSockAddr addr $ \p_addr sz -> do + liftM fromIntegral $ +#if !defined(__HUGS__) + throwSocketErrorIfMinus1RetryMayBlock "sendTo" + (threadWaitWrite (fromIntegral s)) $ +#endif + c_sendto s ptr (fromIntegral $ nbytes) 0{-flags-} + p_addr (fromIntegral sz) + +-- | Receive data from the socket. The socket need not be in a +-- connected state. Returns @(bytes, nbytes, address)@ where @bytes@ +-- is a @String@ of length @nbytes@ representing the data received and +-- @address@ is a 'SockAddr' representing the address of the sending +-- socket. +-- +-- NOTE: blocking on Windows unless you compile with -threaded (see +-- GHC ticket #1129) +recvFrom :: Socket -> Int -> IO (String, Int, SockAddr) +recvFrom sock nbytes = + allocaBytes nbytes $ \ptr -> do + (len, sockaddr) <- recvBufFrom sock ptr nbytes + str <- peekCStringLen (ptr, len) + return (str, len, sockaddr) + +-- | Receive data from the socket, writing it into buffer instead of +-- creating a new string. The socket need not be in a connected +-- state. Returns @(nbytes, address)@ where @nbytes@ is the number of +-- bytes received and @address@ is a 'SockAddr' representing the +-- address of the sending socket. +-- +-- NOTE: blocking on Windows unless you compile with -threaded (see +-- GHC ticket #1129) +recvBufFrom :: Socket -> Ptr a -> Int -> IO (Int, SockAddr) +recvBufFrom sock@(MkSocket s family _stype _protocol _status) ptr nbytes + | nbytes <= 0 = ioError (mkInvalidRecvArgError "Network.Socket.recvFrom") + | otherwise = + withNewSockAddr family $ \ptr_addr sz -> do + alloca $ \ptr_len -> do + poke ptr_len (fromIntegral sz) + len <- +#if !defined(__HUGS__) + throwSocketErrorIfMinus1RetryMayBlock "recvFrom" + (threadWaitRead (fromIntegral s)) $ +#endif + c_recvfrom s ptr (fromIntegral nbytes) 0{-flags-} + ptr_addr ptr_len + let len' = fromIntegral len + if len' == 0 + then ioError (mkEOFError "Network.Socket.recvFrom") + else do + flg <- sIsConnected sock + -- For at least one implementation (WinSock 2), recvfrom() ignores + -- filling in the sockaddr for connected TCP sockets. Cope with + -- this by using getPeerName instead. + sockaddr <- + if flg then + getPeerName sock + else + peekSockAddr ptr_addr + return (len', sockaddr) + +----------------------------------------------------------------------------- +-- send & recv + +-- | Send data to the socket. The socket must be connected to a remote +-- socket. Returns the number of bytes sent. Applications are +-- responsible for ensuring that all data has been sent. +send :: Socket -- Bound/Connected Socket + -> String -- Data to send + -> IO Int -- Number of Bytes sent +send sock@(MkSocket s _family _stype _protocol _status) xs = do + let len = length xs + withCString xs $ \str -> do + liftM fromIntegral $ +#if defined(__GLASGOW_HASKELL__) && defined(mingw32_HOST_OS) +# if __GLASGOW_HASKELL__ >= 611 + writeRawBufferPtr + "Network.Socket.send" + (socket2FD sock) + (castPtr str) + 0 + (fromIntegral len) +#else + writeRawBufferPtr + "Network.Socket.send" + (fromIntegral s) + True + str + 0 + (fromIntegral len) +#endif + +#else +# if !defined(__HUGS__) + throwSocketErrorIfMinus1RetryMayBlock "send" + (threadWaitWrite (fromIntegral s)) $ +# endif + c_send s str (fromIntegral len) 0{-flags-} +#endif + +-- | Receive data from the socket. The socket must be in a connected +-- state. This function may return fewer bytes than specified. If the +-- message is longer than the specified length, it may be discarded +-- depending on the type of socket. This function may block until a +-- message arrives. +-- +-- Considering hardware and network realities, the maximum number of +-- bytes to receive should be a small power of 2, e.g., 4096. +-- +-- For TCP sockets, a zero length return value means the peer has +-- closed its half side of the connection. +recv :: Socket -> Int -> IO String +recv sock l = recvLen sock l >>= \ (s,_) -> return s + +recvLen :: Socket -> Int -> IO (String, Int) +recvLen sock@(MkSocket s _family _stype _protocol _status) nbytes + | nbytes <= 0 = ioError (mkInvalidRecvArgError "Network.Socket.recv") + | otherwise = do + allocaBytes nbytes $ \ptr -> do + len <- +#if defined(__GLASGOW_HASKELL__) && defined(mingw32_HOST_OS) +# if __GLASGOW_HASKELL__ >= 611 + readRawBufferPtr "Network.Socket.recvLen" (socket2FD sock) ptr 0 + (fromIntegral nbytes) +#else + readRawBufferPtr "Network.Socket.recvLen" (fromIntegral s) True ptr 0 + (fromIntegral nbytes) +#endif +#else +# if !defined(__HUGS__) + throwSocketErrorIfMinus1RetryMayBlock "recv" + (threadWaitRead (fromIntegral s)) $ +# endif + c_recv s ptr (fromIntegral nbytes) 0{-flags-} +#endif + let len' = fromIntegral len + if len' == 0 + then ioError (mkEOFError "Network.Socket.recv") + else do + s' <- peekCStringLen (castPtr ptr,len') + return (s', len') + +-- --------------------------------------------------------------------------- +-- socketPort +-- +-- The port number the given socket is currently connected to can be +-- determined by calling $port$, is generally only useful when bind +-- was given $aNY\_PORT$. + +socketPort :: Socket -- Connected & Bound Socket + -> IO PortNumber -- Port Number of Socket +socketPort sock@(MkSocket _ AF_INET _ _ _) = do + (SockAddrInet port _) <- getSocketName sock + return port +#if defined(IPV6_SOCKET_SUPPORT) +socketPort sock@(MkSocket _ AF_INET6 _ _ _) = do + (SockAddrInet6 port _ _ _) <- getSocketName sock + return port +#endif +socketPort (MkSocket _ family _ _ _) = + ioError (userError ("socketPort: not supported for Family " ++ show family)) + + +-- --------------------------------------------------------------------------- +-- getPeerName + +-- Calling $getPeerName$ returns the address details of the machine, +-- other than the local one, which is connected to the socket. This is +-- used in programs such as FTP to determine where to send the +-- returning data. The corresponding call to get the details of the +-- local machine is $getSocketName$. + +getPeerName :: Socket -> IO SockAddr +getPeerName (MkSocket s family _ _ _) = do + withNewSockAddr family $ \ptr sz -> do + with (fromIntegral sz) $ \int_star -> do + throwSocketErrorIfMinus1Retry "getPeerName" $ c_getpeername s ptr int_star + _sz <- peek int_star + peekSockAddr ptr + +getSocketName :: Socket -> IO SockAddr +getSocketName (MkSocket s family _ _ _) = do + withNewSockAddr family $ \ptr sz -> do + with (fromIntegral sz) $ \int_star -> do + throwSocketErrorIfMinus1Retry "getSocketName" $ c_getsockname s ptr int_star + peekSockAddr ptr + +----------------------------------------------------------------------------- +-- Socket Properties + +data SocketOption + = DummySocketOption__ +#ifdef SO_DEBUG + | Debug {- SO_DEBUG -} +#endif +#ifdef SO_REUSEADDR + | ReuseAddr {- SO_REUSEADDR -} +#endif +#ifdef SO_TYPE + | Type {- SO_TYPE -} +#endif +#ifdef SO_ERROR + | SoError {- SO_ERROR -} +#endif +#ifdef SO_DONTROUTE + | DontRoute {- SO_DONTROUTE -} +#endif +#ifdef SO_BROADCAST + | Broadcast {- SO_BROADCAST -} +#endif +#ifdef SO_SNDBUF + | SendBuffer {- SO_SNDBUF -} +#endif +#ifdef SO_RCVBUF + | RecvBuffer {- SO_RCVBUF -} +#endif +#ifdef SO_KEEPALIVE + | KeepAlive {- SO_KEEPALIVE -} +#endif +#ifdef SO_OOBINLINE + | OOBInline {- SO_OOBINLINE -} +#endif +#ifdef IP_TTL + | TimeToLive {- IP_TTL -} +#endif +#ifdef TCP_MAXSEG + | MaxSegment {- TCP_MAXSEG -} +#endif +#ifdef TCP_NODELAY + | NoDelay {- TCP_NODELAY -} +#endif +#ifdef SO_LINGER + | Linger {- SO_LINGER -} +#endif +#ifdef SO_REUSEPORT + | ReusePort {- SO_REUSEPORT -} +#endif +#ifdef SO_RCVLOWAT + | RecvLowWater {- SO_RCVLOWAT -} +#endif +#ifdef SO_SNDLOWAT + | SendLowWater {- SO_SNDLOWAT -} +#endif +#ifdef SO_RCVTIMEO + | RecvTimeOut {- SO_RCVTIMEO -} +#endif +#ifdef SO_SNDTIMEO + | SendTimeOut {- SO_SNDTIMEO -} +#endif +#ifdef SO_USELOOPBACK + | UseLoopBack {- SO_USELOOPBACK -} +#endif +#if HAVE_DECL_IPV6_V6ONLY + | IPv6Only {- IPV6_V6ONLY -} +#endif + deriving (Show, Typeable) + +socketOptLevel :: SocketOption -> CInt +socketOptLevel so = + case so of +#ifdef IP_TTL + TimeToLive -> #const IPPROTO_IP +#endif +#ifdef TCP_MAXSEG + MaxSegment -> #const IPPROTO_TCP +#endif +#ifdef TCP_NODELAY + NoDelay -> #const IPPROTO_TCP +#endif +#if HAVE_DECL_IPV6_V6ONLY + IPv6Only -> #const IPPROTO_IPV6 +#endif + _ -> #const SOL_SOCKET + +packSocketOption :: SocketOption -> CInt +packSocketOption so = + case so of +#ifdef SO_DEBUG + Debug -> #const SO_DEBUG +#endif +#ifdef SO_REUSEADDR + ReuseAddr -> #const SO_REUSEADDR +#endif +#ifdef SO_TYPE + Type -> #const SO_TYPE +#endif +#ifdef SO_ERROR + SoError -> #const SO_ERROR +#endif +#ifdef SO_DONTROUTE + DontRoute -> #const SO_DONTROUTE +#endif +#ifdef SO_BROADCAST + Broadcast -> #const SO_BROADCAST +#endif +#ifdef SO_SNDBUF + SendBuffer -> #const SO_SNDBUF +#endif +#ifdef SO_RCVBUF + RecvBuffer -> #const SO_RCVBUF +#endif +#ifdef SO_KEEPALIVE + KeepAlive -> #const SO_KEEPALIVE +#endif +#ifdef SO_OOBINLINE + OOBInline -> #const SO_OOBINLINE +#endif +#ifdef IP_TTL + TimeToLive -> #const IP_TTL +#endif +#ifdef TCP_MAXSEG + MaxSegment -> #const TCP_MAXSEG +#endif +#ifdef TCP_NODELAY + NoDelay -> #const TCP_NODELAY +#endif +#ifdef SO_LINGER + Linger -> #const SO_LINGER +#endif +#ifdef SO_REUSEPORT + ReusePort -> #const SO_REUSEPORT +#endif +#ifdef SO_RCVLOWAT + RecvLowWater -> #const SO_RCVLOWAT +#endif +#ifdef SO_SNDLOWAT + SendLowWater -> #const SO_SNDLOWAT +#endif +#ifdef SO_RCVTIMEO + RecvTimeOut -> #const SO_RCVTIMEO +#endif +#ifdef SO_SNDTIMEO + SendTimeOut -> #const SO_SNDTIMEO +#endif +#ifdef SO_USELOOPBACK + UseLoopBack -> #const SO_USELOOPBACK +#endif +#if HAVE_DECL_IPV6_V6ONLY + IPv6Only -> #const IPV6_V6ONLY +#endif + unknown -> error ("Network.Socket.packSocketOption: unknown option " ++ + show unknown) + +setSocketOption :: Socket + -> SocketOption -- Option Name + -> Int -- Option Value + -> IO () +setSocketOption (MkSocket s _ _ _ _) so v = do + with (fromIntegral v) $ \ptr_v -> do + throwErrnoIfMinus1_ "setSocketOption" $ + c_setsockopt s (socketOptLevel so) (packSocketOption so) ptr_v + (fromIntegral (sizeOf (undefined :: CInt))) + return () + + +getSocketOption :: Socket + -> SocketOption -- Option Name + -> IO Int -- Option Value +getSocketOption (MkSocket s _ _ _ _) so = do + alloca $ \ptr_v -> + with (fromIntegral (sizeOf (undefined :: CInt))) $ \ptr_sz -> do + throwErrnoIfMinus1 "getSocketOption" $ + c_getsockopt s (socketOptLevel so) (packSocketOption so) ptr_v ptr_sz + fromIntegral `liftM` peek ptr_v + + +#ifdef HAVE_STRUCT_UCRED +-- | Returns the processID, userID and groupID of the socket's peer. +-- +-- Only available on platforms that support SO_PEERCRED on domain sockets. +getPeerCred :: Socket -> IO (CUInt, CUInt, CUInt) +getPeerCred sock = do + let fd = fdSocket sock + let sz = (fromIntegral (#const sizeof(struct ucred))) + with sz $ \ ptr_cr -> + alloca $ \ ptr_sz -> do + poke ptr_sz sz + throwErrnoIfMinus1 "getPeerCred" $ + c_getsockopt fd (#const SOL_SOCKET) (#const SO_PEERCRED) ptr_cr ptr_sz + pid <- (#peek struct ucred, pid) ptr_cr + uid <- (#peek struct ucred, uid) ptr_cr + gid <- (#peek struct ucred, gid) ptr_cr + return (pid, uid, gid) +#endif + +##if !(MIN_VERSION_base(4,3,1)) +closeFdWith closer fd = closer fd +##endif + +#if defined(DOMAIN_SOCKET_SUPPORT) +-- sending/receiving ancillary socket data; low-level mechanism +-- for transmitting file descriptors, mainly. +sendFd :: Socket -> CInt -> IO () +sendFd sock outfd = do + let fd = fdSocket sock +#if !defined(__HUGS__) + throwSocketErrorIfMinus1RetryMayBlock "sendFd" + (threadWaitWrite (fromIntegral fd)) $ + c_sendFd fd outfd +#else + c_sendFd fd outfd +#endif + -- Note: If Winsock supported FD-passing, thi would have been + -- incorrect (since socket FDs need to be closed via closesocket().) + close outfd + +recvFd :: Socket -> IO CInt +recvFd sock = do + let fd = fdSocket sock + theFd <- +#if !defined(__HUGS__) + throwSocketErrorIfMinus1RetryMayBlock "recvFd" + (threadWaitRead (fromIntegral fd)) $ +#endif + c_recvFd fd + return theFd + + +sendAncillary :: Socket + -> Int + -> Int + -> Int + -> Ptr a + -> Int + -> IO () +sendAncillary sock level ty flags datum len = do + let fd = fdSocket sock + _ <- +#if !defined(__HUGS__) + throwSocketErrorIfMinus1RetryMayBlock "sendAncillary" + (threadWaitWrite (fromIntegral fd)) $ +#endif + c_sendAncillary fd (fromIntegral level) (fromIntegral ty) + (fromIntegral flags) datum (fromIntegral len) + return () + +recvAncillary :: Socket + -> Int + -> Int + -> IO (Int,Int,Ptr a,Int) +recvAncillary sock flags len = do + let fd = fdSocket sock + alloca $ \ ptr_len -> + alloca $ \ ptr_lev -> + alloca $ \ ptr_ty -> + alloca $ \ ptr_pData -> do + poke ptr_len (fromIntegral len) + _ <- +#if !defined(__HUGS__) + throwSocketErrorIfMinus1RetryMayBlock "recvAncillary" + (threadWaitRead (fromIntegral fd)) $ +#endif + c_recvAncillary fd ptr_lev ptr_ty (fromIntegral flags) ptr_pData ptr_len + rcvlen <- fromIntegral `liftM` peek ptr_len + lev <- fromIntegral `liftM` peek ptr_lev + ty <- fromIntegral `liftM` peek ptr_ty + pD <- peek ptr_pData + return (lev,ty,pD, rcvlen) +foreign import ccall SAFE_ON_WIN "sendAncillary" + c_sendAncillary :: CInt -> CInt -> CInt -> CInt -> Ptr a -> CInt -> IO CInt + +foreign import ccall SAFE_ON_WIN "recvAncillary" + c_recvAncillary :: CInt -> Ptr CInt -> Ptr CInt -> CInt -> Ptr (Ptr a) -> Ptr CInt -> IO CInt + +foreign import ccall SAFE_ON_WIN "sendFd" c_sendFd :: CInt -> CInt -> IO CInt +foreign import ccall SAFE_ON_WIN "recvFd" c_recvFd :: CInt -> IO CInt + +#endif + + +{- +A calling sequence table for the main functions is shown in the table below. + +\begin{figure}[h] +\begin{center} +\begin{tabular}{|l|c|c|c|c|c|c|c|}d +\hline +{\bf A Call to} & socket & connect & bindSocket & listen & accept & read & write \\ +\hline +{\bf Precedes} & & & & & & & \\ +\hline +socket & & & & & & & \\ +\hline +connect & + & & & & & & \\ +\hline +bindSocket & + & & & & & & \\ +\hline +listen & & & + & & & & \\ +\hline +accept & & & & + & & & \\ +\hline +read & & + & & + & + & + & + \\ +\hline +write & & + & & + & + & + & + \\ +\hline +\end{tabular} +\caption{Sequence Table for Major functions of Socket} +\label{tab:api-seq} +\end{center} +\end{figure} +-} + +-- --------------------------------------------------------------------------- +-- OS Dependent Definitions + +unpackFamily :: CInt -> Family +packFamily :: Family -> CInt + +packSocketType :: SocketType -> CInt +unpackSocketType:: CInt -> SocketType + +------ ------ + +packFamily f = case f of + AF_UNSPEC -> #const AF_UNSPEC +#ifdef AF_UNIX + AF_UNIX -> #const AF_UNIX +#endif +#ifdef AF_INET + AF_INET -> #const AF_INET +#endif +#ifdef AF_INET6 + AF_INET6 -> #const AF_INET6 +#endif +#ifdef AF_IMPLINK + AF_IMPLINK -> #const AF_IMPLINK +#endif +#ifdef AF_PUP + AF_PUP -> #const AF_PUP +#endif +#ifdef AF_CHAOS + AF_CHAOS -> #const AF_CHAOS +#endif +#ifdef AF_NS + AF_NS -> #const AF_NS +#endif +#ifdef AF_NBS + AF_NBS -> #const AF_NBS +#endif +#ifdef AF_ECMA + AF_ECMA -> #const AF_ECMA +#endif +#ifdef AF_DATAKIT + AF_DATAKIT -> #const AF_DATAKIT +#endif +#ifdef AF_CCITT + AF_CCITT -> #const AF_CCITT +#endif +#ifdef AF_SNA + AF_SNA -> #const AF_SNA +#endif +#ifdef AF_DECnet + AF_DECnet -> #const AF_DECnet +#endif +#ifdef AF_DLI + AF_DLI -> #const AF_DLI +#endif +#ifdef AF_LAT + AF_LAT -> #const AF_LAT +#endif +#ifdef AF_HYLINK + AF_HYLINK -> #const AF_HYLINK +#endif +#ifdef AF_APPLETALK + AF_APPLETALK -> #const AF_APPLETALK +#endif +#ifdef AF_ROUTE + AF_ROUTE -> #const AF_ROUTE +#endif +#ifdef AF_NETBIOS + AF_NETBIOS -> #const AF_NETBIOS +#endif +#ifdef AF_NIT + AF_NIT -> #const AF_NIT +#endif +#ifdef AF_802 + AF_802 -> #const AF_802 +#endif +#ifdef AF_ISO + AF_ISO -> #const AF_ISO +#endif +#ifdef AF_OSI + AF_OSI -> #const AF_OSI +#endif +#ifdef AF_NETMAN + AF_NETMAN -> #const AF_NETMAN +#endif +#ifdef AF_X25 + AF_X25 -> #const AF_X25 +#endif +#ifdef AF_AX25 + AF_AX25 -> #const AF_AX25 +#endif +#ifdef AF_OSINET + AF_OSINET -> #const AF_OSINET +#endif +#ifdef AF_GOSSIP + AF_GOSSIP -> #const AF_GOSSIP +#endif +#ifdef AF_IPX + AF_IPX -> #const AF_IPX +#endif +#ifdef Pseudo_AF_XTP + Pseudo_AF_XTP -> #const Pseudo_AF_XTP +#endif +#ifdef AF_CTF + AF_CTF -> #const AF_CTF +#endif +#ifdef AF_WAN + AF_WAN -> #const AF_WAN +#endif +#ifdef AF_SDL + AF_SDL -> #const AF_SDL +#endif +#ifdef AF_NETWARE + AF_NETWARE -> #const AF_NETWARE +#endif +#ifdef AF_NDD + AF_NDD -> #const AF_NDD +#endif +#ifdef AF_INTF + AF_INTF -> #const AF_INTF +#endif +#ifdef AF_COIP + AF_COIP -> #const AF_COIP +#endif +#ifdef AF_CNT + AF_CNT -> #const AF_CNT +#endif +#ifdef Pseudo_AF_RTIP + Pseudo_AF_RTIP -> #const Pseudo_AF_RTIP +#endif +#ifdef Pseudo_AF_PIP + Pseudo_AF_PIP -> #const Pseudo_AF_PIP +#endif +#ifdef AF_SIP + AF_SIP -> #const AF_SIP +#endif +#ifdef AF_ISDN + AF_ISDN -> #const AF_ISDN +#endif +#ifdef Pseudo_AF_KEY + Pseudo_AF_KEY -> #const Pseudo_AF_KEY +#endif +#ifdef AF_NATM + AF_NATM -> #const AF_NATM +#endif +#ifdef AF_ARP + AF_ARP -> #const AF_ARP +#endif +#ifdef Pseudo_AF_HDRCMPLT + Pseudo_AF_HDRCMPLT -> #const Pseudo_AF_HDRCMPLT +#endif +#ifdef AF_ENCAP + AF_ENCAP -> #const AF_ENCAP +#endif +#ifdef AF_LINK + AF_LINK -> #const AF_LINK +#endif +#ifdef AF_RAW + AF_RAW -> #const AF_RAW +#endif +#ifdef AF_RIF + AF_RIF -> #const AF_RIF +#endif +#ifdef AF_NETROM + AF_NETROM -> #const AF_NETROM +#endif +#ifdef AF_BRIDGE + AF_BRIDGE -> #const AF_BRIDGE +#endif +#ifdef AF_ATMPVC + AF_ATMPVC -> #const AF_ATMPVC +#endif +#ifdef AF_ROSE + AF_ROSE -> #const AF_ROSE +#endif +#ifdef AF_NETBEUI + AF_NETBEUI -> #const AF_NETBEUI +#endif +#ifdef AF_SECURITY + AF_SECURITY -> #const AF_SECURITY +#endif +#ifdef AF_PACKET + AF_PACKET -> #const AF_PACKET +#endif +#ifdef AF_ASH + AF_ASH -> #const AF_ASH +#endif +#ifdef AF_ECONET + AF_ECONET -> #const AF_ECONET +#endif +#ifdef AF_ATMSVC + AF_ATMSVC -> #const AF_ATMSVC +#endif +#ifdef AF_IRDA + AF_IRDA -> #const AF_IRDA +#endif +#ifdef AF_PPPOX + AF_PPPOX -> #const AF_PPPOX +#endif +#ifdef AF_WANPIPE + AF_WANPIPE -> #const AF_WANPIPE +#endif +#ifdef AF_BLUETOOTH + AF_BLUETOOTH -> #const AF_BLUETOOTH +#endif + +--------- ---------- + +unpackFamily f = case f of + (#const AF_UNSPEC) -> AF_UNSPEC +#ifdef AF_UNIX + (#const AF_UNIX) -> AF_UNIX +#endif +#ifdef AF_INET + (#const AF_INET) -> AF_INET +#endif +#ifdef AF_INET6 + (#const AF_INET6) -> AF_INET6 +#endif +#ifdef AF_IMPLINK + (#const AF_IMPLINK) -> AF_IMPLINK +#endif +#ifdef AF_PUP + (#const AF_PUP) -> AF_PUP +#endif +#ifdef AF_CHAOS + (#const AF_CHAOS) -> AF_CHAOS +#endif +#ifdef AF_NS + (#const AF_NS) -> AF_NS +#endif +#ifdef AF_NBS + (#const AF_NBS) -> AF_NBS +#endif +#ifdef AF_ECMA + (#const AF_ECMA) -> AF_ECMA +#endif +#ifdef AF_DATAKIT + (#const AF_DATAKIT) -> AF_DATAKIT +#endif +#ifdef AF_CCITT + (#const AF_CCITT) -> AF_CCITT +#endif +#ifdef AF_SNA + (#const AF_SNA) -> AF_SNA +#endif +#ifdef AF_DECnet + (#const AF_DECnet) -> AF_DECnet +#endif +#ifdef AF_DLI + (#const AF_DLI) -> AF_DLI +#endif +#ifdef AF_LAT + (#const AF_LAT) -> AF_LAT +#endif +#ifdef AF_HYLINK + (#const AF_HYLINK) -> AF_HYLINK +#endif +#ifdef AF_APPLETALK + (#const AF_APPLETALK) -> AF_APPLETALK +#endif +#ifdef AF_ROUTE + (#const AF_ROUTE) -> AF_ROUTE +#endif +#ifdef AF_NETBIOS + (#const AF_NETBIOS) -> AF_NETBIOS +#endif +#ifdef AF_NIT + (#const AF_NIT) -> AF_NIT +#endif +#ifdef AF_802 + (#const AF_802) -> AF_802 +#endif +#ifdef AF_ISO + (#const AF_ISO) -> AF_ISO +#endif +#ifdef AF_OSI +# if (!defined(AF_ISO)) || (defined(AF_ISO) && (AF_ISO != AF_OSI)) + (#const AF_OSI) -> AF_OSI +# endif +#endif +#ifdef AF_NETMAN + (#const AF_NETMAN) -> AF_NETMAN +#endif +#ifdef AF_X25 + (#const AF_X25) -> AF_X25 +#endif +#ifdef AF_AX25 + (#const AF_AX25) -> AF_AX25 +#endif +#ifdef AF_OSINET + (#const AF_OSINET) -> AF_OSINET +#endif +#ifdef AF_GOSSIP + (#const AF_GOSSIP) -> AF_GOSSIP +#endif +#if defined(AF_IPX) && (!defined(AF_NS) || AF_NS != AF_IPX) + (#const AF_IPX) -> AF_IPX +#endif +#ifdef Pseudo_AF_XTP + (#const Pseudo_AF_XTP) -> Pseudo_AF_XTP +#endif +#ifdef AF_CTF + (#const AF_CTF) -> AF_CTF +#endif +#ifdef AF_WAN + (#const AF_WAN) -> AF_WAN +#endif +#ifdef AF_SDL + (#const AF_SDL) -> AF_SDL +#endif +#ifdef AF_NETWARE + (#const AF_NETWARE) -> AF_NETWARE +#endif +#ifdef AF_NDD + (#const AF_NDD) -> AF_NDD +#endif +#ifdef AF_INTF + (#const AF_INTF) -> AF_INTF +#endif +#ifdef AF_COIP + (#const AF_COIP) -> AF_COIP +#endif +#ifdef AF_CNT + (#const AF_CNT) -> AF_CNT +#endif +#ifdef Pseudo_AF_RTIP + (#const Pseudo_AF_RTIP) -> Pseudo_AF_RTIP +#endif +#ifdef Pseudo_AF_PIP + (#const Pseudo_AF_PIP) -> Pseudo_AF_PIP +#endif +#ifdef AF_SIP + (#const AF_SIP) -> AF_SIP +#endif +#ifdef AF_ISDN + (#const AF_ISDN) -> AF_ISDN +#endif +#ifdef Pseudo_AF_KEY + (#const Pseudo_AF_KEY) -> Pseudo_AF_KEY +#endif +#ifdef AF_NATM + (#const AF_NATM) -> AF_NATM +#endif +#ifdef AF_ARP + (#const AF_ARP) -> AF_ARP +#endif +#ifdef Pseudo_AF_HDRCMPLT + (#const Pseudo_AF_HDRCMPLT) -> Pseudo_AF_HDRCMPLT +#endif +#ifdef AF_ENCAP + (#const AF_ENCAP) -> AF_ENCAP +#endif +#ifdef AF_LINK + (#const AF_LINK) -> AF_LINK +#endif +#ifdef AF_RAW + (#const AF_RAW) -> AF_RAW +#endif +#ifdef AF_RIF + (#const AF_RIF) -> AF_RIF +#endif +#ifdef AF_NETROM + (#const AF_NETROM) -> AF_NETROM +#endif +#ifdef AF_BRIDGE + (#const AF_BRIDGE) -> AF_BRIDGE +#endif +#ifdef AF_ATMPVC + (#const AF_ATMPVC) -> AF_ATMPVC +#endif +#ifdef AF_ROSE + (#const AF_ROSE) -> AF_ROSE +#endif +#ifdef AF_NETBEUI + (#const AF_NETBEUI) -> AF_NETBEUI +#endif +#ifdef AF_SECURITY + (#const AF_SECURITY) -> AF_SECURITY +#endif +#ifdef AF_PACKET + (#const AF_PACKET) -> AF_PACKET +#endif +#ifdef AF_ASH + (#const AF_ASH) -> AF_ASH +#endif +#ifdef AF_ECONET + (#const AF_ECONET) -> AF_ECONET +#endif +#ifdef AF_ATMSVC + (#const AF_ATMSVC) -> AF_ATMSVC +#endif +#ifdef AF_IRDA + (#const AF_IRDA) -> AF_IRDA +#endif +#ifdef AF_PPPOX + (#const AF_PPPOX) -> AF_PPPOX +#endif +#ifdef AF_WANPIPE + (#const AF_WANPIPE) -> AF_WANPIPE +#endif +#ifdef AF_BLUETOOTH + (#const AF_BLUETOOTH) -> AF_BLUETOOTH +#endif + unknown -> error ("Network.Socket.unpackFamily: unknown address " ++ + "family " ++ show unknown) + +-- Socket Types. + +-- | Socket Types. +-- +-- This data type might have different constructors depending on what is +-- supported by the operating system. +data SocketType + = NoSocketType +#ifdef SOCK_STREAM + | Stream +#endif +#ifdef SOCK_DGRAM + | Datagram +#endif +#ifdef SOCK_RAW + | Raw +#endif +#ifdef SOCK_RDM + | RDM +#endif +#ifdef SOCK_SEQPACKET + | SeqPacket +#endif + deriving (Eq, Ord, Read, Show, Typeable) + +packSocketType stype = case stype of + NoSocketType -> 0 +#ifdef SOCK_STREAM + Stream -> #const SOCK_STREAM +#endif +#ifdef SOCK_DGRAM + Datagram -> #const SOCK_DGRAM +#endif +#ifdef SOCK_RAW + Raw -> #const SOCK_RAW +#endif +#ifdef SOCK_RDM + RDM -> #const SOCK_RDM +#endif +#ifdef SOCK_SEQPACKET + SeqPacket -> #const SOCK_SEQPACKET +#endif + +unpackSocketType t = case t of + 0 -> NoSocketType +#ifdef SOCK_STREAM + (#const SOCK_STREAM) -> Stream +#endif +#ifdef SOCK_DGRAM + (#const SOCK_DGRAM) -> Datagram +#endif +#ifdef SOCK_RAW + (#const SOCK_RAW) -> Raw +#endif +#ifdef SOCK_RDM + (#const SOCK_RDM) -> RDM +#endif +#ifdef SOCK_SEQPACKET + (#const SOCK_SEQPACKET) -> SeqPacket +#endif + _ -> NoSocketType + +-- --------------------------------------------------------------------------- +-- Utility Functions + +aNY_PORT :: PortNumber +aNY_PORT = 0 + +-- | The IPv4 wild card address. + +iNADDR_ANY :: HostAddress +iNADDR_ANY = htonl (#const INADDR_ANY) + +#if defined(IPV6_SOCKET_SUPPORT) +-- | The IPv6 wild card address. + +iN6ADDR_ANY :: HostAddress6 +iN6ADDR_ANY = (0, 0, 0, 0) +#endif + +sOMAXCONN :: Int +sOMAXCONN = #const SOMAXCONN + +sOL_SOCKET :: Int +sOL_SOCKET = #const SOL_SOCKET + +#ifdef SCM_RIGHTS +sCM_RIGHTS :: Int +sCM_RIGHTS = #const SCM_RIGHTS +#endif + +maxListenQueue :: Int +maxListenQueue = sOMAXCONN + +-- ----------------------------------------------------------------------------- + +data ShutdownCmd + = ShutdownReceive + | ShutdownSend + | ShutdownBoth + deriving Typeable + +sdownCmdToInt :: ShutdownCmd -> CInt +sdownCmdToInt ShutdownReceive = 0 +sdownCmdToInt ShutdownSend = 1 +sdownCmdToInt ShutdownBoth = 2 + +-- | Shut down one or both halves of the connection, depending on the +-- second argument to the function. If the second argument is +-- 'ShutdownReceive', further receives are disallowed. If it is +-- 'ShutdownSend', further sends are disallowed. If it is +-- 'ShutdownBoth', further sends and receives are disallowed. +shutdown :: Socket -> ShutdownCmd -> IO () +shutdown (MkSocket s _ _ _ _) stype = do + throwSocketErrorIfMinus1Retry "shutdown" (c_shutdown s (sdownCmdToInt stype)) + return () + +-- ----------------------------------------------------------------------------- + +-- | Close the socket. All future operations on the socket object +-- will fail. The remote end will receive no more data (after queued +-- data is flushed). +sClose :: Socket -> IO () +sClose (MkSocket s _ _ _ socketStatus) = do + modifyMVar_ socketStatus $ \ status -> + case status of + ConvertedToHandle -> + ioError (userError ("sClose: converted to a Handle, use hClose instead")) + Closed -> + return status + _ -> closeFdWith (close . fromIntegral) (fromIntegral s) >> return Closed + +-- ----------------------------------------------------------------------------- + +sIsConnected :: Socket -> IO Bool +sIsConnected (MkSocket _ _ _ _ status) = do + value <- readMVar status + return (value == Connected) + +-- ----------------------------------------------------------------------------- +-- Socket Predicates + +sIsBound :: Socket -> IO Bool +sIsBound (MkSocket _ _ _ _ status) = do + value <- readMVar status + return (value == Bound) + +sIsListening :: Socket -> IO Bool +sIsListening (MkSocket _ _ _ _ status) = do + value <- readMVar status + return (value == Listening) + +sIsReadable :: Socket -> IO Bool +sIsReadable (MkSocket _ _ _ _ status) = do + value <- readMVar status + return (value == Listening || value == Connected) + +sIsWritable :: Socket -> IO Bool +sIsWritable = sIsReadable -- sort of. + +sIsAcceptable :: Socket -> IO Bool +#if defined(DOMAIN_SOCKET_SUPPORT) +sIsAcceptable (MkSocket _ AF_UNIX x _ status) + | x == Stream || x == SeqPacket = do + value <- readMVar status + return (value == Connected || value == Bound || value == Listening) +sIsAcceptable (MkSocket _ AF_UNIX _ _ _) = return False +#endif +sIsAcceptable (MkSocket _ _ _ _ status) = do + value <- readMVar status + return (value == Connected || value == Listening) + +-- ----------------------------------------------------------------------------- +-- Internet address manipulation routines: + +inet_addr :: String -> IO HostAddress +inet_addr ipstr = do + withCString ipstr $ \str -> do + had <- c_inet_addr str + if had == -1 + then ioError (userError ("inet_addr: Malformed address: " ++ ipstr)) + else return had -- network byte order + +inet_ntoa :: HostAddress -> IO String +inet_ntoa haddr = do + pstr <- c_inet_ntoa haddr + peekCString pstr + +-- | Turns a Socket into an 'Handle'. By default, the new handle is +-- unbuffered. Use 'System.IO.hSetBuffering' to change the buffering. +-- +-- Note that since a 'Handle' is automatically closed by a finalizer +-- when it is no longer referenced, you should avoid doing any more +-- operations on the 'Socket' after calling 'socketToHandle'. To +-- close the 'Socket' after 'socketToHandle', call 'System.IO.hClose' +-- on the 'Handle'. + +#ifndef __PARALLEL_HASKELL__ +socketToHandle :: Socket -> IOMode -> IO Handle +socketToHandle s@(MkSocket fd _ _ _ socketStatus) mode = do + modifyMVar socketStatus $ \ status -> + if status == ConvertedToHandle + then ioError (userError ("socketToHandle: already a Handle")) + else do +# if __GLASGOW_HASKELL__ >= 611 + h <- fdToHandle' (fromIntegral fd) (Just GHC.IO.Device.Stream) True (show s) mode True{-bin-} +# elif __GLASGOW_HASKELL__ >= 608 + h <- fdToHandle' (fromIntegral fd) (Just System.Posix.Internals.Stream) True (show s) mode True{-bin-} +# elif __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 608 + h <- openFd (fromIntegral fd) (Just System.Posix.Internals.Stream) True (show s) mode True{-bin-} +# elif defined(__HUGS__) + h <- openFd (fromIntegral fd) True{-is a socket-} mode True{-bin-} +# endif + return (ConvertedToHandle, h) +#else +socketToHandle (MkSocket s family stype protocol status) m = + error "socketToHandle not implemented in a parallel setup" +#endif + +-- | Pack a list of values into a bitmask. The possible mappings from +-- value to bit-to-set are given as the first argument. We assume +-- that each value can cause exactly one bit to be set; unpackBits will +-- break if this property is not true. + +packBits :: (Eq a, Num b, Bits b) => [(a, b)] -> [a] -> b + +packBits mapping xs = foldl' pack 0 mapping + where pack acc (k, v) | k `elem` xs = acc .|. v + | otherwise = acc + +-- | Unpack a bitmask into a list of values. + +unpackBits :: (Num b, Bits b) => [(a, b)] -> b -> [a] + +-- Be permissive and ignore unknown bit values. At least on OS X, +-- getaddrinfo returns an ai_flags field with bits set that have no +-- entry in . +unpackBits [] _ = [] +unpackBits ((k,v):xs) r + | r .&. v /= 0 = k : unpackBits xs (r .&. complement v) + | otherwise = unpackBits xs r + +----------------------------------------------------------------------------- +-- Address and service lookups + +#if defined(IPV6_SOCKET_SUPPORT) + +-- | Flags that control the querying behaviour of 'getAddrInfo'. +data AddrInfoFlag + = AI_ADDRCONFIG + | AI_ALL + | AI_CANONNAME + | AI_NUMERICHOST + | AI_NUMERICSERV + | AI_PASSIVE + | AI_V4MAPPED + deriving (Eq, Read, Show, Typeable) + +aiFlagMapping :: [(AddrInfoFlag, CInt)] + +aiFlagMapping = + [ +#if HAVE_DECL_AI_ADDRCONFIG + (AI_ADDRCONFIG, #const AI_ADDRCONFIG), +#else + (AI_ADDRCONFIG, 0), +#endif +#if HAVE_DECL_AI_ALL + (AI_ALL, #const AI_ALL), +#else + (AI_ALL, 0), +#endif + (AI_CANONNAME, #const AI_CANONNAME), + (AI_NUMERICHOST, #const AI_NUMERICHOST), +#if HAVE_DECL_AI_NUMERICSERV + (AI_NUMERICSERV, #const AI_NUMERICSERV), +#else + (AI_NUMERICSERV, 0), +#endif + (AI_PASSIVE, #const AI_PASSIVE), +#if HAVE_DECL_AI_V4MAPPED + (AI_V4MAPPED, #const AI_V4MAPPED) +#else + (AI_V4MAPPED, 0) +#endif + ] + +-- | Indicate whether the given 'AddrInfoFlag' will have any effect on +-- this system. +addrInfoFlagImplemented :: AddrInfoFlag -> Bool +addrInfoFlagImplemented f = packBits aiFlagMapping [f] /= 0 + +data AddrInfo = + AddrInfo { + addrFlags :: [AddrInfoFlag], + addrFamily :: Family, + addrSocketType :: SocketType, + addrProtocol :: ProtocolNumber, + addrAddress :: SockAddr, + addrCanonName :: Maybe String + } + deriving (Eq, Show, Typeable) + +instance Storable AddrInfo where + sizeOf _ = #const sizeof(struct addrinfo) + alignment _ = alignment (undefined :: CInt) + + peek p = do + ai_flags <- (#peek struct addrinfo, ai_flags) p + ai_family <- (#peek struct addrinfo, ai_family) p + ai_socktype <- (#peek struct addrinfo, ai_socktype) p + ai_protocol <- (#peek struct addrinfo, ai_protocol) p + ai_addr <- (#peek struct addrinfo, ai_addr) p >>= peekSockAddr + ai_canonname_ptr <- (#peek struct addrinfo, ai_canonname) p + + ai_canonname <- if ai_canonname_ptr == nullPtr + then return Nothing + else liftM Just $ peekCString ai_canonname_ptr + + return (AddrInfo + { + addrFlags = unpackBits aiFlagMapping ai_flags, + addrFamily = unpackFamily ai_family, + addrSocketType = unpackSocketType ai_socktype, + addrProtocol = ai_protocol, + addrAddress = ai_addr, + addrCanonName = ai_canonname + }) + + poke p (AddrInfo flags family socketType protocol _ _) = do + (#poke struct addrinfo, ai_flags) p (packBits aiFlagMapping flags) + (#poke struct addrinfo, ai_family) p (packFamily family) + (#poke struct addrinfo, ai_socktype) p (packSocketType socketType) + (#poke struct addrinfo, ai_protocol) p protocol + + -- stuff below is probably not needed, but let's zero it for safety + + (#poke struct addrinfo, ai_addrlen) p (0::CSize) + (#poke struct addrinfo, ai_addr) p nullPtr + (#poke struct addrinfo, ai_canonname) p nullPtr + (#poke struct addrinfo, ai_next) p nullPtr + +data NameInfoFlag + = NI_DGRAM + | NI_NAMEREQD + | NI_NOFQDN + | NI_NUMERICHOST + | NI_NUMERICSERV + deriving (Eq, Read, Show, Typeable) + +niFlagMapping :: [(NameInfoFlag, CInt)] + +niFlagMapping = [(NI_DGRAM, #const NI_DGRAM), + (NI_NAMEREQD, #const NI_NAMEREQD), + (NI_NOFQDN, #const NI_NOFQDN), + (NI_NUMERICHOST, #const NI_NUMERICHOST), + (NI_NUMERICSERV, #const NI_NUMERICSERV)] + +-- | Default hints for address lookup with 'getAddrInfo'. The values +-- of the 'addrAddress' and 'addrCanonName' fields are 'undefined', +-- and are never inspected by 'getAddrInfo'. + +defaultHints :: AddrInfo + +defaultHints = AddrInfo { + addrFlags = [], + addrFamily = AF_UNSPEC, + addrSocketType = NoSocketType, + addrProtocol = defaultProtocol, + addrAddress = undefined, + addrCanonName = undefined + } + +-- | Resolve a host or service name to one or more addresses. +-- The 'AddrInfo' values that this function returns contain 'SockAddr' +-- values that you can pass directly to 'connect' or +-- 'bindSocket'. +-- +-- This function is protocol independent. It can return both IPv4 and +-- IPv6 address information. +-- +-- The 'AddrInfo' argument specifies the preferred query behaviour, +-- socket options, or protocol. You can override these conveniently +-- using Haskell's record update syntax on 'defaultHints', for example +-- as follows: +-- +-- @ +-- myHints = defaultHints { addrFlags = [AI_ADDRCONFIG, AI_CANONNAME] } +-- @ +-- +-- Values for 'addrFlags' control query behaviour. The supported +-- flags are as follows: +-- +-- [@AI_PASSIVE@] If no 'HostName' value is provided, the network +-- address in each 'SockAddr' +-- will be left as a "wild card", i.e. as either 'iNADDR_ANY' +-- or 'iN6ADDR_ANY'. This is useful for server applications that +-- will accept connections from any client. +-- +-- [@AI_CANONNAME@] The 'addrCanonName' field of the first returned +-- 'AddrInfo' will contain the "canonical name" of the host. +-- +-- [@AI_NUMERICHOST@] The 'HostName' argument /must/ be a numeric +-- address in string form, and network name lookups will not be +-- attempted. +-- +-- /Note/: Although the following flags are required by RFC 3493, they +-- may not have an effect on all platforms, because the underlying +-- network stack may not support them. To see whether a flag from the +-- list below will have any effect, call 'addrInfoFlagImplemented'. +-- +-- [@AI_NUMERICSERV@] The 'ServiceName' argument /must/ be a port +-- number in string form, and service name lookups will not be +-- attempted. +-- +-- [@AI_ADDRCONFIG@] The list of returned 'AddrInfo' values will +-- only contain IPv4 addresses if the local system has at least +-- one IPv4 interface configured, and likewise for IPv6. +-- +-- [@AI_V4MAPPED@] If an IPv6 lookup is performed, and no IPv6 +-- addresses are found, IPv6-mapped IPv4 addresses will be +-- returned. +-- +-- [@AI_ALL@] If 'AI_ALL' is specified, return all matching IPv6 and +-- IPv4 addresses. Otherwise, this flag has no effect. +-- +-- You must provide a 'Just' value for at least one of the 'HostName' +-- or 'ServiceName' arguments. 'HostName' can be either a numeric +-- network address (dotted quad for IPv4, colon-separated hex for +-- IPv6) or a hostname. In the latter case, its addresses will be +-- looked up unless 'AI_NUMERICHOST' is specified as a hint. If you +-- do not provide a 'HostName' value /and/ do not set 'AI_PASSIVE' as +-- a hint, network addresses in the result will contain the address of +-- the loopback interface. +-- +-- If the query fails, this function throws an IO exception instead of +-- returning an empty list. Otherwise, it returns a non-empty list +-- of 'AddrInfo' values. +-- +-- There are several reasons why a query might result in several +-- values. For example, the queried-for host could be multihomed, or +-- the service might be available via several protocols. +-- +-- Note: the order of arguments is slightly different to that defined +-- for @getaddrinfo@ in RFC 2553. The 'AddrInfo' parameter comes first +-- to make partial application easier. +-- +-- Example: +-- @ +-- let hints = defaultHints { addrFlags = [AI_ADDRCONFIG, AI_CANONNAME] } +-- addrs <- getAddrInfo (Just hints) (Just "www.haskell.org") (Just "http") +-- let addr = head addrs +-- sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) +-- connect sock (addrAddress addr) +-- @ + +getAddrInfo :: Maybe AddrInfo -- ^ preferred socket type or protocol + -> Maybe HostName -- ^ host name to look up + -> Maybe ServiceName -- ^ service name to look up + -> IO [AddrInfo] -- ^ resolved addresses, with "best" first + +getAddrInfo hints node service = + maybeWith withCString node $ \c_node -> + maybeWith withCString service $ \c_service -> + maybeWith with hints $ \c_hints -> + alloca $ \ptr_ptr_addrs -> do + ret <- c_getaddrinfo c_node c_service c_hints ptr_ptr_addrs + case ret of + 0 -> do ptr_addrs <- peek ptr_ptr_addrs + ais <- followAddrInfo ptr_addrs + c_freeaddrinfo ptr_addrs + return ais + _ -> do err <- gai_strerror ret + ioError (ioeSetErrorString + (mkIOError NoSuchThing "getAddrInfo" Nothing + Nothing) err) + +followAddrInfo :: Ptr AddrInfo -> IO [AddrInfo] + +followAddrInfo ptr_ai | ptr_ai == nullPtr = return [] + | otherwise = do + a <- peek ptr_ai + as <- (#peek struct addrinfo, ai_next) ptr_ai >>= followAddrInfo + return (a:as) + +foreign import ccall safe "hsnet_getaddrinfo" + c_getaddrinfo :: CString -> CString -> Ptr AddrInfo -> Ptr (Ptr AddrInfo) + -> IO CInt + +foreign import ccall safe "hsnet_freeaddrinfo" + c_freeaddrinfo :: Ptr AddrInfo -> IO () + +gai_strerror :: CInt -> IO String + +#ifdef HAVE_GAI_STRERROR +gai_strerror n = c_gai_strerror n >>= peekCString + +foreign import ccall safe "gai_strerror" + c_gai_strerror :: CInt -> IO CString +#else +gai_strerror n = return ("error " ++ show n) +#endif + +withCStringIf :: Bool -> Int -> (CSize -> CString -> IO a) -> IO a +withCStringIf False _ f = f 0 nullPtr +withCStringIf True n f = allocaBytes n (f (fromIntegral n)) + +-- | Resolve an address to a host or service name. +-- This function is protocol independent. +-- +-- The list of 'NameInfoFlag' values controls query behaviour. The +-- supported flags are as follows: +-- +-- [@NI_NOFQDN@] If a host is local, return only the +-- hostname part of the FQDN. +-- +-- [@NI_NUMERICHOST@] The name of the host is not +-- looked up. Instead, a numeric representation of the host's +-- address is returned. For an IPv4 address, this will be a +-- dotted-quad string. For IPv6, it will be colon-separated +-- hexadecimal. +-- +-- [@NI_NUMERICSERV@] The name of the service is not +-- looked up. Instead, a numeric representation of the +-- service is returned. +-- +-- [@NI_NAMEREQD@] If the hostname cannot be looked up, an IO error +-- is thrown. +-- +-- [@NI_DGRAM@] Resolve a datagram-based service name. This is +-- required only for the few protocols that have different port +-- numbers for their datagram-based versions than for their +-- stream-based versions. +-- +-- Hostname and service name lookups can be expensive. You can +-- specify which lookups to perform via the two 'Bool' arguments. If +-- one of these is 'False', the corresponding value in the returned +-- tuple will be 'Nothing', and no lookup will be performed. +-- +-- If a host or service's name cannot be looked up, then the numeric +-- form of the address or service will be returned. +-- +-- If the query fails, this function throws an IO exception. +-- +-- Example: +-- @ +-- (hostName, _) <- getNameInfo [] True False myAddress +-- @ + +getNameInfo :: [NameInfoFlag] -- ^ flags to control lookup behaviour + -> Bool -- ^ whether to look up a hostname + -> Bool -- ^ whether to look up a service name + -> SockAddr -- ^ the address to look up + -> IO (Maybe HostName, Maybe ServiceName) + +getNameInfo flags doHost doService addr = + withCStringIf doHost (#const NI_MAXHOST) $ \c_hostlen c_host -> + withCStringIf doService (#const NI_MAXSERV) $ \c_servlen c_serv -> do + withSockAddr addr $ \ptr_addr sz -> do + ret <- c_getnameinfo ptr_addr (fromIntegral sz) c_host c_hostlen + c_serv c_servlen (packBits niFlagMapping flags) + case ret of + 0 -> do + let peekIf doIf c_val = if doIf + then liftM Just $ peekCString c_val + else return Nothing + host <- peekIf doHost c_host + serv <- peekIf doService c_serv + return (host, serv) + _ -> do err <- gai_strerror ret + ioError (ioeSetErrorString + (mkIOError NoSuchThing "getNameInfo" Nothing + Nothing) err) + +foreign import ccall safe "hsnet_getnameinfo" + c_getnameinfo :: Ptr SockAddr -> CInt{-CSockLen???-} -> CString -> CSize -> CString + -> CSize -> CInt -> IO CInt +#endif + +mkInvalidRecvArgError :: String -> IOError +mkInvalidRecvArgError loc = ioeSetErrorString (mkIOError +#ifdef __GLASGOW_HASKELL__ + InvalidArgument +#else + IllegalOperation +#endif + loc Nothing Nothing) "non-positive length" + +mkEOFError :: String -> IOError +mkEOFError loc = ioeSetErrorString (mkIOError EOF loc Nothing Nothing) "end of file" + +-- --------------------------------------------------------------------------- +-- foreign imports from the C library + +foreign import ccall unsafe "my_inet_ntoa" + c_inet_ntoa :: HostAddress -> IO (Ptr CChar) + +foreign import CALLCONV unsafe "inet_addr" + c_inet_addr :: Ptr CChar -> IO HostAddress + +foreign import CALLCONV unsafe "shutdown" + c_shutdown :: CInt -> CInt -> IO CInt + +close :: CInt -> IO () +close fd = throwErrnoIfMinus1Retry_ "Network.Socket.close" $ c_close fd + +#if !defined(WITH_WINSOCK) +foreign import ccall unsafe "close" + c_close :: CInt -> IO CInt +#else +foreign import stdcall unsafe "closesocket" + c_close :: CInt -> IO CInt +#endif + +foreign import CALLCONV unsafe "socket" + c_socket :: CInt -> CInt -> CInt -> IO CInt +foreign import CALLCONV unsafe "bind" + c_bind :: CInt -> Ptr SockAddr -> CInt{-CSockLen???-} -> IO CInt +foreign import CALLCONV unsafe "connect" + c_connect :: CInt -> Ptr SockAddr -> CInt{-CSockLen???-} -> IO CInt +foreign import CALLCONV unsafe "accept" + c_accept :: CInt -> Ptr SockAddr -> Ptr CInt{-CSockLen???-} -> IO CInt +foreign import CALLCONV unsafe "listen" + c_listen :: CInt -> CInt -> IO CInt + +#if defined(mingw32_HOST_OS) && defined(__GLASGOW_HASKELL__) +foreign import CALLCONV safe "accept" + c_accept_safe :: CInt -> Ptr SockAddr -> Ptr CInt{-CSockLen???-} -> IO CInt + +foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool +#endif + +foreign import CALLCONV unsafe "send" + c_send :: CInt -> Ptr a -> CSize -> CInt -> IO CInt +foreign import CALLCONV SAFE_ON_WIN "sendto" + c_sendto :: CInt -> Ptr a -> CSize -> CInt -> Ptr SockAddr -> CInt -> IO CInt +foreign import CALLCONV unsafe "recv" + c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt +foreign import CALLCONV SAFE_ON_WIN "recvfrom" + c_recvfrom :: CInt -> Ptr a -> CSize -> CInt -> Ptr SockAddr -> Ptr CInt -> IO CInt +foreign import CALLCONV unsafe "getpeername" + c_getpeername :: CInt -> Ptr SockAddr -> Ptr CInt -> IO CInt +foreign import CALLCONV unsafe "getsockname" + c_getsockname :: CInt -> Ptr SockAddr -> Ptr CInt -> IO CInt + +foreign import CALLCONV unsafe "getsockopt" + c_getsockopt :: CInt -> CInt -> CInt -> Ptr CInt -> Ptr CInt -> IO CInt +foreign import CALLCONV unsafe "setsockopt" + c_setsockopt :: CInt -> CInt -> CInt -> Ptr CInt -> CInt -> IO CInt diff --git a/Network/Socket/ByteString.hsc b/Network/Socket/ByteString.hsc new file mode 100644 --- /dev/null +++ b/Network/Socket/ByteString.hsc @@ -0,0 +1,383 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} + +#include "HsNet.h" + +-- | +-- Module : Network.Socket.ByteString +-- Copyright : (c) Johan Tibell 2007-2010 +-- License : BSD-style +-- +-- Maintainer : johan.tibell@gmail.com +-- Stability : stable +-- Portability : portable +-- +-- This module provides access to the BSD /socket/ interface. This +-- module is generally more efficient than the 'String' based network +-- functions in 'Network.Socket'. For detailed documentation, consult +-- your favorite POSIX socket reference. All functions communicate +-- failures by converting the error number to 'System.IO.IOError'. +-- +-- This module is made to be imported with 'Network.Socket' like so: +-- +-- > import Network.Socket hiding (send, sendTo, recv, recvFrom) +-- > import Network.Socket.ByteString +-- +module Network.Socket.ByteString + ( + -- * Send data to a socket + send + , sendAll + , sendTo + , sendAllTo + + -- ** Vectored I/O + -- $vectored + , sendMany + , sendManyTo + + -- * Receive data from a socket + , recv + , recvFrom + + -- * Example + -- $example + ) where + +import Control.Monad (liftM, when) +import Data.ByteString (ByteString) +import Data.ByteString.Internal (createAndTrim) +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import Data.Word (Word8) +#if __GLASGOW_HASKELL__ >= 703 +import Foreign.C.Types (CInt(..)) +#else +import Foreign.C.Types (CInt) +#endif +import Foreign.Marshal.Alloc (allocaBytes) +import Foreign.Ptr (Ptr, castPtr) +import Network.Socket (SockAddr, Socket(..), sendBufTo, recvBufFrom) + +import qualified Data.ByteString as B + +import Network.Socket.ByteString.Internal + +#if !defined(mingw32_HOST_OS) +import Control.Monad (zipWithM_) +import Foreign.C.Types (CChar) +# if __GLASGOW_HASKELL__ >= 703 +import Foreign.C.Types (CSize(..)) +# else +import Foreign.C.Types (CSize) +# endif +import Foreign.Marshal.Array (allocaArray) +import Foreign.Marshal.Utils (with) +import Foreign.Ptr (plusPtr) +import Foreign.Storable (Storable(..)) +import Network.Socket.Internal (throwSocketErrorIfMinus1RetryMayBlock, + withSockAddr) + +import Network.Socket.ByteString.IOVec (IOVec(..)) +import Network.Socket.ByteString.MsgHdr (MsgHdr(..)) + +# if defined(__GLASGOW_HASKELL__) +import GHC.Conc (threadWaitRead, threadWaitWrite) +# endif +#else +# if defined(__GLASGOW_HASKELL__) +# if __GLASGOW_HASKELL__ >= 611 +import GHC.IO.FD +# else +import GHC.Handle (readRawBufferPtr, writeRawBufferPtr) +# endif +# endif +#endif + +#if !defined(mingw32_HOST_OS) +foreign import CALLCONV unsafe "send" + c_send :: CInt -> Ptr a -> CSize -> CInt -> IO CInt +foreign import CALLCONV unsafe "recv" + c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt +#endif + +-- ---------------------------------------------------------------------------- +-- Sending + +-- | Send data to the socket. The socket must be connected to a +-- remote socket. Returns the number of bytes sent. Applications are +-- responsible for ensuring that all data has been sent. +send :: Socket -- ^ Connected socket + -> ByteString -- ^ Data to send + -> IO Int -- ^ Number of bytes sent +send (MkSocket s _ _ _ _) xs = + unsafeUseAsCStringLen xs $ \(str, len) -> + liftM fromIntegral $ +#if defined(__GLASGOW_HASKELL__) && defined(mingw32_HOST_OS) +# if __GLASGOW_HASKELL__ >= 611 + writeRawBufferPtr "Network.Socket.ByteString.send" + (FD s 1) (castPtr str) 0 (fromIntegral len) +# else + writeRawBufferPtr "Network.Socket.ByteString.send" + (fromIntegral s) True str 0 (fromIntegral len) +# endif +#else +# if !defined(__HUGS__) + throwSocketErrorIfMinus1RetryMayBlock "send" + (threadWaitWrite (fromIntegral s)) $ +# endif + c_send s str (fromIntegral len) 0 +#endif + +-- | Send data to the socket. The socket must be connected to a +-- remote socket. Unlike 'send', this function continues to send data +-- until either all data has been sent or an error occurs. On error, +-- an exception is raised, and there is no way to determine how much +-- data, if any, was successfully sent. +sendAll :: Socket -- ^ Connected socket + -> ByteString -- ^ Data to send + -> IO () +sendAll sock bs = do + sent <- send sock bs + when (sent < B.length bs) $ sendAll sock (B.drop sent bs) + +-- | Send data to the socket. The recipient can be specified +-- explicitly, so the socket need not be in a connected state. +-- Returns the number of bytes sent. Applications are responsible for +-- ensuring that all data has been sent. +sendTo :: Socket -- ^ Socket + -> ByteString -- ^ Data to send + -> SockAddr -- ^ Recipient address + -> IO Int -- ^ Number of bytes sent +sendTo sock xs addr = + unsafeUseAsCStringLen xs $ \(str, len) -> sendBufTo sock str len addr + +-- | Send data to the socket. The recipient can be specified +-- explicitly, so the socket need not be in a connected state. Unlike +-- 'sendTo', this function continues to send data until either all +-- data has been sent or an error occurs. On error, an exception is +-- raised, and there is no way to determine how much data, if any, was +-- successfully sent. +sendAllTo :: Socket -- ^ Socket + -> ByteString -- ^ Data to send + -> SockAddr -- ^ Recipient address + -> IO () +sendAllTo sock xs addr = do + sent <- sendTo sock xs addr + when (sent < B.length xs) $ sendAllTo sock (B.drop sent xs) addr + +-- ---------------------------------------------------------------------------- +-- ** Vectored I/O + +-- $vectored +-- +-- Vectored I\/O, also known as scatter\/gather I\/O, allows multiple +-- data segments to be sent using a single system call, without first +-- concatenating the segments. For example, given a list of +-- @ByteString@s, @xs@, +-- +-- > sendMany sock xs +-- +-- is equivalent to +-- +-- > sendAll sock (concat xs) +-- +-- but potentially more efficient. +-- +-- Vectored I\/O are often useful when implementing network protocols +-- that, for example, group data into segments consisting of one or +-- more fixed-length headers followed by a variable-length body. + +-- | Send data to the socket. The socket must be in a connected +-- state. The data is sent as if the parts have been concatenated. +-- This function continues to send data until either all data has been +-- sent or an error occurs. On error, an exception is raised, and +-- there is no way to determine how much data, if any, was +-- successfully sent. +sendMany :: Socket -- ^ Connected socket + -> [ByteString] -- ^ Data to send + -> IO () +#if !defined(mingw32_HOST_OS) +sendMany sock@(MkSocket fd _ _ _ _) cs = do + sent <- sendManyInner + when (sent < totalLength cs) $ sendMany sock (remainingChunks sent cs) + where + sendManyInner = + liftM fromIntegral . withIOVec cs $ \(iovsPtr, iovsLen) -> + throwSocketErrorIfMinus1RetryMayBlock "writev" + (threadWaitWrite (fromIntegral fd)) $ + c_writev (fromIntegral fd) iovsPtr (fromIntegral iovsLen) +#else +sendMany sock = sendAll sock . B.concat +#endif + +-- | Send data to the socket. The recipient can be specified +-- explicitly, so the socket need not be in a connected state. The +-- data is sent as if the parts have been concatenated. This function +-- continues to send data until either all data has been sent or an +-- error occurs. On error, an exception is raised, and there is no +-- way to determine how much data, if any, was successfully sent. +sendManyTo :: Socket -- ^ Socket + -> [ByteString] -- ^ Data to send + -> SockAddr -- ^ Recipient address + -> IO () +#if !defined(mingw32_HOST_OS) +sendManyTo sock@(MkSocket fd _ _ _ _) cs addr = do + sent <- liftM fromIntegral sendManyToInner + when (sent < totalLength cs) $ sendManyTo sock (remainingChunks sent cs) addr + where + sendManyToInner = + withSockAddr addr $ \addrPtr addrSize -> + withIOVec cs $ \(iovsPtr, iovsLen) -> do + let msgHdr = MsgHdr + addrPtr (fromIntegral addrSize) + iovsPtr (fromIntegral iovsLen) + with msgHdr $ \msgHdrPtr -> + throwSocketErrorIfMinus1RetryMayBlock "sendmsg" + (threadWaitWrite (fromIntegral fd)) $ + c_sendmsg (fromIntegral fd) msgHdrPtr 0 +#else +sendManyTo sock cs = sendAllTo sock (B.concat cs) +#endif + +-- ---------------------------------------------------------------------------- +-- Receiving + +-- | Receive data from the socket. The socket must be in a connected +-- state. This function may return fewer bytes than specified. If +-- the message is longer than the specified length, it may be +-- discarded depending on the type of socket. This function may block +-- until a message arrives. +-- +-- Considering hardware and network realities, the maximum number of bytes to +-- receive should be a small power of 2, e.g., 4096. +-- +-- For TCP sockets, a zero length return value means the peer has +-- closed its half side of the connection. +recv :: Socket -- ^ Connected socket + -> Int -- ^ Maximum number of bytes to receive + -> IO ByteString -- ^ Data received +recv (MkSocket s _ _ _ _) nbytes + | nbytes < 0 = ioError (mkInvalidRecvArgError "Network.Socket.ByteString.recv") + | otherwise = createAndTrim nbytes $ recvInner s nbytes + +recvInner :: CInt -> Int -> Ptr Word8 -> IO Int +recvInner s nbytes ptr = + fmap fromIntegral $ +#if defined(__GLASGOW_HASKELL__) && defined(mingw32_HOST_OS) +# if __GLASGOW_HASKELL__ >= 611 + readRawBufferPtr "Network.Socket.ByteString.recv" (FD s 1) ptr 0 (fromIntegral nbytes) +# else + readRawBufferPtr "Network.Socket.ByteString.recv" (fromIntegral s) + True (castPtr ptr) 0 (fromIntegral nbytes) +# endif +#else +# if !defined(__HUGS__) + throwSocketErrorIfMinus1RetryMayBlock "recv" + (threadWaitRead (fromIntegral s)) $ +# endif + c_recv s (castPtr ptr) (fromIntegral nbytes) 0 +#endif + +-- | Receive data from the socket. The socket need not be in a +-- connected state. Returns @(bytes, address)@ where @bytes@ is a +-- 'ByteString' representing the data received and @address@ is a +-- 'SockAddr' representing the address of the sending socket. +recvFrom :: Socket -- ^ Socket + -> Int -- ^ Maximum number of bytes to receive + -> IO (ByteString, SockAddr) -- ^ Data received and sender address +recvFrom sock nbytes = + allocaBytes nbytes $ \ptr -> do + (len, sockaddr) <- recvBufFrom sock ptr nbytes + str <- B.packCStringLen (ptr, len) + return (str, sockaddr) + +-- ---------------------------------------------------------------------------- +-- Not exported + +#if !defined(mingw32_HOST_OS) +-- | Suppose we try to transmit a list of chunks @cs@ via a gathering write +-- operation and find that @n@ bytes were sent. Then @remainingChunks n cs@ is +-- list of chunks remaining to be sent. +remainingChunks :: Int -> [ByteString] -> [ByteString] +remainingChunks _ [] = [] +remainingChunks i (x:xs) + | i < len = B.drop i x : xs + | otherwise = let i' = i - len in i' `seq` remainingChunks i' xs + where + len = B.length x + +-- | @totalLength cs@ is the sum of the lengths of the chunks in the list @cs@. +totalLength :: [ByteString] -> Int +totalLength = sum . map B.length + +-- | @withIOVec cs f@ executes the computation @f@, passing as argument a pair +-- consisting of a pointer to a temporarily allocated array of pointers to +-- 'IOVec' made from @cs@ and the number of pointers (@length cs@). +-- /Unix only/. +withIOVec :: [ByteString] -> ((Ptr IOVec, Int) -> IO a) -> IO a +withIOVec cs f = + allocaArray csLen $ \aPtr -> do + zipWithM_ pokeIov (ptrs aPtr) cs + f (aPtr, csLen) + where + csLen = length cs + ptrs = iterate (`plusPtr` sizeOf (undefined :: IOVec)) + pokeIov ptr s = + unsafeUseAsCStringLen s $ \(sPtr, sLen) -> + poke ptr $ IOVec sPtr (fromIntegral sLen) +#endif + +-- --------------------------------------------------------------------- +-- Example + +-- $example +-- +-- Here are two minimal example programs using the TCP/IP protocol: a +-- server that echoes all data that it receives back (servicing only +-- one client) and a client using it. +-- +-- > -- Echo server program +-- > module Main where +-- > +-- > import Control.Monad (unless) +-- > import Network.Socket hiding (recv) +-- > import qualified Data.ByteString as S +-- > import Network.Socket.ByteString (recv, sendAll) +-- > +-- > main :: IO () +-- > main = withSocketsDo $ +-- > do addrinfos <- getAddrInfo +-- > (Just (defaultHints {addrFlags = [AI_PASSIVE]})) +-- > Nothing (Just "3000") +-- > let serveraddr = head addrinfos +-- > sock <- socket (addrFamily serveraddr) Stream defaultProtocol +-- > bindSocket sock (addrAddress serveraddr) +-- > listen sock 1 +-- > (conn, _) <- accept sock +-- > talk conn +-- > sClose conn +-- > sClose sock +-- > +-- > where +-- > talk :: Socket -> IO () +-- > talk conn = +-- > do msg <- recv conn 1024 +-- > unless (S.null msg) $ sendAll conn msg >> talk conn +-- +-- > -- Echo client program +-- > module Main where +-- > +-- > import Network.Socket hiding (recv) +-- > import Network.Socket.ByteString (recv, sendAll) +-- > import qualified Data.ByteString.Char8 as C +-- > +-- > main :: IO () +-- > main = withSocketsDo $ +-- > do addrinfos <- getAddrInfo Nothing (Just "") (Just "3000") +-- > let serveraddr = head addrinfos +-- > sock <- socket (addrFamily serveraddr) Stream defaultProtocol +-- > connect sock (addrAddress serveraddr) +-- > sendAll sock $ C.pack "Hello, world!" +-- > msg <- recv sock 1024 +-- > sClose sock +-- > putStr "Received " +-- > C.putStrLn msg diff --git a/Network/Socket/ByteString/IOVec.hsc b/Network/Socket/ByteString/IOVec.hsc new file mode 100644 --- /dev/null +++ b/Network/Socket/ByteString/IOVec.hsc @@ -0,0 +1,28 @@ +-- | Support module for the POSIX writev system call. +module Network.Socket.ByteString.IOVec + ( IOVec(..) + ) where + +import Foreign.C.Types (CChar, CInt, CSize) +import Foreign.Ptr (Ptr) +import Foreign.Storable (Storable(..)) + +#include + +data IOVec = IOVec + { iovBase :: Ptr CChar + , iovLen :: CSize + } + +instance Storable IOVec where + sizeOf _ = (#const sizeof(struct iovec)) + alignment _ = alignment (undefined :: CInt) + + peek p = do + base <- (#peek struct iovec, iov_base) p + len <- (#peek struct iovec, iov_len) p + return $ IOVec base len + + poke p iov = do + (#poke struct iovec, iov_base) p (iovBase iov) + (#poke struct iovec, iov_len) p (iovLen iov) diff --git a/Network/Socket/ByteString/Internal.hs b/Network/Socket/ByteString/Internal.hs new file mode 100644 --- /dev/null +++ b/Network/Socket/ByteString/Internal.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} + +-- | +-- Module : Network.Socket.ByteString.Internal +-- Copyright : (c) Johan Tibell 2007-2010 +-- License : BSD-style +-- +-- Maintainer : johan.tibell@gmail.com +-- Stability : stable +-- Portability : portable +-- +module Network.Socket.ByteString.Internal + ( + mkInvalidRecvArgError +#if !defined(mingw32_HOST_OS) + , c_writev + , c_sendmsg +#endif + ) where + +import System.IO.Error (ioeSetErrorString, mkIOError) + +#if !defined(mingw32_HOST_OS) +# if __GLASGOW_HASKELL__ >= 703 +import Foreign.C.Types (CInt(..)) +import System.Posix.Types (CSsize(..)) +# else +import Foreign.C.Types (CInt) +import System.Posix.Types (CSsize) +# endif +import Foreign.Ptr (Ptr) + +import Network.Socket.ByteString.IOVec (IOVec) +import Network.Socket.ByteString.MsgHdr (MsgHdr) +#endif + +#ifdef __GLASGOW_HASKELL__ +# if __GLASGOW_HASKELL__ < 611 +import GHC.IOBase (IOErrorType(..)) +# else +import GHC.IO.Exception (IOErrorType(..)) +# endif +#elif __HUGS__ +import Hugs.Prelude (IOErrorType(..)) +#endif + +mkInvalidRecvArgError :: String -> IOError +mkInvalidRecvArgError loc = ioeSetErrorString (mkIOError +#ifdef __GLASGOW_HASKELL__ + InvalidArgument +#else + IllegalOperation +#endif + loc Nothing Nothing) "non-positive length" + +#if !defined(mingw32_HOST_OS) +foreign import ccall unsafe "writev" + c_writev :: CInt -> Ptr IOVec -> CInt -> IO CSsize + +foreign import ccall unsafe "sendmsg" + c_sendmsg :: CInt -> Ptr MsgHdr -> CInt -> IO CSsize +#endif diff --git a/Network/Socket/ByteString/Lazy.hsc b/Network/Socket/ByteString/Lazy.hsc new file mode 100644 --- /dev/null +++ b/Network/Socket/ByteString/Lazy.hsc @@ -0,0 +1,154 @@ +{-# LANGUAGE BangPatterns, CPP, ForeignFunctionInterface #-} + +-- | +-- Module : Network.Socket.ByteString.Lazy +-- Copyright : (c) Bryan O'Sullivan 2009 +-- License : BSD-style +-- +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : POSIX, GHC +-- +-- This module provides access to the BSD /socket/ interface. This +-- module is generally more efficient than the 'String' based network +-- functions in 'Network.Socket'. For detailed documentation, consult +-- your favorite POSIX socket reference. All functions communicate +-- failures by converting the error number to 'System.IO.IOError'. +-- +-- This module is made to be imported with 'Network.Socket' like so: +-- +-- > import Network.Socket hiding (send, sendTo, recv, recvFrom) +-- > import Network.Socket.ByteString.Lazy +-- > import Prelude hiding (getContents) +-- +module Network.Socket.ByteString.Lazy + ( +#if !defined(mingw32_HOST_OS) + -- * Send data to a socket + send + , sendAll + , +#endif + + -- * Receive data from a socket + getContents + , recv + ) where + +import Control.Monad (liftM) +import Data.ByteString.Lazy.Internal (ByteString(..), defaultChunkSize) +import Data.Int (Int64) +import Network.Socket (Socket(..), ShutdownCmd(..), shutdown) +import Prelude hiding (getContents) +import System.IO.Unsafe (unsafeInterleaveIO) + +import qualified Data.ByteString as S +import qualified Network.Socket.ByteString as N + +#if !defined(mingw32_HOST_OS) +import Control.Monad (unless) +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import Foreign.Marshal.Array (allocaArray) +import Foreign.Ptr (plusPtr) +import Foreign.Storable (Storable(..)) +import Network.Socket.ByteString.IOVec (IOVec(IOVec)) +import Network.Socket.ByteString.Internal (c_writev) +import Network.Socket.Internal (throwSocketErrorIfMinus1RetryMayBlock) + +import qualified Data.ByteString.Lazy as L + +# if defined(__GLASGOW_HASKELL__) +import GHC.Conc (threadWaitWrite) +# endif +#endif + +#if !defined(mingw32_HOST_OS) +-- ----------------------------------------------------------------------------- +-- Sending + +-- | Send data to the socket. The socket must be in a connected state. +-- Returns the number of bytes sent. Applications are responsible for +-- ensuring that all data has been sent. +-- +-- Because a lazily generated 'ByteString' may be arbitrarily long, +-- this function caps the amount it will attempt to send at 4MB. This +-- number is large (so it should not penalize performance on fast +-- networks), but not outrageously so (to avoid demanding lazily +-- computed data unnecessarily early). Before being sent, the lazy +-- 'ByteString' will be converted to a list of strict 'ByteString's +-- with 'L.toChunks'; at most 1024 chunks will be sent. /Unix only/. +send :: Socket -- ^ Connected socket + -> ByteString -- ^ Data to send + -> IO Int64 -- ^ Number of bytes sent +send (MkSocket fd _ _ _ _) s = do + let cs = take maxNumChunks (L.toChunks s) + len = length cs + liftM fromIntegral . allocaArray len $ \ptr -> + withPokes cs ptr $ \niovs -> +# if !defined(__HUGS__) + throwSocketErrorIfMinus1RetryMayBlock "writev" + (threadWaitWrite (fromIntegral fd)) $ +# endif + c_writev (fromIntegral fd) ptr niovs + where + withPokes ss p f = loop ss p 0 0 + where loop (c:cs) q k !niovs + | k < maxNumBytes = + unsafeUseAsCStringLen c $ \(ptr,len) -> do + poke q $ IOVec ptr (fromIntegral len) + loop cs (q `plusPtr` sizeOf (undefined :: IOVec)) + (k + fromIntegral len) (niovs + 1) + | otherwise = f niovs + loop _ _ _ niovs = f niovs + maxNumBytes = 4194304 :: Int -- maximum number of bytes to transmit in one system call + maxNumChunks = 1024 :: Int -- maximum number of chunks to transmit in one system call + +-- | Send data to the socket. The socket must be in a connected +-- state. This function continues to send data until either all data +-- has been sent or an error occurs. If there is an error, an +-- exception is raised, and there is no way to determine how much data +-- was sent. /Unix only/. +sendAll :: Socket -- ^ Connected socket + -> ByteString -- ^ Data to send + -> IO () +sendAll sock bs = do + sent <- send sock bs + let bs' = L.drop sent bs + unless (L.null bs') $ sendAll sock bs' +#endif + +-- ----------------------------------------------------------------------------- +-- Receiving + +-- | Receive data from the socket. The socket must be in a connected +-- state. Data is received on demand, in chunks; each chunk will be +-- sized to reflect the amount of data received by individual 'recv' +-- calls. +-- +-- All remaining data from the socket is consumed. When there is no +-- more data to be received, the receiving side of the socket is shut +-- down. If there is an error and an exception is thrown, the socket +-- is not shut down. +getContents :: Socket -- ^ Connected socket + -> IO ByteString -- ^ Data received +getContents sock = loop where + loop = unsafeInterleaveIO $ do + s <- N.recv sock defaultChunkSize + if S.null s + then shutdown sock ShutdownReceive >> return Empty + else Chunk s `liftM` loop + +-- | Receive data from the socket. The socket must be in a connected +-- state. This function may return fewer bytes than specified. If +-- the received data is longer than the specified length, it may be +-- discarded depending on the type of socket. This function may block +-- until a message arrives. +-- +-- If there is no more data to be received, returns an empty 'ByteString'. +recv :: Socket -- ^ Connected socket + -> Int64 -- ^ Maximum number of bytes to receive + -> IO ByteString -- ^ Data received +recv sock nbytes = chunk `liftM` N.recv sock (fromIntegral nbytes) where + chunk k + | S.null k = Empty + | otherwise = Chunk k Empty diff --git a/Network/Socket/ByteString/MsgHdr.hsc b/Network/Socket/ByteString/MsgHdr.hsc new file mode 100644 --- /dev/null +++ b/Network/Socket/ByteString/MsgHdr.hsc @@ -0,0 +1,47 @@ +{-# LANGUAGE CPP #-} + +-- | Support module for the POSIX 'sendmsg' system call. +module Network.Socket.ByteString.MsgHdr + ( MsgHdr(..) + ) where + +#include +#include + +import Foreign.C.Types (CInt, CSize) +import Foreign.Ptr (Ptr) +import Foreign.Storable (Storable(..)) +import Network.Socket (SockAddr) +import Network.Socket.Internal (zeroMemory) + +import Network.Socket.ByteString.IOVec (IOVec) + +-- We don't use msg_control, msg_controllen, and msg_flags as these +-- don't exist on OpenSolaris. +data MsgHdr = MsgHdr + { msgName :: Ptr SockAddr + , msgNameLen :: CSize + , msgIov :: Ptr IOVec + , msgIovLen :: CSize + } + +instance Storable MsgHdr where + sizeOf _ = (#const sizeof(struct msghdr)) + alignment _ = alignment (undefined :: CInt) + + peek p = do + name <- (#peek struct msghdr, msg_name) p + nameLen <- (#peek struct msghdr, msg_namelen) p + iov <- (#peek struct msghdr, msg_iov) p + iovLen <- (#peek struct msghdr, msg_iovlen) p + return $ MsgHdr name nameLen iov iovLen + + poke p mh = do + -- We need to zero the msg_control, msg_controllen, and msg_flags + -- fields, but they only exist on some platforms (e.g. not on + -- Solaris). Instead of using CPP, we zero the entire struct. + zeroMemory p (#const sizeof(struct msghdr)) + (#poke struct msghdr, msg_name) p (msgName mh) + (#poke struct msghdr, msg_namelen) p (msgNameLen mh) + (#poke struct msghdr, msg_iov) p (msgIov mh) + (#poke struct msghdr, msg_iovlen) p (msgIovLen mh) diff --git a/Network/Socket/Internal.hsc b/Network/Socket/Internal.hsc new file mode 100644 --- /dev/null +++ b/Network/Socket/Internal.hsc @@ -0,0 +1,651 @@ +{-# LANGUAGE CPP, FlexibleInstances, ForeignFunctionInterface #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +----------------------------------------------------------------------------- +-- | +-- Module : Network.Socket.Internal +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/network/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- A module containing semi-public 'Network.Socket' internals. +-- Modules which extend the 'Network.Socket' module will need to use +-- this module while ideally most users will be able to make do with +-- the public interface. +-- +----------------------------------------------------------------------------- + +#include "HsNet.h" + +module Network.Socket.Internal + ( + -- * Socket addresses + HostAddress +#if defined(IPV6_SOCKET_SUPPORT) + , HostAddress6 + , FlowInfo + , ScopeID +#endif + , PortNumber(..) + , SockAddr(..) + + , peekSockAddr + , pokeSockAddr + , sizeOfSockAddr + , sizeOfSockAddrByFamily + , withSockAddr + , withNewSockAddr + + -- * Protocol families + , Family(..) + + -- * Socket error functions +#if defined(HAVE_WINSOCK2_H) && !defined(cygwin32_HOST_OS) + , c_getLastError +#endif + , throwSocketError + + -- * Guards for socket operations that may fail + , throwSocketErrorIfMinus1_ + , throwSocketErrorIfMinus1Retry + , throwSocketErrorIfMinus1RetryMayBlock + + -- * Initialization + , withSocketsDo + + -- * Low-level helpers + , zeroMemory + ) where + +import Data.Bits ( (.|.), shiftL, shiftR ) +import Data.Word ( Word8, Word16, Word32 ) +import Data.Typeable (Typeable) +import Foreign.C.Error (throwErrno, throwErrnoIfMinus1Retry, + throwErrnoIfMinus1RetryMayBlock, throwErrnoIfMinus1_) +import Foreign.C.String ( castCharToCChar, peekCString ) +#if __GLASGOW_HASKELL__ >= 703 +import Foreign.C.Types ( CInt(..), CSize(..) ) +#else +import Foreign.C.Types ( CInt, CSize ) +#endif +import Foreign.Marshal.Alloc ( allocaBytes ) +import Foreign.Marshal.Array ( pokeArray, pokeArray0 ) +import Foreign.Ptr ( Ptr, castPtr, plusPtr ) +import Foreign.Storable ( Storable(..) ) + +#if defined(HAVE_WINSOCK2_H) && !defined(cygwin32_HOST_OS) +import Control.Exception ( finally ) +# if __GLASGOW_HASKELL__ +import GHC.IOBase ( IOErrorType(..) ) +# endif +import Foreign.C.Types ( CChar ) +import System.IO.Error ( ioeSetErrorString, mkIOError ) +#endif + +------------------------------------------------------------------------ + +-- | Network byte order. +type HostAddress = Word32 + +#if defined(IPV6_SOCKET_SUPPORT) +-- | Host byte order. +type HostAddress6 = (Word32, Word32, Word32, Word32) + +-- The peek32 and poke32 functions work around the fact that the RFCs +-- don't require 32-bit-wide address fields to be present. We can +-- only portably rely on an 8-bit field, s6_addr. + +s6_addr_offset :: Int +s6_addr_offset = (#offset struct in6_addr, s6_addr) + +peek32 :: Ptr a -> Int -> IO Word32 +peek32 p i0 = do + let i' = i0 * 4 + peekByte n = peekByteOff p (s6_addr_offset + i' + n) :: IO Word8 + a `sl` i = fromIntegral a `shiftL` i + a0 <- peekByte 0 + a1 <- peekByte 1 + a2 <- peekByte 2 + a3 <- peekByte 3 + return ((a0 `sl` 24) .|. (a1 `sl` 16) .|. (a2 `sl` 8) .|. (a3 `sl` 0)) + +poke32 :: Ptr a -> Int -> Word32 -> IO () +poke32 p i0 a = do + let i' = i0 * 4 + pokeByte n = pokeByteOff p (s6_addr_offset + i' + n) + x `sr` i = fromIntegral (x `shiftR` i) :: Word8 + pokeByte 0 (a `sr` 24) + pokeByte 1 (a `sr` 16) + pokeByte 2 (a `sr` 8) + pokeByte 3 (a `sr` 0) + +instance Storable HostAddress6 where + sizeOf _ = (#const sizeof(struct in6_addr)) + alignment _ = alignment (undefined :: CInt) + + peek p = do + a <- peek32 p 0 + b <- peek32 p 1 + c <- peek32 p 2 + d <- peek32 p 3 + return (a, b, c, d) + + poke p (a, b, c, d) = do + poke32 p 0 a + poke32 p 1 b + poke32 p 2 c + poke32 p 3 d +#endif + +------------------------------------------------------------------------ +-- Port Numbers +-- +-- newtyped to prevent accidental use of sane-looking +-- port numbers that haven't actually been converted to +-- network-byte-order first. +-- + +newtype PortNumber = PortNum Word16 deriving (Eq, Ord, Typeable) + +------------------------------------------------------------------------ +-- Socket addresses + +-- The scheme used for addressing sockets is somewhat quirky. The +-- calls in the BSD socket API that need to know the socket address +-- all operate in terms of struct sockaddr, a `virtual' type of +-- socket address. + +-- The Internet family of sockets are addressed as struct sockaddr_in, +-- so when calling functions that operate on struct sockaddr, we have +-- to type cast the Internet socket address into a struct sockaddr. +-- Instances of the structure for different families might *not* be +-- the same size. Same casting is required of other families of +-- sockets such as Xerox NS. Similarly for Unix domain sockets. + +-- To represent these socket addresses in Haskell-land, we do what BSD +-- didn't do, and use a union/algebraic type for the different +-- families. Currently only Unix domain sockets and the Internet +-- families are supported. + +#if defined(IPV6_SOCKET_SUPPORT) +type FlowInfo = Word32 +type ScopeID = Word32 +#endif + +data SockAddr -- C Names + = SockAddrInet + PortNumber -- sin_port (network byte order) + HostAddress -- sin_addr (ditto) +#if defined(IPV6_SOCKET_SUPPORT) + | SockAddrInet6 + PortNumber -- sin6_port (network byte order) + FlowInfo -- sin6_flowinfo (ditto) + HostAddress6 -- sin6_addr (ditto) + ScopeID -- sin6_scope_id (ditto) +#endif +#if defined(DOMAIN_SOCKET_SUPPORT) + | SockAddrUnix + String -- sun_path +#endif + deriving (Eq, Typeable) + +#if defined(WITH_WINSOCK) || defined(cygwin32_HOST_OS) +type CSaFamily = (#type unsigned short) +#elif defined(darwin_HOST_OS) +type CSaFamily = (#type u_char) +#else +type CSaFamily = (#type sa_family_t) +#endif + +-- | Computes the storage requirements (in bytes) of the given +-- 'SockAddr'. This function differs from 'Foreign.Storable.sizeOf' +-- in that the value of the argument /is/ used. +sizeOfSockAddr :: SockAddr -> Int +#if defined(DOMAIN_SOCKET_SUPPORT) +sizeOfSockAddr (SockAddrUnix path) = + case path of + '\0':_ -> (#const sizeof(sa_family_t)) + length path + _ -> #const sizeof(struct sockaddr_un) +#endif +sizeOfSockAddr (SockAddrInet _ _) = #const sizeof(struct sockaddr_in) +#if defined(IPV6_SOCKET_SUPPORT) +sizeOfSockAddr (SockAddrInet6 _ _ _ _) = #const sizeof(struct sockaddr_in6) +#endif + +-- | Computes the storage requirements (in bytes) required for a +-- 'SockAddr' with the given 'Family'. +sizeOfSockAddrByFamily :: Family -> Int +#if defined(DOMAIN_SOCKET_SUPPORT) +sizeOfSockAddrByFamily AF_UNIX = #const sizeof(struct sockaddr_un) +#endif +#if defined(IPV6_SOCKET_SUPPORT) +sizeOfSockAddrByFamily AF_INET6 = #const sizeof(struct sockaddr_in6) +#endif +sizeOfSockAddrByFamily AF_INET = #const sizeof(struct sockaddr_in) + +-- | Use a 'SockAddr' with a function requiring a pointer to a +-- 'SockAddr' and the length of that 'SockAddr'. +withSockAddr :: SockAddr -> (Ptr SockAddr -> Int -> IO a) -> IO a +withSockAddr addr f = do + let sz = sizeOfSockAddr addr + allocaBytes sz $ \p -> pokeSockAddr p addr >> f (castPtr p) sz + +-- | Create a new 'SockAddr' for use with a function requiring a +-- pointer to a 'SockAddr' and the length of that 'SockAddr'. +withNewSockAddr :: Family -> (Ptr SockAddr -> Int -> IO a) -> IO a +withNewSockAddr family f = do + let sz = sizeOfSockAddrByFamily family + allocaBytes sz $ \ptr -> f ptr sz + +-- We can't write an instance of 'Storable' for 'SockAddr' because +-- @sockaddr@ is a sum type of variable size but +-- 'Foreign.Storable.sizeOf' is required to be constant. + +-- Note that on Darwin, the sockaddr structure must be zeroed before +-- use. + +-- | Write the given 'SockAddr' to the given memory location. +pokeSockAddr :: Ptr a -> SockAddr -> IO () +#if defined(DOMAIN_SOCKET_SUPPORT) +pokeSockAddr p (SockAddrUnix path) = do +#if defined(darwin_TARGET_OS) + zeroMemory p (#const sizeof(struct sockaddr_un)) +#endif +#if defined(HAVE_STRUCT_SOCKADDR_SA_LEN) + (#poke struct sockaddr_un, sun_len) p ((#const sizeof(struct sockaddr_un)) :: Word8) +#endif + (#poke struct sockaddr_un, sun_family) p ((#const AF_UNIX) :: CSaFamily) + let pathC = map castCharToCChar path + poker = case path of ('\0':_) -> pokeArray; _ -> pokeArray0 0 + poker ((#ptr struct sockaddr_un, sun_path) p) pathC +#endif +pokeSockAddr p (SockAddrInet (PortNum port) addr) = do +#if defined(darwin_TARGET_OS) + zeroMemory p (#const sizeof(struct sockaddr_in)) +#endif +#if defined(HAVE_STRUCT_SOCKADDR_SA_LEN) + (#poke struct sockaddr_in, sin_len) p ((#const sizeof(struct sockaddr_in)) :: Word8) +#endif + (#poke struct sockaddr_in, sin_family) p ((#const AF_INET) :: CSaFamily) + (#poke struct sockaddr_in, sin_port) p port + (#poke struct sockaddr_in, sin_addr) p addr +#if defined(IPV6_SOCKET_SUPPORT) +pokeSockAddr p (SockAddrInet6 (PortNum port) flow addr scope) = do +#if defined(darwin_TARGET_OS) + zeroMemory p (#const sizeof(struct sockaddr_in6)) +#endif +#if defined(HAVE_STRUCT_SOCKADDR_SA_LEN) + (#poke struct sockaddr_in6, sin6_len) p ((#const sizeof(struct sockaddr_in6)) :: Word8) +#endif + (#poke struct sockaddr_in6, sin6_family) p ((#const AF_INET6) :: CSaFamily) + (#poke struct sockaddr_in6, sin6_port) p port + (#poke struct sockaddr_in6, sin6_flowinfo) p flow + (#poke struct sockaddr_in6, sin6_addr) p addr + (#poke struct sockaddr_in6, sin6_scope_id) p scope +#endif + +-- | Read a 'SockAddr' from the given memory location. +peekSockAddr :: Ptr SockAddr -> IO SockAddr +peekSockAddr p = do + family <- (#peek struct sockaddr, sa_family) p + case family :: CSaFamily of +#if defined(DOMAIN_SOCKET_SUPPORT) + (#const AF_UNIX) -> do + str <- peekCString ((#ptr struct sockaddr_un, sun_path) p) + return (SockAddrUnix str) +#endif + (#const AF_INET) -> do + addr <- (#peek struct sockaddr_in, sin_addr) p + port <- (#peek struct sockaddr_in, sin_port) p + return (SockAddrInet (PortNum port) addr) +#if defined(IPV6_SOCKET_SUPPORT) + (#const AF_INET6) -> do + port <- (#peek struct sockaddr_in6, sin6_port) p + flow <- (#peek struct sockaddr_in6, sin6_flowinfo) p + addr <- (#peek struct sockaddr_in6, sin6_addr) p + scope <- (#peek struct sockaddr_in6, sin6_scope_id) p + return (SockAddrInet6 (PortNum port) flow addr scope) +#endif + +------------------------------------------------------------------------ +-- Protocol Families. + +-- | This data type might have different constructors depending on +-- what is supported by the operating system. +data Family + = AF_UNSPEC -- unspecified +#ifdef AF_UNIX + | AF_UNIX -- local to host (pipes, portals +#endif +#ifdef AF_INET + | AF_INET -- internetwork: UDP, TCP, etc +#endif +#ifdef AF_INET6 + | AF_INET6 -- Internet Protocol version 6 +#endif +#ifdef AF_IMPLINK + | AF_IMPLINK -- arpanet imp addresses +#endif +#ifdef AF_PUP + | AF_PUP -- pup protocols: e.g. BSP +#endif +#ifdef AF_CHAOS + | AF_CHAOS -- mit CHAOS protocols +#endif +#ifdef AF_NS + | AF_NS -- XEROX NS protocols +#endif +#ifdef AF_NBS + | AF_NBS -- nbs protocols +#endif +#ifdef AF_ECMA + | AF_ECMA -- european computer manufacturers +#endif +#ifdef AF_DATAKIT + | AF_DATAKIT -- datakit protocols +#endif +#ifdef AF_CCITT + | AF_CCITT -- CCITT protocols, X.25 etc +#endif +#ifdef AF_SNA + | AF_SNA -- IBM SNA +#endif +#ifdef AF_DECnet + | AF_DECnet -- DECnet +#endif +#ifdef AF_DLI + | AF_DLI -- Direct data link interface +#endif +#ifdef AF_LAT + | AF_LAT -- LAT +#endif +#ifdef AF_HYLINK + | AF_HYLINK -- NSC Hyperchannel +#endif +#ifdef AF_APPLETALK + | AF_APPLETALK -- Apple Talk +#endif +#ifdef AF_ROUTE + | AF_ROUTE -- Internal Routing Protocol +#endif +#ifdef AF_NETBIOS + | AF_NETBIOS -- NetBios-style addresses +#endif +#ifdef AF_NIT + | AF_NIT -- Network Interface Tap +#endif +#ifdef AF_802 + | AF_802 -- IEEE 802.2, also ISO 8802 +#endif +#ifdef AF_ISO + | AF_ISO -- ISO protocols +#endif +#ifdef AF_OSI + | AF_OSI -- umbrella of all families used by OSI +#endif +#ifdef AF_NETMAN + | AF_NETMAN -- DNA Network Management +#endif +#ifdef AF_X25 + | AF_X25 -- CCITT X.25 +#endif +#ifdef AF_AX25 + | AF_AX25 +#endif +#ifdef AF_OSINET + | AF_OSINET -- AFI +#endif +#ifdef AF_GOSSIP + | AF_GOSSIP -- US Government OSI +#endif +#ifdef AF_IPX + | AF_IPX -- Novell Internet Protocol +#endif +#ifdef Pseudo_AF_XTP + | Pseudo_AF_XTP -- eXpress Transfer Protocol (no AF) +#endif +#ifdef AF_CTF + | AF_CTF -- Common Trace Facility +#endif +#ifdef AF_WAN + | AF_WAN -- Wide Area Network protocols +#endif +#ifdef AF_SDL + | AF_SDL -- SGI Data Link for DLPI +#endif +#ifdef AF_NETWARE + | AF_NETWARE +#endif +#ifdef AF_NDD + | AF_NDD +#endif +#ifdef AF_INTF + | AF_INTF -- Debugging use only +#endif +#ifdef AF_COIP + | AF_COIP -- connection-oriented IP, aka ST II +#endif +#ifdef AF_CNT + | AF_CNT -- Computer Network Technology +#endif +#ifdef Pseudo_AF_RTIP + | Pseudo_AF_RTIP -- Help Identify RTIP packets +#endif +#ifdef Pseudo_AF_PIP + | Pseudo_AF_PIP -- Help Identify PIP packets +#endif +#ifdef AF_SIP + | AF_SIP -- Simple Internet Protocol +#endif +#ifdef AF_ISDN + | AF_ISDN -- Integrated Services Digital Network +#endif +#ifdef Pseudo_AF_KEY + | Pseudo_AF_KEY -- Internal key-management function +#endif +#ifdef AF_NATM + | AF_NATM -- native ATM access +#endif +#ifdef AF_ARP + | AF_ARP -- (rev.) addr. res. prot. (RFC 826) +#endif +#ifdef Pseudo_AF_HDRCMPLT + | Pseudo_AF_HDRCMPLT -- Used by BPF to not rewrite hdrs in iface output +#endif +#ifdef AF_ENCAP + | AF_ENCAP +#endif +#ifdef AF_LINK + | AF_LINK -- Link layer interface +#endif +#ifdef AF_RAW + | AF_RAW -- Link layer interface +#endif +#ifdef AF_RIF + | AF_RIF -- raw interface +#endif +#ifdef AF_NETROM + | AF_NETROM -- Amateur radio NetROM +#endif +#ifdef AF_BRIDGE + | AF_BRIDGE -- multiprotocol bridge +#endif +#ifdef AF_ATMPVC + | AF_ATMPVC -- ATM PVCs +#endif +#ifdef AF_ROSE + | AF_ROSE -- Amateur Radio X.25 PLP +#endif +#ifdef AF_NETBEUI + | AF_NETBEUI -- 802.2LLC +#endif +#ifdef AF_SECURITY + | AF_SECURITY -- Security callback pseudo AF +#endif +#ifdef AF_PACKET + | AF_PACKET -- Packet family +#endif +#ifdef AF_ASH + | AF_ASH -- Ash +#endif +#ifdef AF_ECONET + | AF_ECONET -- Acorn Econet +#endif +#ifdef AF_ATMSVC + | AF_ATMSVC -- ATM SVCs +#endif +#ifdef AF_IRDA + | AF_IRDA -- IRDA sockets +#endif +#ifdef AF_PPPOX + | AF_PPPOX -- PPPoX sockets +#endif +#ifdef AF_WANPIPE + | AF_WANPIPE -- Wanpipe API sockets +#endif +#ifdef AF_BLUETOOTH + | AF_BLUETOOTH -- bluetooth sockets +#endif + deriving (Eq, Ord, Read, Show) + +-- --------------------------------------------------------------------- +-- Guards for socket operations that may fail + +-- | Throw an 'IOError' corresponding to the current socket error. +throwSocketError :: String -- ^ textual description of the error location + -> IO a + +-- | Throw an 'IOError' corresponding to the current socket error if +-- the IO action returns a result of @-1@. Discards the result of the +-- IO action after error handling. +throwSocketErrorIfMinus1_ + :: (Eq a, Num a) + => String -- ^ textual description of the location + -> IO a -- ^ the 'IO' operation to be executed + -> IO () + +{-# SPECIALIZE throwSocketErrorIfMinus1_ :: String -> IO CInt -> IO () #-} + +-- | Throw an 'IOError' corresponding to the current socket error if +-- the IO action returns a result of @-1@, but retries in case of an +-- interrupted operation. +throwSocketErrorIfMinus1Retry + :: (Eq a, Num a) + => String -- ^ textual description of the location + -> IO a -- ^ the 'IO' operation to be executed + -> IO a + +{-# SPECIALIZE throwSocketErrorIfMinus1Retry :: String -> IO CInt -> IO CInt #-} + +-- | Throw an 'IOError' corresponding to the current socket error if +-- the IO action returns a result of @-1@, but retries in case of an +-- interrupted operation. Checks for operations that would block and +-- executes an alternative action before retrying in that case. +throwSocketErrorIfMinus1RetryMayBlock + :: (Eq a, Num a) + => String -- ^ textual description of the location + -> IO b -- ^ action to execute before retrying if an + -- immediate retry would block + -> IO a -- ^ the 'IO' operation to be executed + -> IO a + +{-# SPECIALIZE throwSocketErrorIfMinus1RetryMayBlock + :: String -> IO b -> IO CInt -> IO CInt #-} + +#if defined(__GLASGOW_HASKELL__) && (!defined(HAVE_WINSOCK2_H) || defined(cygwin32_HOST_OS)) + +throwSocketErrorIfMinus1RetryMayBlock name on_block act = + throwErrnoIfMinus1RetryMayBlock name act on_block + +throwSocketErrorIfMinus1Retry = throwErrnoIfMinus1Retry + +throwSocketErrorIfMinus1_ = throwErrnoIfMinus1_ + +throwSocketError = throwErrno + +#else + +throwSocketErrorIfMinus1RetryMayBlock name _ act + = throwSocketErrorIfMinus1Retry name act + +throwSocketErrorIfMinus1_ name act = do + throwSocketErrorIfMinus1Retry name act + return () + +# if defined(HAVE_WINSOCK2_H) && !defined(cygwin32_HOST_OS) +throwSocketErrorIfMinus1Retry name act = do + r <- act + if (r == -1) + then do + rc <- c_getLastError + case rc of + 10093 -> do -- WSANOTINITIALISED + withSocketsDo (return ()) + r <- act + if (r == -1) + then throwSocketError name + else return r + _ -> throwSocketError name + else return r + +throwSocketError name = do + rc <- c_getLastError + pstr <- c_getWSError rc + str <- peekCString pstr +# if __GLASGOW_HASKELL__ + ioError (ioeSetErrorString (mkIOError OtherError name Nothing Nothing) str) +# else + ioError (userError (name ++ ": socket error - " ++ str)) +# endif + +foreign import CALLCONV unsafe "WSAGetLastError" + c_getLastError :: IO CInt + +foreign import ccall unsafe "getWSErrorDescr" + c_getWSError :: CInt -> IO (Ptr CChar) + + +# else +throwSocketErrorIfMinus1Retry = throwErrnoIfMinus1Retry +throwSocketError = throwErrno +# endif +#endif /* __GLASGOW_HASKELL */ + +-- --------------------------------------------------------------------------- +-- WinSock support + +{-| On Windows operating systems, the networking subsystem has to be +initialised using 'withSocketsDo' before any networking operations can +be used. eg. + +> main = withSocketsDo $ do {...} + +Although this is only strictly necessary on Windows platforms, it is +harmless on other platforms, so for portability it is good practice to +use it all the time. +-} +withSocketsDo :: IO a -> IO a +#if !defined(WITH_WINSOCK) +withSocketsDo x = x +#else +withSocketsDo act = do + x <- initWinSock + if x /= 0 + then ioError (userError "Failed to initialise WinSock") + else act `finally` shutdownWinSock + +foreign import ccall unsafe "initWinSock" initWinSock :: IO Int +foreign import ccall unsafe "shutdownWinSock" shutdownWinSock :: IO () + +#endif + +------------------------------------------------------------------------ +-- Helper functions + +foreign import ccall unsafe "string.h" memset :: Ptr a -> CInt -> CSize -> IO () + +-- | Zero a structure. +zeroMemory :: Ptr a -> CSize -> IO () +zeroMemory dest nbytes = memset dest 0 (fromIntegral nbytes) diff --git a/Network/Stream.hs b/Network/Stream.hs new file mode 100644 --- /dev/null +++ b/Network/Stream.hs @@ -0,0 +1,91 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.Stream +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- An library for creating abstract streams. Originally part of Gray's\/Bringert's +-- HTTP module. +-- +-- * Changes by Robin Bate Boerop : +-- - Removed unnecessary import statements. +-- - Moved Debug code to StreamDebugger.hs +-- - Moved Socket-related code to StreamSocket.hs. +-- +-- * Changes by Simon Foster: +-- - Split Network.HTTPmodule up into to separate +-- Network.[Stream,TCP,HTTP] modules +----------------------------------------------------------------------------- +module Network.Stream + ( Stream(..) + , ConnError(..) + , Result + , bindE + , fmapE + + , failParse -- :: String -> Result a + , failWith -- :: ConnError -> Result a + , failMisc -- :: String -> Result a + ) where + +import Control.Monad.Error + +data ConnError + = ErrorReset + | ErrorClosed + | ErrorParse String + | ErrorMisc String + deriving(Show,Eq) + +instance Error ConnError where + noMsg = strMsg "unknown error" + strMsg x = ErrorMisc x + +-- in GHC 7.0 the Monad instance for Error no longer +-- uses fail x = Left (strMsg x). failMisc is therefore +-- used instead. +failMisc :: String -> Result a +failMisc x = failWith (strMsg x) + +failParse :: String -> Result a +failParse x = failWith (ErrorParse x) + +failWith :: ConnError -> Result a +failWith x = Left x + +bindE :: Result a -> (a -> Result b) -> Result b +bindE (Left e) _ = Left e +bindE (Right v) f = f v + +fmapE :: (a -> Result b) -> IO (Result a) -> IO (Result b) +fmapE f a = do + x <- a + case x of + Left e -> return (Left e) + Right r -> return (f r) + +-- | This is the type returned by many exported network functions. +type Result a = Either ConnError {- error -} + a {- result -} + +-- | Streams should make layering of TLS protocol easier in future, +-- they allow reading/writing to files etc for debugging, +-- they allow use of protocols other than TCP/IP +-- and they allow customisation. +-- +-- Instances of this class should not trim +-- the input in any way, e.g. leave LF on line +-- endings etc. Unless that is exactly the behaviour +-- you want from your twisted instances ;) +class Stream x where + readLine :: x -> IO (Result String) + readBlock :: x -> Int -> IO (Result String) + writeBlock :: x -> String -> IO (Result ()) + close :: x -> IO () + closeOnEnd :: x -> Bool -> IO () + -- ^ True => shutdown the connection when response has been read / end-of-stream + -- has been reached. diff --git a/Network/StreamDebugger.hs b/Network/StreamDebugger.hs new file mode 100644 --- /dev/null +++ b/Network/StreamDebugger.hs @@ -0,0 +1,103 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.StreamDebugger +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- Implements debugging of @Stream@s. Originally part of Gray's\/Bringert's +-- HTTP module. +-- +-- * Changes by Robin Bate Boerop : +-- - Created. Made minor formatting changes. +-- +----------------------------------------------------------------------------- +module Network.StreamDebugger + ( StreamDebugger + , debugStream + , debugByteStream + ) where + +import Network.Stream (Stream(..)) +import System.IO + ( Handle, hFlush, hPutStrLn, IOMode(AppendMode), hClose, openFile, + hSetBuffering, BufferMode(NoBuffering) + ) +import Network.TCP ( HandleStream, HStream, + StreamHooks(..), setStreamHooks, getStreamHooks ) + +-- | Allows stream logging. Refer to 'debugStream' below. +data StreamDebugger x + = Dbg Handle x + +instance (Stream x) => Stream (StreamDebugger x) where + readBlock (Dbg h x) n = + do val <- readBlock x n + hPutStrLn h ("--readBlock " ++ show n) + hPutStrLn h (show val) + return val + readLine (Dbg h x) = + do val <- readLine x + hPutStrLn h ("--readLine") + hPutStrLn h (show val) + return val + writeBlock (Dbg h x) str = + do val <- writeBlock x str + hPutStrLn h ("--writeBlock" ++ show str) + hPutStrLn h (show val) + return val + close (Dbg h x) = + do hPutStrLn h "--closing..." + hFlush h + close x + hPutStrLn h "--closed." + hClose h + closeOnEnd (Dbg h x) f = + do hPutStrLn h ("--close-on-end.." ++ show f) + hFlush h + closeOnEnd x f + +-- | Wraps a stream with logging I\/O. +-- The first argument is a filename which is opened in @AppendMode@. +debugStream :: (Stream a) => FilePath -> a -> IO (StreamDebugger a) +debugStream file stream = + do h <- openFile file AppendMode + hPutStrLn h ("File \"" ++ file ++ "\" opened for appending.") + return (Dbg h stream) + +debugByteStream :: HStream ty => FilePath -> HandleStream ty -> IO (HandleStream ty) +debugByteStream file stream = do + sh <- getStreamHooks stream + case sh of + Just h + | hook_name h == file -> return stream -- reuse the stream hooks. + _ -> do + h <- openFile file AppendMode + hSetBuffering h NoBuffering + hPutStrLn h ("File \"" ++ file ++ "\" opened for appending.") + setStreamHooks stream (debugStreamHooks h file) + return stream + +debugStreamHooks :: HStream ty => Handle -> String -> StreamHooks ty +debugStreamHooks h nm = + StreamHooks + { hook_readBlock = \ toStr n val -> do + let eval = case val of { Left e -> Left e ; Right v -> Right $ toStr v} + hPutStrLn h ("--readBlock " ++ show n) + hPutStrLn h (either show show eval) + , hook_readLine = \ toStr val -> do + let eval = case val of { Left e -> Left e ; Right v -> Right $ toStr v} + hPutStrLn h ("--readLine") + hPutStrLn h (either show show eval) + , hook_writeBlock = \ toStr str val -> do + hPutStrLn h ("--writeBlock " ++ show val) + hPutStrLn h (toStr str) + , hook_close = do + hPutStrLn h "--closing..." + hFlush h + hClose h + , hook_name = nm + } diff --git a/Network/StreamSocket.hs b/Network/StreamSocket.hs new file mode 100644 --- /dev/null +++ b/Network/StreamSocket.hs @@ -0,0 +1,93 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +----------------------------------------------------------------------------- +-- | +-- Module : Network.StreamSocket +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- Socket Stream instance. Originally part of Gray's\/Bringert's HTTP module. +-- +-- * Changes by Robin Bate Boerop : +-- - Made dependencies explicit in import statements. +-- - Removed false dependencies in import statements. +-- - Created separate module for instance Stream Socket. +-- +-- * Changes by Simon Foster: +-- - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules +-- +----------------------------------------------------------------------------- +module Network.StreamSocket + ( handleSocketError + , myrecv + ) where + +import Network.Stream + ( Stream(..), ConnError(ErrorReset, ErrorMisc), Result + ) +import Network.Socket + ( Socket, getSocketOption, shutdown, send, recv, sClose + , ShutdownCmd(ShutdownBoth), SocketOption(SoError) + ) + +import Network.HTTP.Base ( catchIO ) +import Control.Monad (liftM) +import Control.Exception as Exception (IOException) +import System.IO.Error (catch, isEOFError) + +-- | Exception handler for socket operations. +handleSocketError :: Socket -> IOException -> IO (Result a) +handleSocketError sk e = + do se <- getSocketOption sk SoError + case se of + 0 -> ioError e + 10054 -> return $ Left ErrorReset -- reset + _ -> return $ Left $ ErrorMisc $ show se + +myrecv :: Socket -> Int -> IO String +myrecv sock len = + let handler e = if isEOFError e then return [] else ioError e + in System.IO.Error.catch (recv sock len) handler + +instance Stream Socket where + readBlock sk n = readBlockSocket sk n + readLine sk = readLineSocket sk + writeBlock sk str = writeBlockSocket sk str + close sk = do + -- This slams closed the connection (which is considered rude for TCP\/IP) + shutdown sk ShutdownBoth + sClose sk + closeOnEnd _sk _ = return () -- can't really deal with this, so do run the risk of leaking sockets here. + +readBlockSocket :: Socket -> Int -> IO (Result String) +readBlockSocket sk n = (liftM Right $ fn n) `catchIO` (handleSocketError sk) + where + fn x = do { str <- myrecv sk x + ; let len = length str + ; if len < x + then ( fn (x-len) >>= \more -> return (str++more) ) + else return str + } + +-- Use of the following function is discouraged. +-- The function reads in one character at a time, +-- which causes many calls to the kernel recv() +-- hence causes many context switches. +readLineSocket :: Socket -> IO (Result String) +readLineSocket sk = (liftM Right $ fn "") `catchIO` (handleSocketError sk) + where + fn str = do + c <- myrecv sk 1 -- like eating through a straw. + if null c || c == "\n" + then return (reverse str++c) + else fn (head c:str) + +writeBlockSocket :: Socket -> String -> IO (Result ()) +writeBlockSocket sk str = (liftM Right $ fn str) `catchIO` (handleSocketError sk) + where + fn [] = return () + fn x = send sk x >>= \i -> fn (drop i x) + diff --git a/Network/TCP.hs b/Network/TCP.hs new file mode 100644 --- /dev/null +++ b/Network/TCP.hs @@ -0,0 +1,411 @@ +{-# LANGUAGE TypeSynonymInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Network.TCP +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- Some utility functions for working with the Haskell @network@ package. Mostly +-- for internal use by the @Network.HTTP@ code, but +-- +----------------------------------------------------------------------------- +module Network.TCP + ( Connection + , EndPoint(..) + , openTCPPort + , isConnectedTo + + , openTCPConnection + , socketConnection + , isTCPConnectedTo + + , HandleStream + , HStream(..) + + , StreamHooks(..) + , nullHooks + , setStreamHooks + , getStreamHooks + , hstreamToConnection + + ) where + +import Network.BSD (getHostByName, hostAddresses) +import Network.Socket + ( Socket, SockAddr(SockAddrInet), SocketOption(KeepAlive) + , SocketType(Stream), inet_addr, connect + , shutdown, ShutdownCmd(..) + , sClose, setSocketOption, getPeerName + , socket, Family(AF_INET) + ) +import qualified Network.Stream as Stream + ( Stream(readBlock, readLine, writeBlock, close, closeOnEnd) ) +import Network.Stream + ( ConnError(..) + , Result + , failWith + , failMisc + ) +import Network.BufferType + +import Network.HTTP.Base ( catchIO ) +import Network.Socket ( socketToHandle ) + +import Data.Char ( toLower ) +import Data.Word ( Word8 ) +import Control.Concurrent +import Control.Monad ( liftM, when ) +import System.IO ( Handle, hFlush, IOMode(..), hClose ) +import System.IO.Error ( isEOFError ) + +import qualified Data.ByteString as Strict +import qualified Data.ByteString.Lazy as Lazy + +----------------------------------------------------------------- +------------------ TCP Connections ------------------------------ +----------------------------------------------------------------- + +-- | The 'Connection' newtype is a wrapper that allows us to make +-- connections an instance of the Stream class, without GHC extensions. +-- While this looks sort of like a generic reference to the transport +-- layer it is actually TCP specific, which can be seen in the +-- implementation of the 'Stream Connection' instance. +newtype Connection = Connection (HandleStream String) + +newtype HandleStream a = HandleStream {getRef :: MVar (Conn a)} + +data EndPoint = EndPoint { epHost :: String, epPort :: Int } + +instance Eq EndPoint where + EndPoint host1 port1 == EndPoint host2 port2 = + map toLower host1 == map toLower host2 && port1 == port2 + +data Conn a + = MkConn { connSock :: ! Socket + , connHandle :: Handle + , connBuffer :: BufferOp a + , connInput :: Maybe a + , connEndPoint :: EndPoint + , connHooks :: Maybe (StreamHooks a) + , connCloseEOF :: Bool -- True => close socket upon reaching end-of-stream. + } + | ConnClosed + deriving(Eq) + +hstreamToConnection :: HandleStream String -> Connection +hstreamToConnection h = Connection h + +connHooks' :: Conn a -> Maybe (StreamHooks a) +connHooks' ConnClosed{} = Nothing +connHooks' x = connHooks x + +-- all of these are post-op hooks +data StreamHooks ty + = StreamHooks + { hook_readLine :: (ty -> String) -> Result ty -> IO () + , hook_readBlock :: (ty -> String) -> Int -> Result ty -> IO () + , hook_writeBlock :: (ty -> String) -> ty -> Result () -> IO () + , hook_close :: IO () + , hook_name :: String -- hack alert: name of the hook itself. + } + +instance Eq ty => Eq (StreamHooks ty) where + (==) _ _ = True + +nullHooks :: StreamHooks ty +nullHooks = StreamHooks + { hook_readLine = \ _ _ -> return () + , hook_readBlock = \ _ _ _ -> return () + , hook_writeBlock = \ _ _ _ -> return () + , hook_close = return () + , hook_name = "" + } + +setStreamHooks :: HandleStream ty -> StreamHooks ty -> IO () +setStreamHooks h sh = modifyMVar_ (getRef h) (\ c -> return c{connHooks=Just sh}) + +getStreamHooks :: HandleStream ty -> IO (Maybe (StreamHooks ty)) +getStreamHooks h = readMVar (getRef h) >>= return.connHooks + +-- | @HStream@ overloads the use of 'HandleStream's, letting you +-- overload the handle operations over the type that is communicated +-- across the handle. It comes in handy for @Network.HTTP@ 'Request' +-- and 'Response's as the payload representation isn't fixed, but overloaded. +-- +-- The library comes with instances for @ByteString@s and @String@, but +-- should you want to plug in your own payload representation, defining +-- your own @HStream@ instance _should_ be all that it takes. +-- +class BufferType bufType => HStream bufType where + openStream :: String -> Int -> IO (HandleStream bufType) + openSocketStream :: String -> Int -> Socket -> IO (HandleStream bufType) + readLine :: HandleStream bufType -> IO (Result bufType) + readBlock :: HandleStream bufType -> Int -> IO (Result bufType) + writeBlock :: HandleStream bufType -> bufType -> IO (Result ()) + close :: HandleStream bufType -> IO () + closeQuick :: HandleStream bufType -> IO () + closeOnEnd :: HandleStream bufType -> Bool -> IO () + +instance HStream Strict.ByteString where + openStream = openTCPConnection + openSocketStream = socketConnection + readBlock c n = readBlockBS c n + readLine c = readLineBS c + writeBlock c str = writeBlockBS c str + close c = closeIt c Strict.null True + closeQuick c = closeIt c Strict.null False + closeOnEnd c f = closeEOF c f + +instance HStream Lazy.ByteString where + openStream = \ a b -> openTCPConnection_ a b True + openSocketStream = \ a b c -> socketConnection_ a b c True + readBlock c n = readBlockBS c n + readLine c = readLineBS c + writeBlock c str = writeBlockBS c str + close c = closeIt c Lazy.null True + closeQuick c = closeIt c Lazy.null False + closeOnEnd c f = closeEOF c f + +instance Stream.Stream Connection where + readBlock (Connection c) = Network.TCP.readBlock c + readLine (Connection c) = Network.TCP.readLine c + writeBlock (Connection c) = Network.TCP.writeBlock c + close (Connection c) = Network.TCP.close c + closeOnEnd (Connection c) f = Network.TCP.closeEOF c f + +instance HStream String where + openStream = openTCPConnection + openSocketStream = socketConnection + readBlock ref n = readBlockBS ref n + + -- This function uses a buffer, at this time the buffer is just 1000 characters. + -- (however many bytes this is is left to the user to decypher) + readLine ref = readLineBS ref + -- The 'Connection' object allows no outward buffering, + -- since in general messages are serialised in their entirety. + writeBlock ref str = writeBlockBS ref str -- (stringToBuf str) + + -- Closes a Connection. Connection will no longer + -- allow any of the other Stream functions. Notice that a Connection may close + -- at any time before a call to this function. This function is idempotent. + -- (I think the behaviour here is TCP specific) + close c = closeIt c null True + + -- Closes a Connection without munching the rest of the stream. + closeQuick c = closeIt c null False + + closeOnEnd c f = closeEOF c f + +-- | @openTCPPort uri port@ establishes a connection to a remote +-- host, using 'getHostByName' which possibly queries the DNS system, hence +-- may trigger a network connection. +openTCPPort :: String -> Int -> IO Connection +openTCPPort uri port = openTCPConnection uri port >>= return.Connection + +-- Add a "persistent" option? Current persistent is default. +-- Use "Result" type for synchronous exception reporting? +openTCPConnection :: BufferType ty => String -> Int -> IO (HandleStream ty) +openTCPConnection uri port = openTCPConnection_ uri port False + +openTCPConnection_ :: BufferType ty => String -> Int -> Bool -> IO (HandleStream ty) +openTCPConnection_ uri port stashInput = withSocket $ \s -> do + setSocketOption s KeepAlive 1 + hostA <- getHostAddr uri + let a = SockAddrInet (toEnum port) hostA + connect s a + socketConnection_ uri port s stashInput + where + withSocket action = do + s <- socket AF_INET Stream 6 + catchIO (action s) (\e -> sClose s >> ioError e) + getHostAddr h = do + catchIO (inet_addr uri) -- handles ascii IP numbers + (\ _ -> do + host <- getHostByName_safe uri + case hostAddresses host of + [] -> fail ("openTCPConnection: no addresses in host entry for " ++ show h) + (ha:_) -> return ha) + + getHostByName_safe h = + catchIO (getHostByName h) + (\ _ -> fail ("openTCPConnection: host lookup failure for " ++ show h)) + +-- | @socketConnection@, like @openConnection@ but using a pre-existing 'Socket'. +socketConnection :: BufferType ty + => String + -> Int + -> Socket + -> IO (HandleStream ty) +socketConnection hst port sock = socketConnection_ hst port sock False + +-- Internal function used to control the on-demand streaming of input +-- for /lazy/ streams. +socketConnection_ :: BufferType ty + => String + -> Int + -> Socket + -> Bool + -> IO (HandleStream ty) +socketConnection_ hst port sock stashInput = do + h <- socketToHandle sock ReadWriteMode + mb <- case stashInput of { True -> liftM Just $ buf_hGetContents bufferOps h; _ -> return Nothing } + let conn = MkConn + { connSock = sock + , connHandle = h + , connBuffer = bufferOps + , connInput = mb + , connEndPoint = EndPoint hst port + , connHooks = Nothing + , connCloseEOF = False + } + v <- newMVar conn + return (HandleStream v) + +closeConnection :: HStream a => HandleStream a -> IO Bool -> IO () +closeConnection ref readL = do + -- won't hold onto the lock for the duration + -- we are draining it...ToDo: have Connection + -- into a shutting-down state so that other + -- threads will simply back off if/when attempting + -- to also close it. + c <- readMVar (getRef ref) + closeConn c `catchIO` (\_ -> return ()) + modifyMVar_ (getRef ref) (\ _ -> return ConnClosed) + where + -- Be kind to peer & close gracefully. + closeConn ConnClosed = return () + closeConn conn = do + let sk = connSock conn + hFlush (connHandle conn) + shutdown sk ShutdownSend + suck readL + hClose (connHandle conn) + shutdown sk ShutdownReceive + sClose sk + + suck :: IO Bool -> IO () + suck rd = do + f <- rd + if f then return () else suck rd + +-- | Checks both that the underlying Socket is connected +-- and that the connection peer matches the given +-- host name (which is recorded locally). +isConnectedTo :: Connection -> EndPoint -> IO Bool +isConnectedTo (Connection conn) endPoint = do + v <- readMVar (getRef conn) + case v of + ConnClosed -> print "aa" >> return False + _ + | connEndPoint v == endPoint -> + catch (getPeerName (connSock v) >> return True) (const $ return False) + | otherwise -> return False + +isTCPConnectedTo :: HandleStream ty -> EndPoint -> IO Bool +isTCPConnectedTo conn endPoint = do + v <- readMVar (getRef conn) + case v of + ConnClosed -> return False + _ + | connEndPoint v == endPoint -> + catch (getPeerName (connSock v) >> return True) (const $ return False) + | otherwise -> return False + +readBlockBS :: HStream a => HandleStream a -> Int -> IO (Result a) +readBlockBS ref n = onNonClosedDo ref $ \ conn -> do + x <- bufferGetBlock ref n + maybe (return ()) + (\ h -> hook_readBlock h (buf_toStr $ connBuffer conn) n x) + (connHooks' conn) + return x + +-- This function uses a buffer, at this time the buffer is just 1000 characters. +-- (however many bytes this is is left for the user to decipher) +readLineBS :: HStream a => HandleStream a -> IO (Result a) +readLineBS ref = onNonClosedDo ref $ \ conn -> do + x <- bufferReadLine ref + maybe (return ()) + (\ h -> hook_readLine h (buf_toStr $ connBuffer conn) x) + (connHooks' conn) + return x + +-- The 'Connection' object allows no outward buffering, +-- since in general messages are serialised in their entirety. +writeBlockBS :: HandleStream a -> a -> IO (Result ()) +writeBlockBS ref b = onNonClosedDo ref $ \ conn -> do + x <- bufferPutBlock (connBuffer conn) (connHandle conn) b + maybe (return ()) + (\ h -> hook_writeBlock h (buf_toStr $ connBuffer conn) b x) + (connHooks' conn) + return x + +closeIt :: HStream ty => HandleStream ty -> (ty -> Bool) -> Bool -> IO () +closeIt c p b = do + closeConnection c (if b + then readLineBS c >>= \ x -> case x of { Right xs -> return (p xs); _ -> return True} + else return True) + conn <- readMVar (getRef c) + maybe (return ()) + (hook_close) + (connHooks' conn) + +closeEOF :: HandleStream ty -> Bool -> IO () +closeEOF c flg = modifyMVar_ (getRef c) (\ co -> return co{connCloseEOF=flg}) + +bufferGetBlock :: HStream a => HandleStream a -> Int -> IO (Result a) +bufferGetBlock ref n = onNonClosedDo ref $ \ conn -> do + case connInput conn of + Just c -> do + let (a,b) = buf_splitAt (connBuffer conn) n c + modifyMVar_ (getRef ref) (\ co -> return co{connInput=Just b}) + return (return a) + _ -> do + Prelude.catch (buf_hGet (connBuffer conn) (connHandle conn) n >>= return.return) + (\ e -> + if isEOFError e + then do + when (connCloseEOF conn) $ catch (closeQuick ref) (\ _ -> return ()) + return (return (buf_empty (connBuffer conn))) + else return (failMisc (show e))) + +bufferPutBlock :: BufferOp a -> Handle -> a -> IO (Result ()) +bufferPutBlock ops h b = + Prelude.catch (buf_hPut ops h b >> hFlush h >> return (return ())) + (\ e -> return (failMisc (show e))) + +bufferReadLine :: HStream a => HandleStream a -> IO (Result a) +bufferReadLine ref = onNonClosedDo ref $ \ conn -> do + case connInput conn of + Just c -> do + let (a,b0) = buf_span (connBuffer conn) (/='\n') c + let (newl,b1) = buf_splitAt (connBuffer conn) 1 b0 + modifyMVar_ (getRef ref) (\ co -> return co{connInput=Just b1}) + return (return (buf_append (connBuffer conn) a newl)) + _ -> Prelude.catch + (buf_hGetLine (connBuffer conn) (connHandle conn) >>= + return . return . appendNL (connBuffer conn)) + (\ e -> + if isEOFError e + then do + when (connCloseEOF conn) $ catch (closeQuick ref) (\ _ -> return ()) + return (return (buf_empty (connBuffer conn))) + else return (failMisc (show e))) + where + -- yes, this s**ks.. _may_ have to be addressed if perf + -- suggests worthiness. + appendNL ops b = buf_snoc ops b nl + + nl :: Word8 + nl = fromIntegral (fromEnum '\n') + +onNonClosedDo :: HandleStream a -> (Conn a -> IO (Result b)) -> IO (Result b) +onNonClosedDo h act = do + x <- readMVar (getRef h) + case x of + ConnClosed{} -> return (failWith ErrorClosed) + _ -> act x + diff --git a/Network/URI.hs b/Network/URI.hs new file mode 100644 --- /dev/null +++ b/Network/URI.hs @@ -0,0 +1,1289 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Network.URI +-- Copyright : (c) 2004, Graham Klyne +-- License : BSD-style (see end of this file) +-- +-- Maintainer : Graham Klyne +-- Stability : provisional +-- Portability : portable +-- +-- This module defines functions for handling URIs. It presents substantially the +-- same interface as the older GHC Network.URI module, but is implemented using +-- Parsec rather than a Regex library that is not available with Hugs. The internal +-- representation of URI has been changed so that URI strings are more +-- completely preserved when round-tripping to a URI value and back. +-- +-- In addition, four methods are provided for parsing different +-- kinds of URI string (as noted in RFC3986): +-- 'parseURI', +-- 'parseURIReference', +-- 'parseRelativeReference' and +-- 'parseAbsoluteURI'. +-- +-- Further, four methods are provided for classifying different +-- kinds of URI string (as noted in RFC3986): +-- 'isURI', +-- 'isURIReference', +-- 'isRelativeReference' and +-- 'isAbsoluteURI'. +-- +-- The long-standing official reference for URI handling was RFC2396 [1], +-- as updated by RFC 2732 [2], but this was replaced by a new specification, +-- RFC3986 [3] in January 2005. This latter specification has been used +-- as the primary reference for constructing the URI parser implemented +-- here, and it is intended that there is a direct relationship between +-- the syntax definition in that document and this parser implementation. +-- +-- RFC 1808 [4] contains a number of test cases for relative URI handling. +-- Dan Connolly's Python module @uripath.py@ [5] also contains useful details +-- and test cases. +-- +-- Some of the code has been copied from the previous GHC implementation, +-- but the parser is replaced with one that performs more complete +-- syntax checking of the URI itself, according to RFC3986 [3]. +-- +-- References +-- +-- (1) +-- +-- (2) +-- +-- (3) +-- +-- (4) +-- +-- (5) +-- +-------------------------------------------------------------------------------- + +module Network.URI + ( + -- * The URI type + URI(..) + , URIAuth(..) + , nullURI + + -- * Parsing + , parseURI + , parseURIReference + , parseRelativeReference + , parseAbsoluteURI + + -- * Test for strings containing various kinds of URI + , isURI + , isURIReference + , isRelativeReference + , isAbsoluteURI + , isIPv6address + , isIPv4address + + -- * Relative URIs + , relativeTo + , nonStrictRelativeTo + , relativeFrom + + -- * Operations on URI strings + -- | Support for putting strings into URI-friendly + -- escaped format and getting them back again. + -- This can't be done transparently in all cases, because certain + -- characters have different meanings in different kinds of URI. + -- The URI spec [3], section 2.4, indicates that all URI components + -- should be escaped before they are assembled as a URI: + -- \"Once produced, a URI is always in its percent-encoded form\" + , uriToString + , isReserved, isUnreserved + , isAllowedInURI, isUnescapedInURI + , escapeURIChar + , escapeURIString + , unEscapeString + + -- * URI Normalization functions + , normalizeCase + , normalizeEscape + , normalizePathSegments + + -- * Deprecated functions + , parseabsoluteURI + , escapeString + , reserved, unreserved + , scheme, authority, path, query, fragment + ) where + +import Text.ParserCombinators.Parsec + ( GenParser, ParseError + , parse, (<|>), (), try + , option, many, many1, count, notFollowedBy + , char, satisfy, oneOf, string, eof + , unexpected + ) + +import Control.Monad (MonadPlus(..)) +import Data.Char (ord, chr, isHexDigit, toLower, toUpper, digitToInt) +import Debug.Trace (trace) +import Numeric (showIntAtBase) + +#ifdef __GLASGOW_HASKELL__ +import Data.Typeable (Typeable) +# if MIN_VERSION_base(4,0,0) +import Data.Data (Data) +# else +import Data.Generics (Data) +# endif +#else +import Data.Typeable (Typeable(..), TyCon, mkTyCon, mkTyConApp) +#endif + +------------------------------------------------------------ +-- The URI datatype +------------------------------------------------------------ + +-- |Represents a general universal resource identifier using +-- its component parts. +-- +-- For example, for the URI +-- +-- > foo://anonymous@www.haskell.org:42/ghc?query#frag +-- +-- the components are: +-- +data URI = URI + { uriScheme :: String -- ^ @foo:@ + , uriAuthority :: Maybe URIAuth -- ^ @\/\/anonymous\@www.haskell.org:42@ + , uriPath :: String -- ^ @\/ghc@ + , uriQuery :: String -- ^ @?query@ + , uriFragment :: String -- ^ @#frag@ + } deriving (Eq +#ifdef __GLASGOW_HASKELL__ + , Typeable, Data +#endif + ) + +#ifndef __GLASGOW_HASKELL__ +uriTc :: TyCon +uriTc = mkTyCon "URI" + +instance Typeable URI where + typeOf _ = mkTyConApp uriTc [] +#endif + +-- |Type for authority value within a URI +data URIAuth = URIAuth + { uriUserInfo :: String -- ^ @anonymous\@@ + , uriRegName :: String -- ^ @www.haskell.org@ + , uriPort :: String -- ^ @:42@ + } deriving (Eq +#ifdef __GLASGOW_HASKELL__ + , Typeable, Data +#endif + ) + +#ifndef __GLASGOW_HASKELL__ +uriAuthTc :: TyCon +uriAuthTc = mkTyCon "URIAuth" + +instance Typeable URIAuth where + typeOf _ = mkTyConApp uriAuthTc [] +#endif + +-- |Blank URI +nullURI :: URI +nullURI = URI + { uriScheme = "" + , uriAuthority = Nothing + , uriPath = "" + , uriQuery = "" + , uriFragment = "" + } + +-- URI as instance of Show. Note that for security reasons, the default +-- behaviour is to suppress any userinfo field (see RFC3986, section 7.5). +-- This can be overridden by using uriToString directly with first +-- argument @id@ (noting that this returns a ShowS value rather than a string). +-- +-- [[[Another design would be to embed the userinfo mapping function in +-- the URIAuth value, with the default value suppressing userinfo formatting, +-- but providing a function to return a new URI value with userinfo +-- data exposed by show.]]] +-- +instance Show URI where + showsPrec _ = uriToString defaultUserInfoMap + +defaultUserInfoMap :: String -> String +defaultUserInfoMap uinf = user++newpass + where + (user,pass) = break (==':') uinf + newpass = if null pass || (pass == "@") + || (pass == ":@") + then pass + else ":...@" + +testDefaultUserInfoMap :: [Bool] +testDefaultUserInfoMap = + [ defaultUserInfoMap "" == "" + , defaultUserInfoMap "@" == "@" + , defaultUserInfoMap "user@" == "user@" + , defaultUserInfoMap "user:@" == "user:@" + , defaultUserInfoMap "user:anonymous@" == "user:...@" + , defaultUserInfoMap "user:pass@" == "user:...@" + , defaultUserInfoMap "user:pass" == "user:...@" + , defaultUserInfoMap "user:anonymous" == "user:...@" + ] + +------------------------------------------------------------ +-- Parse a URI +------------------------------------------------------------ + +-- |Turn a string containing a URI into a 'URI'. +-- Returns 'Nothing' if the string is not a valid URI; +-- (an absolute URI with optional fragment identifier). +-- +-- NOTE: this is different from the previous network.URI, +-- whose @parseURI@ function works like 'parseURIReference' +-- in this module. +-- +parseURI :: String -> Maybe URI +parseURI = parseURIAny uri + +-- |Parse a URI reference to a 'URI' value. +-- Returns 'Nothing' if the string is not a valid URI reference. +-- (an absolute or relative URI with optional fragment identifier). +-- +parseURIReference :: String -> Maybe URI +parseURIReference = parseURIAny uriReference + +-- |Parse a relative URI to a 'URI' value. +-- Returns 'Nothing' if the string is not a valid relative URI. +-- (a relative URI with optional fragment identifier). +-- +parseRelativeReference :: String -> Maybe URI +parseRelativeReference = parseURIAny relativeRef + +-- |Parse an absolute URI to a 'URI' value. +-- Returns 'Nothing' if the string is not a valid absolute URI. +-- (an absolute URI without a fragment identifier). +-- +parseAbsoluteURI :: String -> Maybe URI +parseAbsoluteURI = parseURIAny absoluteURI + +-- |Test if string contains a valid URI +-- (an absolute URI with optional fragment identifier). +-- +isURI :: String -> Bool +isURI = isValidParse uri + +-- |Test if string contains a valid URI reference +-- (an absolute or relative URI with optional fragment identifier). +-- +isURIReference :: String -> Bool +isURIReference = isValidParse uriReference + +-- |Test if string contains a valid relative URI +-- (a relative URI with optional fragment identifier). +-- +isRelativeReference :: String -> Bool +isRelativeReference = isValidParse relativeRef + +-- |Test if string contains a valid absolute URI +-- (an absolute URI without a fragment identifier). +-- +isAbsoluteURI :: String -> Bool +isAbsoluteURI = isValidParse absoluteURI + +-- |Test if string contains a valid IPv6 address +-- +isIPv6address :: String -> Bool +isIPv6address = isValidParse ipv6address + +-- |Test if string contains a valid IPv4 address +-- +isIPv4address :: String -> Bool +isIPv4address = isValidParse ipv4address + +-- |Test function: parse and reconstruct a URI reference +-- +testURIReference :: String -> String +testURIReference uristr = show (parseAll uriReference "" uristr) + +-- Helper function for turning a string into a URI +-- +parseURIAny :: URIParser URI -> String -> Maybe URI +parseURIAny parser uristr = case parseAll parser "" uristr of + Left _ -> Nothing + Right u -> Just u + +-- Helper function to test a string match to a parser +-- +isValidParse :: URIParser a -> String -> Bool +isValidParse parser uristr = case parseAll parser "" uristr of + -- Left e -> error (show e) + Left _ -> False + Right _ -> True + +parseAll :: URIParser a -> String -> String -> Either ParseError a +parseAll parser filename uristr = parse newparser filename uristr + where + newparser = + do { res <- parser + ; eof + ; return res + } + +------------------------------------------------------------ +-- URI parser body based on Parsec elements and combinators +------------------------------------------------------------ + +-- Parser parser type. +-- Currently +type URIParser a = GenParser Char () a + +-- RFC3986, section 2.1 +-- +-- Parse and return a 'pct-encoded' sequence +-- +escaped :: URIParser String +escaped = + do { char '%' + ; h1 <- hexDigitChar + ; h2 <- hexDigitChar + ; return $ ['%',h1,h2] + } + +-- RFC3986, section 2.2 +-- +-- |Returns 'True' if the character is a \"reserved\" character in a +-- URI. To include a literal instance of one of these characters in a +-- component of a URI, it must be escaped. +-- +isReserved :: Char -> Bool +isReserved c = isGenDelims c || isSubDelims c + +isGenDelims :: Char -> Bool +isGenDelims c = c `elem` ":/?#[]@" + +isSubDelims :: Char -> Bool +isSubDelims c = c `elem` "!$&'()*+,;=" + +genDelims :: URIParser String +genDelims = do { c <- satisfy isGenDelims ; return [c] } + +subDelims :: URIParser String +subDelims = do { c <- satisfy isSubDelims ; return [c] } + +-- RFC3986, section 2.3 +-- +-- |Returns 'True' if the character is an \"unreserved\" character in +-- a URI. These characters do not need to be escaped in a URI. The +-- only characters allowed in a URI are either \"reserved\", +-- \"unreserved\", or an escape sequence (@%@ followed by two hex digits). +-- +isUnreserved :: Char -> Bool +isUnreserved c = isAlphaNumChar c || (c `elem` "-_.~") + +unreservedChar :: URIParser String +unreservedChar = do { c <- satisfy isUnreserved ; return [c] } + +-- RFC3986, section 3 +-- +-- URI = scheme ":" hier-part [ "?" query ] [ "#" fragment ] +-- +-- hier-part = "//" authority path-abempty +-- / path-abs +-- / path-rootless +-- / path-empty + +uri :: URIParser URI +uri = + do { us <- try uscheme + -- ; ua <- option Nothing ( do { try (string "//") ; uauthority } ) + -- ; up <- upath + ; (ua,up) <- hierPart + ; uq <- option "" ( do { char '?' ; uquery } ) + ; uf <- option "" ( do { char '#' ; ufragment } ) + ; return $ URI + { uriScheme = us + , uriAuthority = ua + , uriPath = up + , uriQuery = uq + , uriFragment = uf + } + } + +hierPart :: URIParser ((Maybe URIAuth),String) +hierPart = + do { try (string "//") + ; ua <- uauthority + ; up <- pathAbEmpty + ; return (ua,up) + } + <|> do { up <- pathAbs + ; return (Nothing,up) + } + <|> do { up <- pathRootLess + ; return (Nothing,up) + } + <|> do { return (Nothing,"") + } + +-- RFC3986, section 3.1 + +uscheme :: URIParser String +uscheme = + do { s <- oneThenMany alphaChar (satisfy isSchemeChar) + ; char ':' + ; return $ s++":" + } + +-- RFC3986, section 3.2 + +uauthority :: URIParser (Maybe URIAuth) +uauthority = + do { uu <- option "" (try userinfo) + ; uh <- host + ; up <- option "" port + ; return $ Just $ URIAuth + { uriUserInfo = uu + , uriRegName = uh + , uriPort = up + } + } + +-- RFC3986, section 3.2.1 + +userinfo :: URIParser String +userinfo = + do { uu <- many (uchar ";:&=+$,") + ; char '@' + ; return (concat uu ++"@") + } + +-- RFC3986, section 3.2.2 + +host :: URIParser String +host = ipLiteral <|> try ipv4address <|> regName + +ipLiteral :: URIParser String +ipLiteral = + do { char '[' + ; ua <- ( ipv6address <|> ipvFuture ) + ; char ']' + ; return $ "[" ++ ua ++ "]" + } + "IP address literal" + +ipvFuture :: URIParser String +ipvFuture = + do { char 'v' + ; h <- hexDigitChar + ; char '.' + ; a <- many1 (satisfy isIpvFutureChar) + ; return $ 'c':h:'.':a + } + +isIpvFutureChar :: Char -> Bool +isIpvFutureChar c = isUnreserved c || isSubDelims c || (c==';') + +ipv6address :: URIParser String +ipv6address = + try ( do + { a2 <- count 6 h4c + ; a3 <- ls32 + ; return $ concat a2 ++ a3 + } ) + <|> try ( do + { string "::" + ; a2 <- count 5 h4c + ; a3 <- ls32 + ; return $ "::" ++ concat a2 ++ a3 + } ) + <|> try ( do + { a1 <- opt_n_h4c_h4 0 + ; string "::" + ; a2 <- count 4 h4c + ; a3 <- ls32 + ; return $ a1 ++ "::" ++ concat a2 ++ a3 + } ) + <|> try ( do + { a1 <- opt_n_h4c_h4 1 + ; string "::" + ; a2 <- count 3 h4c + ; a3 <- ls32 + ; return $ a1 ++ "::" ++ concat a2 ++ a3 + } ) + <|> try ( do + { a1 <- opt_n_h4c_h4 2 + ; string "::" + ; a2 <- count 2 h4c + ; a3 <- ls32 + ; return $ a1 ++ "::" ++ concat a2 ++ a3 + } ) + <|> try ( do + { a1 <- opt_n_h4c_h4 3 + ; string "::" + ; a2 <- h4c + ; a3 <- ls32 + ; return $ a1 ++ "::" ++ a2 ++ a3 + } ) + <|> try ( do + { a1 <- opt_n_h4c_h4 4 + ; string "::" + ; a3 <- ls32 + ; return $ a1 ++ "::" ++ a3 + } ) + <|> try ( do + { a1 <- opt_n_h4c_h4 5 + ; string "::" + ; a3 <- h4 + ; return $ a1 ++ "::" ++ a3 + } ) + <|> try ( do + { a1 <- opt_n_h4c_h4 6 + ; string "::" + ; return $ a1 ++ "::" + } ) + "IPv6 address" + +opt_n_h4c_h4 :: Int -> URIParser String +opt_n_h4c_h4 n = option "" $ + do { a1 <- countMinMax 0 n h4c + ; a2 <- h4 + ; return $ concat a1 ++ a2 + } + +ls32 :: URIParser String +ls32 = try ( do + { a1 <- h4c + ; a2 <- h4 + ; return (a1++a2) + } ) + <|> ipv4address + +h4c :: URIParser String +h4c = try $ + do { a1 <- h4 + ; char ':' + ; notFollowedBy (char ':') + ; return $ a1 ++ ":" + } + +h4 :: URIParser String +h4 = countMinMax 1 4 hexDigitChar + +ipv4address :: URIParser String +ipv4address = + do { a1 <- decOctet ; char '.' + ; a2 <- decOctet ; char '.' + ; a3 <- decOctet ; char '.' + ; a4 <- decOctet + ; return $ a1++"."++a2++"."++a3++"."++a4 + } + +decOctet :: URIParser String +decOctet = + do { a1 <- countMinMax 1 3 digitChar + ; if (read a1 :: Integer) > 255 then + fail "Decimal octet value too large" + else + return a1 + } + +regName :: URIParser String +regName = + do { ss <- countMinMax 0 255 ( unreservedChar <|> escaped <|> subDelims ) + ; return $ concat ss + } + "Registered name" + +-- RFC3986, section 3.2.3 + +port :: URIParser String +port = + do { char ':' + ; p <- many digitChar + ; return (':':p) + } + +-- +-- RFC3986, section 3.3 +-- +-- path = path-abempty ; begins with "/" or is empty +-- / path-abs ; begins with "/" but not "//" +-- / path-noscheme ; begins with a non-colon segment +-- / path-rootless ; begins with a segment +-- / path-empty ; zero characters +-- +-- path-abempty = *( "/" segment ) +-- path-abs = "/" [ segment-nz *( "/" segment ) ] +-- path-noscheme = segment-nzc *( "/" segment ) +-- path-rootless = segment-nz *( "/" segment ) +-- path-empty = 0 +-- +-- segment = *pchar +-- segment-nz = 1*pchar +-- segment-nzc = 1*( unreserved / pct-encoded / sub-delims / "@" ) +-- +-- pchar = unreserved / pct-encoded / sub-delims / ":" / "@" + +{- +upath :: URIParser String +upath = pathAbEmpty + <|> pathAbs + <|> pathNoScheme + <|> pathRootLess + <|> pathEmpty +-} + +pathAbEmpty :: URIParser String +pathAbEmpty = + do { ss <- many slashSegment + ; return $ concat ss + } + +pathAbs :: URIParser String +pathAbs = + do { char '/' + ; ss <- option "" pathRootLess + ; return $ '/':ss + } + +pathNoScheme :: URIParser String +pathNoScheme = + do { s1 <- segmentNzc + ; ss <- many slashSegment + ; return $ concat (s1:ss) + } + +pathRootLess :: URIParser String +pathRootLess = + do { s1 <- segmentNz + ; ss <- many slashSegment + ; return $ concat (s1:ss) + } + +slashSegment :: URIParser String +slashSegment = + do { char '/' + ; s <- segment + ; return ('/':s) + } + +segment :: URIParser String +segment = + do { ps <- many pchar + ; return $ concat ps + } + +segmentNz :: URIParser String +segmentNz = + do { ps <- many1 pchar + ; return $ concat ps + } + +segmentNzc :: URIParser String +segmentNzc = + do { ps <- many1 (uchar "@") + ; return $ concat ps + } + +pchar :: URIParser String +pchar = uchar ":@" + +-- helper function for pchar and friends +uchar :: String -> URIParser String +uchar extras = + unreservedChar + <|> escaped + <|> subDelims + <|> do { c <- oneOf extras ; return [c] } + +-- RFC3986, section 3.4 + +uquery :: URIParser String +uquery = + do { ss <- many $ uchar (":@"++"/?") + ; return $ '?':concat ss + } + +-- RFC3986, section 3.5 + +ufragment :: URIParser String +ufragment = + do { ss <- many $ uchar (":@"++"/?") + ; return $ '#':concat ss + } + +-- Reference, Relative and Absolute URI forms +-- +-- RFC3986, section 4.1 + +uriReference :: URIParser URI +uriReference = uri <|> relativeRef + +-- RFC3986, section 4.2 +-- +-- relative-URI = relative-part [ "?" query ] [ "#" fragment ] +-- +-- relative-part = "//" authority path-abempty +-- / path-abs +-- / path-noscheme +-- / path-empty + +relativeRef :: URIParser URI +relativeRef = + do { notMatching uscheme + -- ; ua <- option Nothing ( do { try (string "//") ; uauthority } ) + -- ; up <- upath + ; (ua,up) <- relativePart + ; uq <- option "" ( do { char '?' ; uquery } ) + ; uf <- option "" ( do { char '#' ; ufragment } ) + ; return $ URI + { uriScheme = "" + , uriAuthority = ua + , uriPath = up + , uriQuery = uq + , uriFragment = uf + } + } + +relativePart :: URIParser ((Maybe URIAuth),String) +relativePart = + do { try (string "//") + ; ua <- uauthority + ; up <- pathAbEmpty + ; return (ua,up) + } + <|> do { up <- pathAbs + ; return (Nothing,up) + } + <|> do { up <- pathNoScheme + ; return (Nothing,up) + } + <|> do { return (Nothing,"") + } + +-- RFC3986, section 4.3 + +absoluteURI :: URIParser URI +absoluteURI = + do { us <- uscheme + -- ; ua <- option Nothing ( do { try (string "//") ; uauthority } ) + -- ; up <- upath + ; (ua,up) <- hierPart + ; uq <- option "" ( do { char '?' ; uquery } ) + ; return $ URI + { uriScheme = us + , uriAuthority = ua + , uriPath = up + , uriQuery = uq + , uriFragment = "" + } + } + +-- Imports from RFC 2234 + + -- NOTE: can't use isAlphaNum etc. because these deal with ISO 8859 + -- (and possibly Unicode!) chars. + -- [[[Above was a comment originally in GHC Network/URI.hs: + -- when IRIs are introduced then most codepoints above 128(?) should + -- be treated as unreserved, and higher codepoints for letters should + -- certainly be allowed. + -- ]]] + +isAlphaChar :: Char -> Bool +isAlphaChar c = (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z') + +isDigitChar :: Char -> Bool +isDigitChar c = (c >= '0' && c <= '9') + +isAlphaNumChar :: Char -> Bool +isAlphaNumChar c = isAlphaChar c || isDigitChar c + +isHexDigitChar :: Char -> Bool +isHexDigitChar c = isHexDigit c + +isSchemeChar :: Char -> Bool +isSchemeChar c = (isAlphaNumChar c) || (c `elem` "+-.") + +alphaChar :: URIParser Char +alphaChar = satisfy isAlphaChar -- or: Parsec.letter ? + +digitChar :: URIParser Char +digitChar = satisfy isDigitChar -- or: Parsec.digit ? + +alphaNumChar :: URIParser Char +alphaNumChar = satisfy isAlphaNumChar + +hexDigitChar :: URIParser Char +hexDigitChar = satisfy isHexDigitChar -- or: Parsec.hexDigit ? + +-- Additional parser combinators for common patterns + +oneThenMany :: GenParser t s a -> GenParser t s a -> GenParser t s [a] +oneThenMany p1 pr = + do { a1 <- p1 + ; ar <- many pr + ; return (a1:ar) + } + +countMinMax :: Int -> Int -> GenParser t s a -> GenParser t s [a] +countMinMax m n p | m > 0 = + do { a1 <- p + ; ar <- countMinMax (m-1) (n-1) p + ; return (a1:ar) + } +countMinMax _ n _ | n <= 0 = return [] +countMinMax _ n p = option [] $ + do { a1 <- p + ; ar <- countMinMax 0 (n-1) p + ; return (a1:ar) + } + +notMatching :: Show a => GenParser tok st a -> GenParser tok st () +notMatching p = do { a <- try p ; unexpected (show a) } <|> return () + +------------------------------------------------------------ +-- Reconstruct a URI string +------------------------------------------------------------ +-- +-- |Turn a 'URI' into a string. +-- +-- Uses a supplied function to map the userinfo part of the URI. +-- +-- The Show instance for URI uses a mapping that hides any password +-- that may be present in the URI. Use this function with argument @id@ +-- to preserve the password in the formatted output. +-- +uriToString :: (String->String) -> URI -> ShowS +uriToString userinfomap URI { uriScheme=myscheme + , uriAuthority=myauthority + , uriPath=mypath + , uriQuery=myquery + , uriFragment=myfragment + } = + (myscheme++) . (uriAuthToString userinfomap myauthority) + . (mypath++) . (myquery++) . (myfragment++) + +uriAuthToString :: (String->String) -> (Maybe URIAuth) -> ShowS +uriAuthToString _ Nothing = id -- shows "" +uriAuthToString userinfomap + (Just URIAuth { uriUserInfo = myuinfo + , uriRegName = myregname + , uriPort = myport + } ) = + ("//"++) . (if null myuinfo then id else ((userinfomap myuinfo)++)) + . (myregname++) + . (myport++) + +------------------------------------------------------------ +-- Character classes +------------------------------------------------------------ + +-- | Returns 'True' if the character is allowed in a URI. +-- +isAllowedInURI :: Char -> Bool +isAllowedInURI c = isReserved c || isUnreserved c || c == '%' -- escape char + +-- | Returns 'True' if the character is allowed unescaped in a URI. +-- +isUnescapedInURI :: Char -> Bool +isUnescapedInURI c = isReserved c || isUnreserved c + +------------------------------------------------------------ +-- Escape sequence handling +------------------------------------------------------------ + +-- |Escape character if supplied predicate is not satisfied, +-- otherwise return character as singleton string. +-- +escapeURIChar :: (Char->Bool) -> Char -> String +escapeURIChar p c + | p c = [c] + | otherwise = '%' : myShowHex (ord c) "" + where + myShowHex :: Int -> ShowS + myShowHex n r = case showIntAtBase 16 (toChrHex) n r of + [] -> "00" + [x] -> ['0',x] + cs -> cs + toChrHex d + | d < 10 = chr (ord '0' + fromIntegral d) + | otherwise = chr (ord 'A' + fromIntegral (d - 10)) + +-- |Can be used to make a string valid for use in a URI. +-- +escapeURIString + :: (Char->Bool) -- ^ a predicate which returns 'False' + -- if the character should be escaped + -> String -- ^ the string to process + -> String -- ^ the resulting URI string +escapeURIString p s = concatMap (escapeURIChar p) s + +-- |Turns all instances of escaped characters in the string back +-- into literal characters. +-- +unEscapeString :: String -> String +unEscapeString [] = "" +unEscapeString ('%':x1:x2:s) | isHexDigit x1 && isHexDigit x2 = + chr (digitToInt x1 * 16 + digitToInt x2) : unEscapeString s +unEscapeString (c:s) = c : unEscapeString s + +------------------------------------------------------------ +-- Resolving a relative URI relative to a base URI +------------------------------------------------------------ + +-- |Returns a new 'URI' which represents the value of the +-- first 'URI' interpreted as relative to the second 'URI'. +-- For example: +-- +-- > "foo" `relativeTo` "http://bar.org/" = "http://bar.org/foo" +-- > "http:foo" `nonStrictRelativeTo` "http://bar.org/" = "http://bar.org/foo" +-- +-- Algorithm from RFC3986 [3], section 5.2.2 +-- + +nonStrictRelativeTo :: URI -> URI -> Maybe URI +nonStrictRelativeTo ref base = relativeTo ref' base + where + ref' = if uriScheme ref == uriScheme base + then ref { uriScheme="" } + else ref + +isDefined :: ( MonadPlus m, Eq (m a) ) => m a -> Bool +isDefined a = a /= mzero + +-- |Compute an absolute 'URI' for a supplied URI +-- relative to a given base. +relativeTo :: URI -> URI -> Maybe URI +relativeTo ref base + | isDefined ( uriScheme ref ) = + just_segments ref + | isDefined ( uriAuthority ref ) = + just_segments ref { uriScheme = uriScheme base } + | isDefined ( uriPath ref ) = + if (head (uriPath ref) == '/') then + just_segments ref + { uriScheme = uriScheme base + , uriAuthority = uriAuthority base + } + else + just_segments ref + { uriScheme = uriScheme base + , uriAuthority = uriAuthority base + , uriPath = mergePaths base ref + } + | isDefined ( uriQuery ref ) = + just_segments ref + { uriScheme = uriScheme base + , uriAuthority = uriAuthority base + , uriPath = uriPath base + } + | otherwise = + just_segments ref + { uriScheme = uriScheme base + , uriAuthority = uriAuthority base + , uriPath = uriPath base + , uriQuery = uriQuery base + } + where + just_segments u = + Just $ u { uriPath = removeDotSegments (uriPath u) } + mergePaths b r + | isDefined (uriAuthority b) && null pb = '/':pr + | otherwise = dropLast pb ++ pr + where + pb = uriPath b + pr = uriPath r + dropLast = fst . splitLast -- reverse . dropWhile (/='/') . reverse + +-- Remove dot segments, but protect leading '/' character +removeDotSegments :: String -> String +removeDotSegments ('/':ps) = '/':elimDots ps [] +removeDotSegments ps = elimDots ps [] + +-- Second arg accumulates segments processed so far in reverse order +elimDots :: String -> [String] -> String +-- elimDots ps rs | traceVal "\nps " ps $ traceVal "rs " rs $ False = error "" +elimDots [] [] = "" +elimDots [] rs = concat (reverse rs) +elimDots ( '.':'/':ps) rs = elimDots ps rs +elimDots ( '.':[] ) rs = elimDots [] rs +elimDots ( '.':'.':'/':ps) rs = elimDots ps (drop 1 rs) +elimDots ( '.':'.':[] ) rs = elimDots [] (drop 1 rs) +elimDots ps rs = elimDots ps1 (r:rs) + where + (r,ps1) = nextSegment ps + +-- Returns the next segment and the rest of the path from a path string. +-- Each segment ends with the next '/' or the end of string. +-- +nextSegment :: String -> (String,String) +nextSegment ps = + case break (=='/') ps of + (r,'/':ps1) -> (r++"/",ps1) + (r,_) -> (r,[]) + +-- Split last (name) segment from path, returning (path,name) +splitLast :: String -> (String,String) +splitLast p = (reverse revpath,reverse revname) + where + (revname,revpath) = break (=='/') $ reverse p + +------------------------------------------------------------ +-- Finding a URI relative to a base URI +------------------------------------------------------------ + +-- |Returns a new 'URI' which represents the relative location of +-- the first 'URI' with respect to the second 'URI'. Thus, the +-- values supplied are expected to be absolute URIs, and the result +-- returned may be a relative URI. +-- +-- Example: +-- +-- > "http://example.com/Root/sub1/name2#frag" +-- > `relativeFrom` "http://example.com/Root/sub2/name2#frag" +-- > == "../sub1/name2#frag" +-- +-- There is no single correct implementation of this function, +-- but any acceptable implementation must satisfy the following: +-- +-- > (uabs `relativeFrom` ubase) `relativeTo` ubase == uabs +-- +-- For any valid absolute URI. +-- (cf. +-- ) +-- +relativeFrom :: URI -> URI -> URI +relativeFrom uabs base + | diff uriScheme uabs base = uabs + | diff uriAuthority uabs base = uabs { uriScheme = "" } + | diff uriPath uabs base = uabs + { uriScheme = "" + , uriAuthority = Nothing + , uriPath = relPathFrom (removeBodyDotSegments $ uriPath uabs) + (removeBodyDotSegments $ uriPath base) + } + | diff uriQuery uabs base = uabs + { uriScheme = "" + , uriAuthority = Nothing + , uriPath = "" + } + | otherwise = uabs -- Always carry fragment from uabs + { uriScheme = "" + , uriAuthority = Nothing + , uriPath = "" + , uriQuery = "" + } + where + diff :: Eq b => (a -> b) -> a -> a -> Bool + diff sel u1 u2 = sel u1 /= sel u2 + -- Remove dot segments except the final segment + removeBodyDotSegments p = removeDotSegments p1 ++ p2 + where + (p1,p2) = splitLast p + +relPathFrom :: String -> String -> String +relPathFrom [] _ = "/" +relPathFrom pabs [] = pabs +relPathFrom pabs base = -- Construct a relative path segments + if sa1 == sb1 -- if the paths share a leading segment + then if (sa1 == "/") -- other than a leading '/' + then if (sa2 == sb2) + then relPathFrom1 ra2 rb2 + else pabs + else relPathFrom1 ra1 rb1 + else pabs + where + (sa1,ra1) = nextSegment pabs + (sb1,rb1) = nextSegment base + (sa2,ra2) = nextSegment ra1 + (sb2,rb2) = nextSegment rb1 + +-- relPathFrom1 strips off trailing names from the supplied paths, +-- and calls difPathFrom to find the relative path from base to +-- target +relPathFrom1 :: String -> String -> String +relPathFrom1 pabs base = relName + where + (sa,na) = splitLast pabs + (sb,nb) = splitLast base + rp = relSegsFrom sa sb + relName = if null rp then + if (na == nb) then "" + else if protect na then "./"++na + else na + else + rp++na + -- Precede name with some path if it is null or contains a ':' + protect s = null s || ':' `elem` s + +-- relSegsFrom discards any common leading segments from both paths, +-- then invokes difSegsFrom to calculate a relative path from the end +-- of the base path to the end of the target path. +-- The final name is handled separately, so this deals only with +-- "directory" segtments. +-- +relSegsFrom :: String -> String -> String +{- +relSegsFrom sabs base + | traceVal "\nrelSegsFrom\nsabs " sabs $ traceVal "base " base $ + False = error "" +-} +relSegsFrom [] [] = "" -- paths are identical +relSegsFrom sabs base = + if sa1 == sb1 + then relSegsFrom ra1 rb1 + else difSegsFrom sabs base + where + (sa1,ra1) = nextSegment sabs + (sb1,rb1) = nextSegment base + +-- difSegsFrom calculates a path difference from base to target, +-- not including the final name at the end of the path +-- (i.e. results always ends with '/') +-- +-- This function operates under the invariant that the supplied +-- value of sabs is the desired path relative to the beginning of +-- base. Thus, when base is empty, the desired path has been found. +-- +difSegsFrom :: String -> String -> String +{- +difSegsFrom sabs base + | traceVal "\ndifSegsFrom\nsabs " sabs $ traceVal "base " base $ + False = error "" +-} +difSegsFrom sabs "" = sabs +difSegsFrom sabs base = difSegsFrom ("../"++sabs) (snd $ nextSegment base) + +------------------------------------------------------------ +-- Other normalization functions +------------------------------------------------------------ + +-- |Case normalization; cf. RFC3986 section 6.2.2.1 +-- NOTE: authority case normalization is not performed +-- +normalizeCase :: String -> String +normalizeCase uristr = ncScheme uristr + where + ncScheme (':':cs) = ':':ncEscape cs + ncScheme (c:cs) | isSchemeChar c = toLower c:ncScheme cs + ncScheme _ = ncEscape uristr -- no scheme present + ncEscape ('%':h1:h2:cs) = '%':toUpper h1:toUpper h2:ncEscape cs + ncEscape (c:cs) = c:ncEscape cs + ncEscape [] = [] + +-- |Encoding normalization; cf. RFC3986 section 6.2.2.2 +-- +normalizeEscape :: String -> String +normalizeEscape ('%':h1:h2:cs) + | isHexDigit h1 && isHexDigit h2 && isUnreserved escval = + escval:normalizeEscape cs + where + escval = chr (digitToInt h1*16+digitToInt h2) +normalizeEscape (c:cs) = c:normalizeEscape cs +normalizeEscape [] = [] + +-- |Path segment normalization; cf. RFC3986 section 6.2.2.4 +-- +normalizePathSegments :: String -> String +normalizePathSegments uristr = normstr juri + where + juri = parseURI uristr + normstr Nothing = uristr + normstr (Just u) = show (normuri u) + normuri u = u { uriPath = removeDotSegments (uriPath u) } + +------------------------------------------------------------ +-- Local trace helper functions +------------------------------------------------------------ + +traceShow :: Show a => String -> a -> a +traceShow msg x = trace (msg ++ show x) x + +traceVal :: Show a => String -> a -> b -> b +traceVal msg x y = trace (msg ++ show x) y + +------------------------------------------------------------ +-- Deprecated functions +------------------------------------------------------------ + +{-# DEPRECATED parseabsoluteURI "use parseAbsoluteURI" #-} +parseabsoluteURI :: String -> Maybe URI +parseabsoluteURI = parseAbsoluteURI + +{-# DEPRECATED escapeString "use escapeURIString, and note the flipped arguments" #-} +escapeString :: String -> (Char->Bool) -> String +escapeString = flip escapeURIString + +{-# DEPRECATED reserved "use isReserved" #-} +reserved :: Char -> Bool +reserved = isReserved + +{-# DEPRECATED unreserved "use isUnreserved" #-} +unreserved :: Char -> Bool +unreserved = isUnreserved + +-- Additional component access functions for backward compatibility + +{-# DEPRECATED scheme "use uriScheme" #-} +scheme :: URI -> String +scheme = orNull init . uriScheme + +{-# DEPRECATED authority "use uriAuthority, and note changed functionality" #-} +authority :: URI -> String +authority = dropss . ($"") . uriAuthToString id . uriAuthority + where + -- Old-style authority component does not include leading '//' + dropss ('/':'/':s) = s + dropss s = s + +{-# DEPRECATED path "use uriPath" #-} +path :: URI -> String +path = uriPath + +{-# DEPRECATED query "use uriQuery, and note changed functionality" #-} +query :: URI -> String +query = orNull tail . uriQuery + +{-# DEPRECATED fragment "use uriFragment, and note changed functionality" #-} +fragment :: URI -> String +fragment = orNull tail . uriFragment + +orNull :: ([a]->[a]) -> [a] -> [a] +orNull _ [] = [] +orNull f as = f as + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2004, G. KLYNE. All rights reserved. +-- Distributed as free software under the following license. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions +-- are met: +-- +-- - Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- +-- - Neither name of the copyright holders nor the names of its +-- contributors may be used to endorse or promote products derived from +-- this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE CONTRIBUTORS +-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +-- HOLDERS OR THE CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, +-- INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, +-- BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS +-- OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +-- ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR +-- TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +-- USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- +-------------------------------------------------------------------------------- diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMainWithHooks autoconfUserHooks diff --git a/System/Random.hs b/System/Random.hs new file mode 100644 --- /dev/null +++ b/System/Random.hs @@ -0,0 +1,567 @@ +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Trustworthy #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : System.Random +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE in the 'random' repository) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- This library deals with the common task of pseudo-random number +-- generation. The library makes it possible to generate repeatable +-- results, by starting with a specified initial random number generator, +-- or to get different results on each run by using the system-initialised +-- generator or by supplying a seed from some other source. +-- +-- The library is split into two layers: +-- +-- * A core /random number generator/ provides a supply of bits. +-- The class 'RandomGen' provides a common interface to such generators. +-- The library provides one instance of 'RandomGen', the abstract +-- data type 'StdGen'. Programmers may, of course, supply their own +-- instances of 'RandomGen'. +-- +-- * The class 'Random' provides a way to extract values of a particular +-- type from a random number generator. For example, the 'Float' +-- instance of 'Random' allows one to generate random values of type +-- 'Float'. +-- +-- This implementation uses the Portable Combined Generator of L'Ecuyer +-- ["System.Random\#LEcuyer"] for 32-bit computers, transliterated by +-- Lennart Augustsson. It has a period of roughly 2.30584e18. +-- +----------------------------------------------------------------------------- + +#include "MachDeps.h" + +module System.Random + ( + + -- $intro + + -- * Random number generators + +#ifdef ENABLE_SPLITTABLEGEN + RandomGen(next, genRange) + , SplittableGen(split) +#else + RandomGen(next, genRange, split) +#endif + -- ** Standard random number generators + , StdGen + , mkStdGen + + -- ** The global random number generator + + -- $globalrng + + , getStdRandom + , getStdGen + , setStdGen + , newStdGen + + -- * Random values of various types + , Random ( random, randomR, + randoms, randomRs, + randomIO, randomRIO ) + + -- * References + -- $references + + ) where + +import Prelude + +import Data.Bits +import Data.Int +import Data.Word +import Foreign.C.Types + +#ifdef __NHC__ +import CPUTime ( getCPUTime ) +import Foreign.Ptr ( Ptr, nullPtr ) +import Foreign.C ( CTime, CUInt ) +#else +import System.CPUTime ( getCPUTime ) +import Data.Time ( getCurrentTime, UTCTime(..) ) +import Data.Ratio ( numerator, denominator ) +#endif +import Data.Char ( isSpace, chr, ord ) +import System.IO.Unsafe ( unsafePerformIO ) +import Data.IORef +import Numeric ( readDec ) + +-- The standard nhc98 implementation of Time.ClockTime does not match +-- the extended one expected in this module, so we lash-up a quick +-- replacement here. +#ifdef __NHC__ +foreign import ccall "time.h time" readtime :: Ptr CTime -> IO CTime +getTime :: IO (Integer, Integer) +getTime = do CTime t <- readtime nullPtr; return (toInteger t, 0) +#else +getTime :: IO (Integer, Integer) +getTime = do + utc <- getCurrentTime + let daytime = toRational $ utctDayTime utc + return $ quotRem (numerator daytime) (denominator daytime) +#endif + +-- | The class 'RandomGen' provides a common interface to random number +-- generators. +-- +#ifdef ENABLE_SPLITTABLEGEN +-- Minimal complete definition: 'next'. +#else +-- Minimal complete definition: 'next' and 'split'. +#endif + +class RandomGen g where + + -- |The 'next' operation returns an 'Int' that is uniformly distributed + -- in the range returned by 'genRange' (including both end points), + -- and a new generator. + next :: g -> (Int, g) + + -- |The 'genRange' operation yields the range of values returned by + -- the generator. + -- + -- It is required that: + -- + -- * If @(a,b) = 'genRange' g@, then @a < b@. + -- + -- * 'genRange' always returns a pair of defined 'Int's. + -- + -- The second condition ensures that 'genRange' cannot examine its + -- argument, and hence the value it returns can be determined only by the + -- instance of 'RandomGen'. That in turn allows an implementation to make + -- a single call to 'genRange' to establish a generator's range, without + -- being concerned that the generator returned by (say) 'next' might have + -- a different range to the generator passed to 'next'. + -- + -- The default definition spans the full range of 'Int'. + genRange :: g -> (Int,Int) + + -- default method + genRange _ = (minBound, maxBound) + +#ifdef ENABLE_SPLITTABLEGEN +-- | The class 'SplittableGen' proivides a way to specify a random number +-- generator that can be split into two new generators. +class SplittableGen g where +#endif + -- |The 'split' operation allows one to obtain two distinct random number + -- generators. This is very useful in functional programs (for example, when + -- passing a random number generator down to recursive calls), but very + -- little work has been done on statistically robust implementations of + -- 'split' (["System.Random\#Burton", "System.Random\#Hellekalek"] + -- are the only examples we know of). + split :: g -> (g, g) + +{- | +The 'StdGen' instance of 'RandomGen' has a 'genRange' of at least 30 bits. + +The result of repeatedly using 'next' should be at least as statistically +robust as the /Minimal Standard Random Number Generator/ described by +["System.Random\#Park", "System.Random\#Carta"]. +Until more is known about implementations of 'split', all we require is +that 'split' deliver generators that are (a) not identical and +(b) independently robust in the sense just given. + +The 'Show' and 'Read' instances of 'StdGen' provide a primitive way to save the +state of a random number generator. +It is required that @'read' ('show' g) == g@. + +In addition, 'reads' may be used to map an arbitrary string (not necessarily one +produced by 'show') onto a value of type 'StdGen'. In general, the 'Read' +instance of 'StdGen' has the following properties: + +* It guarantees to succeed on any string. + +* It guarantees to consume only a finite portion of the string. + +* Different argument strings are likely to result in different results. + +-} + +data StdGen + = StdGen Int32 Int32 + +instance RandomGen StdGen where + next = stdNext + genRange _ = stdRange + +#ifdef ENABLE_SPLITTABLEGEN +instance SplittableGen StdGen where +#endif + split = stdSplit + +instance Show StdGen where + showsPrec p (StdGen s1 s2) = + showsPrec p s1 . + showChar ' ' . + showsPrec p s2 + +instance Read StdGen where + readsPrec _p = \ r -> + case try_read r of + r'@[_] -> r' + _ -> [stdFromString r] -- because it shouldn't ever fail. + where + try_read r = do + (s1, r1) <- readDec (dropWhile isSpace r) + (s2, r2) <- readDec (dropWhile isSpace r1) + return (StdGen s1 s2, r2) + +{- + If we cannot unravel the StdGen from a string, create + one based on the string given. +-} +stdFromString :: String -> (StdGen, String) +stdFromString s = (mkStdGen num, rest) + where (cs, rest) = splitAt 6 s + num = foldl (\a x -> x + 3 * a) 1 (map ord cs) + + +{- | +The function 'mkStdGen' provides an alternative way of producing an initial +generator, by mapping an 'Int' into a generator. Again, distinct arguments +should be likely to produce distinct generators. +-} +mkStdGen :: Int -> StdGen -- why not Integer ? +mkStdGen s = mkStdGen32 $ fromIntegral s + +mkStdGen32 :: Int32 -> StdGen +mkStdGen32 sMaybeNegative = StdGen (s1+1) (s2+1) + where + -- We want a non-negative number, but we can't just take the abs + -- of sMaybeNegative as -minBound == minBound. + s = sMaybeNegative .&. maxBound + (q, s1) = s `divMod` 2147483562 + s2 = q `mod` 2147483398 + +createStdGen :: Integer -> StdGen +createStdGen s = mkStdGen32 $ fromIntegral s + +-- FIXME: 1/2/3 below should be ** (vs@30082002) XXX + +{- | +With a source of random number supply in hand, the 'Random' class allows the +programmer to extract random values of a variety of types. + +Minimal complete definition: 'randomR' and 'random'. + +-} + +class Random a where + -- | Takes a range /(lo,hi)/ and a random number generator + -- /g/, and returns a random value uniformly distributed in the closed + -- interval /[lo,hi]/, together with a new generator. It is unspecified + -- what happens if /lo>hi/. For continuous types there is no requirement + -- that the values /lo/ and /hi/ are ever produced, but they may be, + -- depending on the implementation and the interval. + randomR :: RandomGen g => (a,a) -> g -> (a,g) + + -- | The same as 'randomR', but using a default range determined by the type: + -- + -- * For bounded types (instances of 'Bounded', such as 'Char'), + -- the range is normally the whole type. + -- + -- * For fractional types, the range is normally the semi-closed interval + -- @[0,1)@. + -- + -- * For 'Integer', the range is (arbitrarily) the range of 'Int'. + random :: RandomGen g => g -> (a, g) + + -- | Plural variant of 'randomR', producing an infinite list of + -- random values instead of returning a new generator. + randomRs :: RandomGen g => (a,a) -> g -> [a] + randomRs ival g = x : randomRs ival g' where (x,g') = randomR ival g + + -- | Plural variant of 'random', producing an infinite list of + -- random values instead of returning a new generator. + randoms :: RandomGen g => g -> [a] + randoms g = (\(x,g') -> x : randoms g') (random g) + + -- | A variant of 'randomR' that uses the global random number generator + -- (see "System.Random#globalrng"). + randomRIO :: (a,a) -> IO a + randomRIO range = getStdRandom (randomR range) + + -- | A variant of 'random' that uses the global random number generator + -- (see "System.Random#globalrng"). + randomIO :: IO a + randomIO = getStdRandom random + + +instance Random Integer where + randomR ival g = randomIvalInteger ival g + random g = randomR (toInteger (minBound::Int), toInteger (maxBound::Int)) g + +instance Random Int where randomR = randomIvalIntegral; random = randomBounded +instance Random Int8 where randomR = randomIvalIntegral; random = randomBounded +instance Random Int16 where randomR = randomIvalIntegral; random = randomBounded +instance Random Int32 where randomR = randomIvalIntegral; random = randomBounded +instance Random Int64 where randomR = randomIvalIntegral; random = randomBounded + +#ifndef __NHC__ +-- Word is a type synonym in nhc98. +instance Random Word where randomR = randomIvalIntegral; random = randomBounded +#endif +instance Random Word8 where randomR = randomIvalIntegral; random = randomBounded +instance Random Word16 where randomR = randomIvalIntegral; random = randomBounded +instance Random Word32 where randomR = randomIvalIntegral; random = randomBounded +instance Random Word64 where randomR = randomIvalIntegral; random = randomBounded + +instance Random CChar where randomR = randomIvalIntegral; random = randomBounded +instance Random CSChar where randomR = randomIvalIntegral; random = randomBounded +instance Random CUChar where randomR = randomIvalIntegral; random = randomBounded +instance Random CShort where randomR = randomIvalIntegral; random = randomBounded +instance Random CUShort where randomR = randomIvalIntegral; random = randomBounded +instance Random CInt where randomR = randomIvalIntegral; random = randomBounded +instance Random CUInt where randomR = randomIvalIntegral; random = randomBounded +instance Random CLong where randomR = randomIvalIntegral; random = randomBounded +instance Random CULong where randomR = randomIvalIntegral; random = randomBounded +instance Random CPtrdiff where randomR = randomIvalIntegral; random = randomBounded +instance Random CSize where randomR = randomIvalIntegral; random = randomBounded +instance Random CWchar where randomR = randomIvalIntegral; random = randomBounded +instance Random CSigAtomic where randomR = randomIvalIntegral; random = randomBounded +instance Random CLLong where randomR = randomIvalIntegral; random = randomBounded +instance Random CULLong where randomR = randomIvalIntegral; random = randomBounded +instance Random CIntPtr where randomR = randomIvalIntegral; random = randomBounded +instance Random CUIntPtr where randomR = randomIvalIntegral; random = randomBounded +instance Random CIntMax where randomR = randomIvalIntegral; random = randomBounded +instance Random CUIntMax where randomR = randomIvalIntegral; random = randomBounded + +instance Random Char where + randomR (a,b) g = + case (randomIvalInteger (toInteger (ord a), toInteger (ord b)) g) of + (x,g') -> (chr x, g') + random g = randomR (minBound,maxBound) g + +instance Random Bool where + randomR (a,b) g = + case (randomIvalInteger (bool2Int a, bool2Int b) g) of + (x, g') -> (int2Bool x, g') + where + bool2Int :: Bool -> Integer + bool2Int False = 0 + bool2Int True = 1 + + int2Bool :: Int -> Bool + int2Bool 0 = False + int2Bool _ = True + + random g = randomR (minBound,maxBound) g + +{-# INLINE randomRFloating #-} +randomRFloating :: (Fractional a, Num a, Ord a, Random a, RandomGen g) => (a, a) -> g -> (a, g) +randomRFloating (l,h) g + | l>h = randomRFloating (h,l) g + | otherwise = let (coef,g') = random g in + (2.0 * (0.5*l + coef * (0.5*h - 0.5*l)), g') -- avoid overflow + +instance Random Double where + randomR = randomRFloating + random rng = + case random rng of + (x,rng') -> + -- We use 53 bits of randomness corresponding to the 53 bit significand: + ((fromIntegral (mask53 .&. (x::Int64)) :: Double) + / fromIntegral twoto53, rng') + where + twoto53 = (2::Int64) ^ (53::Int64) + mask53 = twoto53 - 1 + +instance Random Float where + randomR = randomRFloating + random rng = + -- TODO: Faster to just use 'next' IF it generates enough bits of randomness. + case random rng of + (x,rng') -> + -- We use 24 bits of randomness corresponding to the 24 bit significand: + ((fromIntegral (mask24 .&. (x::Int32)) :: Float) + / fromIntegral twoto24, rng') + -- Note, encodeFloat is another option, but I'm not seeing slightly + -- worse performance with the following [2011.06.25]: +-- (encodeFloat rand (-24), rng') + where + mask24 = twoto24 - 1 + twoto24 = (2::Int32) ^ (24::Int32) + +-- CFloat/CDouble are basically the same as a Float/Double: +instance Random CFloat where + randomR = randomRFloating + random rng = case random rng of + (x,rng') -> (realToFrac (x::Float), rng') + +instance Random CDouble where + randomR = randomRFloating + -- A MYSTERY: + -- Presently, this is showing better performance than the Double instance: + -- (And yet, if the Double instance uses randomFrac then its performance is much worse!) + random = randomFrac + -- random rng = case random rng of + -- (x,rng') -> (realToFrac (x::Double), rng') + +mkStdRNG :: Integer -> IO StdGen +mkStdRNG o = do + ct <- getCPUTime + (sec, psec) <- getTime + return (createStdGen (sec * 12345 + psec + ct + o)) + +randomBounded :: (RandomGen g, Random a, Bounded a) => g -> (a, g) +randomBounded = randomR (minBound, maxBound) + +-- The two integer functions below take an [inclusive,inclusive] range. +randomIvalIntegral :: (RandomGen g, Integral a) => (a, a) -> g -> (a, g) +randomIvalIntegral (l,h) = randomIvalInteger (toInteger l, toInteger h) + +randomIvalInteger :: (RandomGen g, Num a) => (Integer, Integer) -> g -> (a, g) +randomIvalInteger (l,h) rng + | l > h = randomIvalInteger (h,l) rng + | otherwise = case (f n 1 rng) of (v, rng') -> (fromInteger (l + v `mod` k), rng') + where + k = h - l + 1 + -- ERROR: b here (2^31-87) represents a baked-in assumption about genRange: + b = 2147483561 + n = iLogBase b k + + -- Here we loop until we've generated enough randomness to cover the range: + f 0 acc g = (acc, g) + f n' acc g = + let + (x,g') = next g + in + -- We shift over the random bits generated thusfar (* b) and add in the new ones. + f (n' - 1) (fromIntegral x + acc * b) g' + +-- The continuous functions on the other hand take an [inclusive,exclusive) range. +randomFrac :: (RandomGen g, Fractional a) => g -> (a, g) +randomFrac = randomIvalDouble (0::Double,1) realToFrac + +randomIvalDouble :: (RandomGen g, Fractional a) => (Double, Double) -> (Double -> a) -> g -> (a, g) +randomIvalDouble (l,h) fromDouble rng + | l > h = randomIvalDouble (h,l) fromDouble rng + | otherwise = + case (randomIvalInteger (toInteger (minBound::Int32), toInteger (maxBound::Int32)) rng) of + (x, rng') -> + let + scaled_x = + fromDouble (0.5*l + 0.5*h) + -- previously (l+h)/2, overflowed + fromDouble ((0.5*h - 0.5*l) / (0.5 * realToFrac int32Count)) * -- avoid overflow + fromIntegral (x::Int32) + in + (scaled_x, rng') + +int32Count :: Integer +int32Count = toInteger (maxBound::Int32) - toInteger (minBound::Int32) + 1 + +-- Perform an expensive logarithm on arbitrary-size integers by repeated division. +-- +-- (NOTE: This actually returns ceiling(log(i) base b) except with an +-- incorrect result at iLogBase b b = 2.) +iLogBase :: Integer -> Integer -> Integer +iLogBase b i = if i < b then 1 else 1 + iLogBase b (i `div` b) + +stdRange :: (Int,Int) +stdRange = (0, 2147483562) + +stdNext :: StdGen -> (Int, StdGen) +-- Returns values in the range stdRange +stdNext (StdGen s1 s2) = (fromIntegral z', StdGen s1'' s2'') + where z' = if z < 1 then z + 2147483562 else z + z = s1'' - s2'' + + k = s1 `quot` 53668 + s1' = 40014 * (s1 - k * 53668) - k * 12211 + s1'' = if s1' < 0 then s1' + 2147483563 else s1' + + k' = s2 `quot` 52774 + s2' = 40692 * (s2 - k' * 52774) - k' * 3791 + s2'' = if s2' < 0 then s2' + 2147483399 else s2' + +stdSplit :: StdGen -> (StdGen, StdGen) +stdSplit std@(StdGen s1 s2) + = (left, right) + where + -- no statistical foundation for this! + left = StdGen new_s1 t2 + right = StdGen t1 new_s2 + + new_s1 | s1 == 2147483562 = 1 + | otherwise = s1 + 1 + + new_s2 | s2 == 1 = 2147483398 + | otherwise = s2 - 1 + + StdGen t1 t2 = snd (next std) + +-- The global random number generator + +{- $globalrng #globalrng# + +There is a single, implicit, global random number generator of type +'StdGen', held in some global variable maintained by the 'IO' monad. It is +initialised automatically in some system-dependent fashion, for example, by +using the time of day, or Linux's kernel random number generator. To get +deterministic behaviour, use 'setStdGen'. +-} + +-- |Sets the global random number generator. +setStdGen :: StdGen -> IO () +setStdGen sgen = writeIORef theStdGen sgen + +-- |Gets the global random number generator. +getStdGen :: IO StdGen +getStdGen = readIORef theStdGen + +theStdGen :: IORef StdGen +theStdGen = unsafePerformIO $ do + rng <- mkStdRNG 0 + newIORef rng + +-- |Applies 'split' to the current global random generator, +-- updates it with one of the results, and returns the other. +newStdGen :: IO StdGen +newStdGen = atomicModifyIORef theStdGen split + +{- |Uses the supplied function to get a value from the current global +random generator, and updates the global generator with the new generator +returned by the function. For example, @rollDice@ gets a random integer +between 1 and 6: + +> rollDice :: IO Int +> rollDice = getStdRandom (randomR (1,6)) + +-} + +getStdRandom :: (StdGen -> (a,StdGen)) -> IO a +getStdRandom f = atomicModifyIORef theStdGen (swap . f) + where swap (v,g) = (g,v) + +{- $references + +1. FW #Burton# Burton and RL Page, /Distributed random number generation/, +Journal of Functional Programming, 2(2):203-212, April 1992. + +2. SK #Park# Park, and KW Miller, /Random number generators - +good ones are hard to find/, Comm ACM 31(10), Oct 1988, pp1192-1201. + +3. DG #Carta# Carta, /Two fast implementations of the minimal standard +random number generator/, Comm ACM, 33(1), Jan 1990, pp87-88. + +4. P #Hellekalek# Hellekalek, /Don\'t trust parallel Monte Carlo/, +Department of Mathematics, University of Salzburg, +, 1998. + +5. Pierre #LEcuyer# L'Ecuyer, /Efficient and portable combined random +number generators/, Comm ACM, 31(6), Jun 1988, pp742-749. + +The Web site is a great source of information. + +-} diff --git a/Text/Parsec.hs b/Text/Parsec.hs new file mode 100644 --- /dev/null +++ b/Text/Parsec.hs @@ -0,0 +1,36 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.Parsec +-- Copyright : (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007 +-- License : BSD-style (see the LICENSE file) +-- +-- Maintainer : derek.a.elkins@gmail.com +-- Stability : provisional +-- Portability : portable +-- +----------------------------------------------------------------------------- + +module Text.Parsec + ( module Text.Parsec.Prim + , module Text.Parsec.Char + , module Text.Parsec.Combinator + , module Text.Parsec.String + , module Text.Parsec.ByteString + , module Text.Parsec.ByteString.Lazy + , ParseError + , errorPos + , SourcePos + , SourceName, Line, Column + , sourceName, sourceLine, sourceColumn + , incSourceLine, incSourceColumn + , setSourceLine, setSourceColumn, setSourceName + ) where + +import Text.Parsec.Pos +import Text.Parsec.Error +import Text.Parsec.Prim +import Text.Parsec.Char +import Text.Parsec.Combinator +import Text.Parsec.String hiding ( Parser, GenParser, parseFromFile ) +import Text.Parsec.ByteString hiding ( Parser, GenParser, parseFromFile ) +import Text.Parsec.ByteString.Lazy hiding ( Parser, GenParser, parseFromFile ) diff --git a/Text/Parsec/ByteString.hs b/Text/Parsec/ByteString.hs new file mode 100644 --- /dev/null +++ b/Text/Parsec/ByteString.hs @@ -0,0 +1,46 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.Parsec.ByteString +-- Copyright : (c) Paolo Martini 2007 +-- License : BSD-style (see the LICENSE file) +-- +-- Maintainer : derek.a.elkins@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Make strict ByteStrings an instance of 'Stream' with 'Char' token type. +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Text.Parsec.ByteString + ( Parser, GenParser, parseFromFile + ) where + +import Text.Parsec.Error +import Text.Parsec.Prim + +import qualified Data.ByteString.Char8 as C + +instance (Monad m) => Stream C.ByteString m Char where + uncons = return . C.uncons + +type Parser = Parsec C.ByteString () +type GenParser t st = Parsec C.ByteString st + +-- | @parseFromFile p filePath@ runs a strict bytestring parser @p@ on the +-- input read from @filePath@ using 'ByteString.Char8.readFile'. Returns either a 'ParseError' +-- ('Left') or a value of type @a@ ('Right'). +-- +-- > main = do{ result <- parseFromFile numbers "digits.txt" +-- > ; case result of +-- > Left err -> print err +-- > Right xs -> print (sum xs) +-- > } + +parseFromFile :: Parser a -> String -> IO (Either ParseError a) +parseFromFile p fname + = do input <- C.readFile fname + return (runP p () fname input) diff --git a/Text/Parsec/ByteString/Lazy.hs b/Text/Parsec/ByteString/Lazy.hs new file mode 100644 --- /dev/null +++ b/Text/Parsec/ByteString/Lazy.hs @@ -0,0 +1,45 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.Parsec.ByteString.Lazy +-- Copyright : (c) Paolo Martini 2007 +-- License : BSD-style (see the LICENSE file) +-- +-- Maintainer : derek.a.elkins@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Make lazy ByteStrings an instance of 'Stream' with 'Char' token type. +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Text.Parsec.ByteString.Lazy + ( Parser, GenParser, parseFromFile + ) where + +import Text.Parsec.Error +import Text.Parsec.Prim + +import qualified Data.ByteString.Lazy.Char8 as C + +instance (Monad m) => Stream C.ByteString m Char where + uncons = return . C.uncons + +type Parser = Parsec C.ByteString () +type GenParser t st = Parsec C.ByteString st + +-- | @parseFromFile p filePath@ runs a lazy bytestring parser @p@ on the +-- input read from @filePath@ using 'ByteString.Lazy.Char8.readFile'. Returns either a 'ParseError' +-- ('Left') or a value of type @a@ ('Right'). +-- +-- > main = do{ result <- parseFromFile numbers "digits.txt" +-- > ; case result of +-- > Left err -> print err +-- > Right xs -> print (sum xs) +-- > } +parseFromFile :: Parser a -> String -> IO (Either ParseError a) +parseFromFile p fname + = do input <- C.readFile fname + return (runP p () fname input) diff --git a/Text/Parsec/Char.hs b/Text/Parsec/Char.hs new file mode 100644 --- /dev/null +++ b/Text/Parsec/Char.hs @@ -0,0 +1,135 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.Parsec.Char +-- Copyright : (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007 +-- License : BSD-style (see the LICENSE file) +-- +-- Maintainer : derek.a.elkins@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Commonly used character parsers. +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE FlexibleContexts #-} + +module Text.Parsec.Char where + +import Data.Char +import Text.Parsec.Pos +import Text.Parsec.Prim + +-- | @oneOf cs@ succeeds if the current character is in the supplied +-- list of characters @cs@. Returns the parsed character. See also +-- 'satisfy'. +-- +-- > vowel = oneOf "aeiou" + +oneOf :: (Stream s m Char) => [Char] -> ParsecT s u m Char +oneOf cs = satisfy (\c -> elem c cs) + +-- | As the dual of 'oneOf', @noneOf cs@ succeeds if the current +-- character /not/ in the supplied list of characters @cs@. Returns the +-- parsed character. +-- +-- > consonant = noneOf "aeiou" + +noneOf :: (Stream s m Char) => [Char] -> ParsecT s u m Char +noneOf cs = satisfy (\c -> not (elem c cs)) + +-- | Skips /zero/ or more white space characters. See also 'skipMany'. + +spaces :: (Stream s m Char) => ParsecT s u m () +spaces = skipMany space "white space" + +-- | Parses a white space character (any character which satisfies 'isSpace') +-- Returns the parsed character. + +space :: (Stream s m Char) => ParsecT s u m Char +space = satisfy isSpace "space" + +-- | Parses a newline character (\'\\n\'). Returns a newline character. + +newline :: (Stream s m Char) => ParsecT s u m Char +newline = char '\n' "new-line" + +-- | Parses a tab character (\'\\t\'). Returns a tab character. + +tab :: (Stream s m Char) => ParsecT s u m Char +tab = char '\t' "tab" + +-- | Parses an upper case letter (a character between \'A\' and \'Z\'). +-- Returns the parsed character. + +upper :: (Stream s m Char) => ParsecT s u m Char +upper = satisfy isUpper "uppercase letter" + +-- | Parses a lower case character (a character between \'a\' and \'z\'). +-- Returns the parsed character. + +lower :: (Stream s m Char) => ParsecT s u m Char +lower = satisfy isLower "lowercase letter" + +-- | Parses a letter or digit (a character between \'0\' and \'9\'). +-- Returns the parsed character. + +alphaNum :: (Stream s m Char => ParsecT s u m Char) +alphaNum = satisfy isAlphaNum "letter or digit" + +-- | Parses a letter (an upper case or lower case character). Returns the +-- parsed character. + +letter :: (Stream s m Char) => ParsecT s u m Char +letter = satisfy isAlpha "letter" + +-- | Parses a digit. Returns the parsed character. + +digit :: (Stream s m Char) => ParsecT s u m Char +digit = satisfy isDigit "digit" + +-- | Parses a hexadecimal digit (a digit or a letter between \'a\' and +-- \'f\' or \'A\' and \'F\'). Returns the parsed character. + +hexDigit :: (Stream s m Char) => ParsecT s u m Char +hexDigit = satisfy isHexDigit "hexadecimal digit" + +-- | Parses an octal digit (a character between \'0\' and \'7\'). Returns +-- the parsed character. + +octDigit :: (Stream s m Char) => ParsecT s u m Char +octDigit = satisfy isOctDigit "octal digit" + +-- | @char c@ parses a single character @c@. Returns the parsed +-- character (i.e. @c@). +-- +-- > semiColon = char ';' + +char :: (Stream s m Char) => Char -> ParsecT s u m Char +char c = satisfy (==c) show [c] + +-- | This parser succeeds for any character. Returns the parsed character. + +anyChar :: (Stream s m Char) => ParsecT s u m Char +anyChar = satisfy (const True) + +-- | The parser @satisfy f@ succeeds for any character for which the +-- supplied function @f@ returns 'True'. Returns the character that is +-- actually parsed. + +-- > digit = satisfy isDigit +-- > oneOf cs = satisfy (\c -> c `elem` cs) + +satisfy :: (Stream s m Char) => (Char -> Bool) -> ParsecT s u m Char +satisfy f = tokenPrim (\c -> show [c]) + (\pos c _cs -> updatePosChar pos c) + (\c -> if f c then Just c else Nothing) + +-- | @string s@ parses a sequence of characters given by @s@. Returns +-- the parsed string (i.e. @s@). +-- +-- > divOrMod = string "div" +-- > <|> string "mod" + +string :: (Stream s m Char) => String -> ParsecT s u m String +string s = tokens show updatePosString s diff --git a/Text/Parsec/Combinator.hs b/Text/Parsec/Combinator.hs new file mode 100644 --- /dev/null +++ b/Text/Parsec/Combinator.hs @@ -0,0 +1,277 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.Parsec.Combinator +-- Copyright : (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007 +-- License : BSD-style (see the LICENSE file) +-- +-- Maintainer : derek.a.elkins@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Commonly used generic combinators +-- +----------------------------------------------------------------------------- + +module Text.Parsec.Combinator + ( choice + , count + , between + , option, optionMaybe, optional + , skipMany1 + , many1 + , sepBy, sepBy1 + , endBy, endBy1 + , sepEndBy, sepEndBy1 + , chainl, chainl1 + , chainr, chainr1 + , eof, notFollowedBy + -- tricky combinators + , manyTill, lookAhead, anyToken + ) where + +import Control.Monad +import Text.Parsec.Prim + +-- | @choice ps@ tries to apply the parsers in the list @ps@ in order, +-- until one of them succeeds. Returns the value of the succeeding +-- parser. + +choice :: (Stream s m t) => [ParsecT s u m a] -> ParsecT s u m a +choice ps = foldr (<|>) mzero ps + +-- | @option x p@ tries to apply parser @p@. If @p@ fails without +-- consuming input, it returns the value @x@, otherwise the value +-- returned by @p@. +-- +-- > priority = option 0 (do{ d <- digit +-- > ; return (digitToInt d) +-- > }) + +option :: (Stream s m t) => a -> ParsecT s u m a -> ParsecT s u m a +option x p = p <|> return x + +-- | @optionMaybe p@ tries to apply parser @p@. If @p@ fails without +-- consuming input, it return 'Nothing', otherwise it returns +-- 'Just' the value returned by @p@. + +optionMaybe :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m (Maybe a) +optionMaybe p = option Nothing (liftM Just p) + +-- | @optional p@ tries to apply parser @p@. It will parse @p@ or nothing. +-- It only fails if @p@ fails after consuming input. It discards the result +-- of @p@. + +optional :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m () +optional p = do{ p; return ()} <|> return () + +-- | @between open close p@ parses @open@, followed by @p@ and @close@. +-- Returns the value returned by @p@. +-- +-- > braces = between (symbol "{") (symbol "}") + +between :: (Stream s m t) => ParsecT s u m open -> ParsecT s u m close + -> ParsecT s u m a -> ParsecT s u m a +between open close p + = do{ open; x <- p; close; return x } + +-- | @skipMany1 p@ applies the parser @p@ /one/ or more times, skipping +-- its result. + +skipMany1 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m () +skipMany1 p = do{ p; skipMany p } +{- +skipMany p = scan + where + scan = do{ p; scan } <|> return () +-} + +-- | @many1 p@ applies the parser @p@ /one/ or more times. Returns a +-- list of the returned values of @p@. +-- +-- > word = many1 letter + +many1 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m [a] +many1 p = do{ x <- p; xs <- many p; return (x:xs) } +{- +many p = scan id + where + scan f = do{ x <- p + ; scan (\tail -> f (x:tail)) + } + <|> return (f []) +-} + + +-- | @sepBy p sep@ parses /zero/ or more occurrences of @p@, separated +-- by @sep@. Returns a list of values returned by @p@. +-- +-- > commaSep p = p `sepBy` (symbol ",") + +sepBy :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a] +sepBy p sep = sepBy1 p sep <|> return [] + +-- | @sepBy1 p sep@ parses /one/ or more occurrences of @p@, separated +-- by @sep@. Returns a list of values returned by @p@. + +sepBy1 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a] +sepBy1 p sep = do{ x <- p + ; xs <- many (sep >> p) + ; return (x:xs) + } + + +-- | @sepEndBy1 p sep@ parses /one/ or more occurrences of @p@, +-- separated and optionally ended by @sep@. Returns a list of values +-- returned by @p@. + +sepEndBy1 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a] +sepEndBy1 p sep = do{ x <- p + ; do{ sep + ; xs <- sepEndBy p sep + ; return (x:xs) + } + <|> return [x] + } + +-- | @sepEndBy p sep@ parses /zero/ or more occurrences of @p@, +-- separated and optionally ended by @sep@, ie. haskell style +-- statements. Returns a list of values returned by @p@. +-- +-- > haskellStatements = haskellStatement `sepEndBy` semi + +sepEndBy :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a] +sepEndBy p sep = sepEndBy1 p sep <|> return [] + + +-- | @endBy1 p sep@ parses /one/ or more occurrences of @p@, seperated +-- and ended by @sep@. Returns a list of values returned by @p@. + +endBy1 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a] +endBy1 p sep = many1 (do{ x <- p; sep; return x }) + +-- | @endBy p sep@ parses /zero/ or more occurrences of @p@, seperated +-- and ended by @sep@. Returns a list of values returned by @p@. +-- +-- > cStatements = cStatement `endBy` semi + +endBy :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a] +endBy p sep = many (do{ x <- p; sep; return x }) + +-- | @count n p@ parses @n@ occurrences of @p@. If @n@ is smaller or +-- equal to zero, the parser equals to @return []@. Returns a list of +-- @n@ values returned by @p@. + +count :: (Stream s m t) => Int -> ParsecT s u m a -> ParsecT s u m [a] +count n p | n <= 0 = return [] + | otherwise = sequence (replicate n p) + +-- | @chainr p op x@ parser /zero/ or more occurrences of @p@, +-- separated by @op@ Returns a value obtained by a /right/ associative +-- application of all functions returned by @op@ to the values returned +-- by @p@. If there are no occurrences of @p@, the value @x@ is +-- returned. + +chainr :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m (a -> a -> a) -> a -> ParsecT s u m a +chainr p op x = chainr1 p op <|> return x + +-- | @chainl p op x@ parser /zero/ or more occurrences of @p@, +-- separated by @op@. Returns a value obtained by a /left/ associative +-- application of all functions returned by @op@ to the values returned +-- by @p@. If there are zero occurrences of @p@, the value @x@ is +-- returned. + +chainl :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m (a -> a -> a) -> a -> ParsecT s u m a +chainl p op x = chainl1 p op <|> return x + +-- | @chainl1 p op x@ parser /one/ or more occurrences of @p@, +-- separated by @op@ Returns a value obtained by a /left/ associative +-- application of all functions returned by @op@ to the values returned +-- by @p@. . This parser can for example be used to eliminate left +-- recursion which typically occurs in expression grammars. +-- +-- > expr = term `chainl1` addop +-- > term = factor `chainl1` mulop +-- > factor = parens expr <|> integer +-- > +-- > mulop = do{ symbol "*"; return (*) } +-- > <|> do{ symbol "/"; return (div) } +-- > +-- > addop = do{ symbol "+"; return (+) } +-- > <|> do{ symbol "-"; return (-) } + +chainl1 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m (a -> a -> a) -> ParsecT s u m a +chainl1 p op = do{ x <- p; rest x } + where + rest x = do{ f <- op + ; y <- p + ; rest (f x y) + } + <|> return x + +-- | @chainr1 p op x@ parser /one/ or more occurrences of |p|, +-- separated by @op@ Returns a value obtained by a /right/ associative +-- application of all functions returned by @op@ to the values returned +-- by @p@. + +chainr1 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m (a -> a -> a) -> ParsecT s u m a +chainr1 p op = scan + where + scan = do{ x <- p; rest x } + + rest x = do{ f <- op + ; y <- scan + ; return (f x y) + } + <|> return x + +----------------------------------------------------------- +-- Tricky combinators +----------------------------------------------------------- +-- | The parser @anyToken@ accepts any kind of token. It is for example +-- used to implement 'eof'. Returns the accepted token. + +anyToken :: (Stream s m t, Show t) => ParsecT s u m t +anyToken = tokenPrim show (\pos _tok _toks -> pos) Just + +-- | This parser only succeeds at the end of the input. This is not a +-- primitive parser but it is defined using 'notFollowedBy'. +-- +-- > eof = notFollowedBy anyToken "end of input" + +eof :: (Stream s m t, Show t) => ParsecT s u m () +eof = notFollowedBy anyToken "end of input" + +-- | @notFollowedBy p@ only succeeds when parser @p@ fails. This parser +-- does not consume any input. This parser can be used to implement the +-- \'longest match\' rule. For example, when recognizing keywords (for +-- example @let@), we want to make sure that a keyword is not followed +-- by a legal identifier character, in which case the keyword is +-- actually an identifier (for example @lets@). We can program this +-- behaviour as follows: +-- +-- > keywordLet = try (do{ string "let" +-- > ; notFollowedBy alphaNum +-- > }) + +notFollowedBy :: (Stream s m t, Show a) => ParsecT s u m a -> ParsecT s u m () +notFollowedBy p = try (do{ c <- try p; unexpected (show c) } + <|> return () + ) + +-- | @manyTill p end@ applies parser @p@ /zero/ or more times until +-- parser @end@ succeeds. Returns the list of values returned by @p@. +-- This parser can be used to scan comments: +-- +-- > simpleComment = do{ string "")) +-- > } +-- +-- Note the overlapping parsers @anyChar@ and @string \"-->\"@, and +-- therefore the use of the 'try' combinator. + +manyTill :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a] +manyTill p end = scan + where + scan = do{ end; return [] } + <|> + do{ x <- p; xs <- scan; return (x:xs) } diff --git a/Text/Parsec/Error.hs b/Text/Parsec/Error.hs new file mode 100644 --- /dev/null +++ b/Text/Parsec/Error.hs @@ -0,0 +1,201 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.Parsec.Error +-- Copyright : (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007 +-- License : BSD-style (see the LICENSE file) +-- +-- Maintainer : derek.a.elkins@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Parse errors +-- +----------------------------------------------------------------------------- + +module Text.Parsec.Error + ( Message ( SysUnExpect, UnExpect, Expect, Message ) + , messageString + , ParseError, errorPos, errorMessages, errorIsUnknown + , showErrorMessages + , newErrorMessage, newErrorUnknown + , addErrorMessage, setErrorPos, setErrorMessage + , mergeError + ) where + +import Data.List ( nub, sort ) + +import Text.Parsec.Pos + +-- | This abstract data type represents parse error messages. There are +-- four kinds of messages: +-- +-- > data Message = SysUnExpect String +-- > | UnExpect String +-- > | Expect String +-- > | Message String +-- +-- The fine distinction between different kinds of parse errors allows +-- the system to generate quite good error messages for the user. It +-- also allows error messages that are formatted in different +-- languages. Each kind of message is generated by different combinators: +-- +-- * A 'SysUnExpect' message is automatically generated by the +-- 'Text.Parsec.Combinator.satisfy' combinator. The argument is the +-- unexpected input. +-- +-- * A 'UnExpect' message is generated by the 'Text.Parsec.Prim.unexpected' +-- combinator. The argument describes the +-- unexpected item. +-- +-- * A 'Expect' message is generated by the 'Text.Parsec.Prim.' +-- combinator. The argument describes the expected item. +-- +-- * A 'Message' message is generated by the 'fail' +-- combinator. The argument is some general parser message. + +data Message = SysUnExpect !String -- @ library generated unexpect + | UnExpect !String -- @ unexpected something + | Expect !String -- @ expecting something + | Message !String -- @ raw message + +instance Enum Message where + fromEnum (SysUnExpect _) = 0 + fromEnum (UnExpect _) = 1 + fromEnum (Expect _) = 2 + fromEnum (Message _) = 3 + toEnum _ = error "toEnum is undefined for Message" + +-- < Return 'True' only when 'compare' would return 'EQ'. + +instance Eq Message where + + m1 == m2 = fromEnum m1 == fromEnum m2 + +-- < Compares two error messages without looking at their content. Only +-- the constructors are compared where: +-- +-- > 'SysUnExpect' < 'UnExpect' < 'Expect' < 'Message' + +instance Ord Message where + compare msg1 msg2 = compare (fromEnum msg1) (fromEnum msg2) + +-- | Extract the message string from an error message + +messageString :: Message -> String +messageString (SysUnExpect s) = s +messageString (UnExpect s) = s +messageString (Expect s) = s +messageString (Message s) = s + +-- | The abstract data type @ParseError@ represents parse errors. It +-- provides the source position ('SourcePos') of the error +-- and a list of error messages ('Message'). A @ParseError@ +-- can be returned by the function 'Text.Parsec.Prim.parse'. @ParseError@ is an +-- instance of the 'Show' class. + +data ParseError = ParseError !SourcePos [Message] + +-- | Extracts the source position from the parse error + +errorPos :: ParseError -> SourcePos +errorPos (ParseError pos _msgs) + = pos + +-- | Extracts the list of error messages from the parse error + +errorMessages :: ParseError -> [Message] +errorMessages (ParseError _pos msgs) + = sort msgs + +errorIsUnknown :: ParseError -> Bool +errorIsUnknown (ParseError _pos msgs) + = null msgs + +-- < Create parse errors + +newErrorUnknown :: SourcePos -> ParseError +newErrorUnknown pos + = ParseError pos [] + +newErrorMessage :: Message -> SourcePos -> ParseError +newErrorMessage msg pos + = ParseError pos [msg] + +addErrorMessage :: Message -> ParseError -> ParseError +addErrorMessage msg (ParseError pos msgs) + = ParseError pos (msg:msgs) + +setErrorPos :: SourcePos -> ParseError -> ParseError +setErrorPos pos (ParseError _ msgs) + = ParseError pos msgs + +setErrorMessage :: Message -> ParseError -> ParseError +setErrorMessage msg (ParseError pos msgs) + = ParseError pos (msg : filter (msg /=) msgs) + +mergeError :: ParseError -> ParseError -> ParseError +mergeError (ParseError pos1 msgs1) (ParseError pos2 msgs2) + = case pos1 `compare` pos2 of + -- select the longest match + EQ -> ParseError pos1 (msgs1 ++ msgs2) + GT -> ParseError pos1 msgs1 + LT -> ParseError pos2 msgs2 + +instance Show ParseError where + show err + = show (errorPos err) ++ ":" ++ + showErrorMessages "or" "unknown parse error" + "expecting" "unexpected" "end of input" + (errorMessages err) + +-- Language independent show function + +-- TODO +-- < The standard function for showing error messages. Formats a list of +-- error messages in English. This function is used in the |Show| +-- instance of |ParseError <#ParseError>|. The resulting string will be +-- formatted like: +-- +-- |unexpected /{The first UnExpect or a SysUnExpect message}/; +-- expecting /{comma separated list of Expect messages}/; +-- /{comma separated list of Message messages}/ + +showErrorMessages :: + String -> String -> String -> String -> String -> [Message] -> String +showErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEndOfInput msgs + | null msgs = msgUnknown + | otherwise = concat $ map ("\n"++) $ clean $ + [showSysUnExpect,showUnExpect,showExpect,showMessages] + where + (sysUnExpect,msgs1) = span ((SysUnExpect "") ==) msgs + (unExpect,msgs2) = span ((UnExpect "") ==) msgs1 + (expect,messages) = span ((Expect "") ==) msgs2 + + showExpect = showMany msgExpecting expect + showUnExpect = showMany msgUnExpected unExpect + showSysUnExpect | not (null unExpect) || + null sysUnExpect = "" + | null firstMsg = msgUnExpected ++ " " ++ msgEndOfInput + | otherwise = msgUnExpected ++ " " ++ firstMsg + where + firstMsg = messageString (head sysUnExpect) + + showMessages = showMany "" messages + + -- helpers + showMany pre msgs = case clean (map messageString msgs) of + [] -> "" + ms | null pre -> commasOr ms + | otherwise -> pre ++ " " ++ commasOr ms + + commasOr [] = "" + commasOr [m] = m + commasOr ms = commaSep (init ms) ++ " " ++ msgOr ++ " " ++ last ms + + commaSep = seperate ", " . clean + + seperate _ [] = "" + seperate _ [m] = m + seperate sep (m:ms) = m ++ sep ++ seperate sep ms + + clean = nub . filter (not . null) diff --git a/Text/Parsec/Expr.hs b/Text/Parsec/Expr.hs new file mode 100644 --- /dev/null +++ b/Text/Parsec/Expr.hs @@ -0,0 +1,166 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.Parsec.Expr +-- Copyright : (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007 +-- License : BSD-style (see the LICENSE file) +-- +-- Maintainer : derek.a.elkins@gmail.com +-- Stability : provisional +-- Portability : non-portable +-- +-- A helper module to parse \"expressions\". +-- Builds a parser given a table of operators and associativities. +-- +----------------------------------------------------------------------------- + +module Text.Parsec.Expr + ( Assoc(..), Operator(..), OperatorTable + , buildExpressionParser + ) where + +import Text.Parsec.Prim +import Text.Parsec.Combinator + +----------------------------------------------------------- +-- Assoc and OperatorTable +----------------------------------------------------------- + +-- | This data type specifies the associativity of operators: left, right +-- or none. + +data Assoc = AssocNone + | AssocLeft + | AssocRight + +-- | This data type specifies operators that work on values of type @a@. +-- An operator is either binary infix or unary prefix or postfix. A +-- binary operator has also an associated associativity. + +data Operator s u m a = Infix (ParsecT s u m (a -> a -> a)) Assoc + | Prefix (ParsecT s u m (a -> a)) + | Postfix (ParsecT s u m (a -> a)) + +-- | An @OperatorTable s u m a@ is a list of @Operator s u m a@ +-- lists. The list is ordered in descending +-- precedence. All operators in one list have the same precedence (but +-- may have a different associativity). + +type OperatorTable s u m a = [[Operator s u m a]] + +----------------------------------------------------------- +-- Convert an OperatorTable and basic term parser into +-- a full fledged expression parser +----------------------------------------------------------- + +-- | @buildExpressionParser table term@ builds an expression parser for +-- terms @term@ with operators from @table@, taking the associativity +-- and precedence specified in @table@ into account. Prefix and postfix +-- operators of the same precedence can only occur once (i.e. @--2@ is +-- not allowed if @-@ is prefix negate). Prefix and postfix operators +-- of the same precedence associate to the left (i.e. if @++@ is +-- postfix increment, than @-2++@ equals @-1@, not @-3@). +-- +-- The @buildExpressionParser@ takes care of all the complexity +-- involved in building expression parser. Here is an example of an +-- expression parser that handles prefix signs, postfix increment and +-- basic arithmetic. +-- +-- > expr = buildExpressionParser table term +-- > "expression" +-- > +-- > term = parens expr +-- > <|> natural +-- > "simple expression" +-- > +-- > table = [ [prefix "-" negate, prefix "+" id ] +-- > , [postfix "++" (+1)] +-- > , [binary "*" (*) AssocLeft, binary "/" (div) AssocLeft ] +-- > , [binary "+" (+) AssocLeft, binary "-" (-) AssocLeft ] +-- > ] +-- > +-- > binary name fun assoc = Infix (do{ reservedOp name; return fun }) assoc +-- > prefix name fun = Prefix (do{ reservedOp name; return fun }) +-- > postfix name fun = Postfix (do{ reservedOp name; return fun }) + +buildExpressionParser :: (Stream s m t) + => OperatorTable s u m a + -> ParsecT s u m a + -> ParsecT s u m a +buildExpressionParser operators simpleExpr + = foldl (makeParser) simpleExpr operators + where + makeParser term ops + = let (rassoc,lassoc,nassoc + ,prefix,postfix) = foldr splitOp ([],[],[],[],[]) ops + + rassocOp = choice rassoc + lassocOp = choice lassoc + nassocOp = choice nassoc + prefixOp = choice prefix "" + postfixOp = choice postfix "" + + ambigious assoc op= try $ + do{ op; fail ("ambiguous use of a " ++ assoc + ++ " associative operator") + } + + ambigiousRight = ambigious "right" rassocOp + ambigiousLeft = ambigious "left" lassocOp + ambigiousNon = ambigious "non" nassocOp + + termP = do{ pre <- prefixP + ; x <- term + ; post <- postfixP + ; return (post (pre x)) + } + + postfixP = postfixOp <|> return id + + prefixP = prefixOp <|> return id + + rassocP x = do{ f <- rassocOp + ; y <- do{ z <- termP; rassocP1 z } + ; return (f x y) + } + <|> ambigiousLeft + <|> ambigiousNon + -- <|> return x + + rassocP1 x = rassocP x <|> return x + + lassocP x = do{ f <- lassocOp + ; y <- termP + ; lassocP1 (f x y) + } + <|> ambigiousRight + <|> ambigiousNon + -- <|> return x + + lassocP1 x = lassocP x <|> return x + + nassocP x = do{ f <- nassocOp + ; y <- termP + ; ambigiousRight + <|> ambigiousLeft + <|> ambigiousNon + <|> return (f x y) + } + -- <|> return x + + in do{ x <- termP + ; rassocP x <|> lassocP x <|> nassocP x <|> return x + "operator" + } + + + splitOp (Infix op assoc) (rassoc,lassoc,nassoc,prefix,postfix) + = case assoc of + AssocNone -> (rassoc,lassoc,op:nassoc,prefix,postfix) + AssocLeft -> (rassoc,op:lassoc,nassoc,prefix,postfix) + AssocRight -> (op:rassoc,lassoc,nassoc,prefix,postfix) + + splitOp (Prefix op) (rassoc,lassoc,nassoc,prefix,postfix) + = (rassoc,lassoc,nassoc,op:prefix,postfix) + + splitOp (Postfix op) (rassoc,lassoc,nassoc,prefix,postfix) + = (rassoc,lassoc,nassoc,prefix,op:postfix) diff --git a/Text/Parsec/Language.hs b/Text/Parsec/Language.hs new file mode 100644 --- /dev/null +++ b/Text/Parsec/Language.hs @@ -0,0 +1,150 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.Parsec.Language +-- Copyright : (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007 +-- License : BSD-style (see the LICENSE file) +-- +-- Maintainer : derek.a.elkins@gmail.com +-- Stability : provisional +-- Portability : non-portable (uses non-portable module Text.Parsec.Token) +-- +-- A helper module that defines some language definitions that can be used +-- to instantiate a token parser (see "Text.Parsec.Token"). +-- +----------------------------------------------------------------------------- + +module Text.Parsec.Language + ( haskellDef, haskell + , mondrianDef, mondrian + , emptyDef + , haskellStyle + , javaStyle + , LanguageDef + , GenLanguageDef + ) where + +import Text.Parsec +import Text.Parsec.Token + +----------------------------------------------------------- +-- Styles: haskellStyle, javaStyle +----------------------------------------------------------- + +-- | This is a minimal token definition for Haskell style languages. It +-- defines the style of comments, valid identifiers and case +-- sensitivity. It does not define any reserved words or operators. + +haskellStyle :: LanguageDef st +haskellStyle = emptyDef + { commentStart = "{-" + , commentEnd = "-}" + , commentLine = "--" + , nestedComments = True + , identStart = letter + , identLetter = alphaNum <|> oneOf "_'" + , opStart = opLetter haskellStyle + , opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~" + , reservedOpNames= [] + , reservedNames = [] + , caseSensitive = True + } + +-- | This is a minimal token definition for Java style languages. It +-- defines the style of comments, valid identifiers and case +-- sensitivity. It does not define any reserved words or operators. + +javaStyle :: LanguageDef st +javaStyle = emptyDef + { commentStart = "/*" + , commentEnd = "*/" + , commentLine = "//" + , nestedComments = True + , identStart = letter + , identLetter = alphaNum <|> oneOf "_'" + , reservedNames = [] + , reservedOpNames= [] + , caseSensitive = False + } + +----------------------------------------------------------- +-- minimal language definition +-------------------------------------------------------- + +-- TODO: This seems wrong +-- < This is the most minimal token definition. It is recommended to use +-- this definition as the basis for other definitions. @emptyDef@ has +-- no reserved names or operators, is case sensitive and doesn't accept +-- comments, identifiers or operators. + +emptyDef :: LanguageDef st +emptyDef = LanguageDef + { commentStart = "" + , commentEnd = "" + , commentLine = "" + , nestedComments = True + , identStart = letter <|> char '_' + , identLetter = alphaNum <|> oneOf "_'" + , opStart = opLetter emptyDef + , opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~" + , reservedOpNames= [] + , reservedNames = [] + , caseSensitive = True + } + + + +----------------------------------------------------------- +-- Haskell +----------------------------------------------------------- + +-- | A lexer for the haskell language. + +haskell :: TokenParser st +haskell = makeTokenParser haskellDef + +-- | The language definition for the Haskell language. + +haskellDef :: LanguageDef st +haskellDef = haskell98Def + { identLetter = identLetter haskell98Def <|> char '#' + , reservedNames = reservedNames haskell98Def ++ + ["foreign","import","export","primitive" + ,"_ccall_","_casm_" + ,"forall" + ] + } + +-- | The language definition for the language Haskell98. + +haskell98Def :: LanguageDef st +haskell98Def = haskellStyle + { reservedOpNames= ["::","..","=","\\","|","<-","->","@","~","=>"] + , reservedNames = ["let","in","case","of","if","then","else", + "data","type", + "class","default","deriving","do","import", + "infix","infixl","infixr","instance","module", + "newtype","where", + "primitive" + -- "as","qualified","hiding" + ] + } + + +----------------------------------------------------------- +-- Mondrian +----------------------------------------------------------- + +-- | A lexer for the mondrian language. + +mondrian :: TokenParser st +mondrian = makeTokenParser mondrianDef + +-- | The language definition for the language Mondrian. + +mondrianDef :: LanguageDef st +mondrianDef = javaStyle + { reservedNames = [ "case", "class", "default", "extends" + , "import", "in", "let", "new", "of", "package" + ] + , caseSensitive = True + } diff --git a/Text/Parsec/Perm.hs b/Text/Parsec/Perm.hs new file mode 100644 --- /dev/null +++ b/Text/Parsec/Perm.hs @@ -0,0 +1,181 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.Parsec.Perm +-- Copyright : (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007 +-- License : BSD-style (see the file libraries/parsec/LICENSE) +-- +-- Maintainer : derek.a.elkins@gmail.com +-- Stability : provisional +-- Portability : non-portable (uses existentially quantified data constructors) +-- +-- This module implements permutation parsers. The algorithm used +-- is fairly complex since we push the type system to its limits :-) +-- The algorithm is described in: +-- +-- /Parsing Permutation Phrases,/ +-- by Arthur Baars, Andres Loh and Doaitse Swierstra. +-- Published as a functional pearl at the Haskell Workshop 2001. +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE ExistentialQuantification #-} + +module Text.Parsec.Perm + ( PermParser + , StreamPermParser -- abstract + + , permute + , (<||>), (<$$>) + , (<|?>), (<$?>) + ) where + +import Text.Parsec + +import Control.Monad.Identity + +infixl 1 <||>, <|?> +infixl 2 <$$>, <$?> + + +{--------------------------------------------------------------- + test -- parse a permutation of + * an optional string of 'a's + * a required 'b' + * an optional 'c' +---------------------------------------------------------------} +{- +test input + = parse (do{ x <- ptest; eof; return x }) "" input + +ptest :: Parser (String,Char,Char) +ptest + = permute $ + (,,) <$?> ("",many1 (char 'a')) + <||> char 'b' + <|?> ('_',char 'c') +-} + +{--------------------------------------------------------------- + Building a permutation parser +---------------------------------------------------------------} + +-- | The expression @perm \<||> p@ adds parser @p@ to the permutation +-- parser @perm@. The parser @p@ is not allowed to accept empty input - +-- use the optional combinator ('<|?>') instead. Returns a +-- new permutation parser that includes @p@. + +(<||>) :: (Stream s Identity tok) => StreamPermParser s st (a -> b) -> Parsec s st a -> StreamPermParser s st b +(<||>) perm p = add perm p + +-- | The expression @f \<$$> p@ creates a fresh permutation parser +-- consisting of parser @p@. The the final result of the permutation +-- parser is the function @f@ applied to the return value of @p@. The +-- parser @p@ is not allowed to accept empty input - use the optional +-- combinator ('<$?>') instead. +-- +-- If the function @f@ takes more than one parameter, the type variable +-- @b@ is instantiated to a functional type which combines nicely with +-- the adds parser @p@ to the ('<||>') combinator. This +-- results in stylized code where a permutation parser starts with a +-- combining function @f@ followed by the parsers. The function @f@ +-- gets its parameters in the order in which the parsers are specified, +-- but actual input can be in any order. + +(<$$>) :: (Stream s Identity tok) => (a -> b) -> Parsec s st a -> StreamPermParser s st b +(<$$>) f p = newperm f <||> p + +-- | The expression @perm \<||> (x,p)@ adds parser @p@ to the +-- permutation parser @perm@. The parser @p@ is optional - if it can +-- not be applied, the default value @x@ will be used instead. Returns +-- a new permutation parser that includes the optional parser @p@. + +(<|?>) :: (Stream s Identity tok) => StreamPermParser s st (a -> b) -> (a, Parsec s st a) -> StreamPermParser s st b +(<|?>) perm (x,p) = addopt perm x p + +-- | The expression @f \<$?> (x,p)@ creates a fresh permutation parser +-- consisting of parser @p@. The the final result of the permutation +-- parser is the function @f@ applied to the return value of @p@. The +-- parser @p@ is optional - if it can not be applied, the default value +-- @x@ will be used instead. + +(<$?>) :: (Stream s Identity tok) => (a -> b) -> (a, Parsec s st a) -> StreamPermParser s st b +(<$?>) f (x,p) = newperm f <|?> (x,p) + +{--------------------------------------------------------------- + The permutation tree +---------------------------------------------------------------} + +-- | Provided for backwards compatibility. The tok type is ignored. + +type PermParser tok st a = StreamPermParser String st a + +-- | The type @StreamPermParser s st a@ denotes a permutation parser that, +-- when converted by the 'permute' function, parses +-- @s@ streams with user state @st@ and returns a value of +-- type @a@ on success. +-- +-- Normally, a permutation parser is first build with special operators +-- like ('<||>') and than transformed into a normal parser +-- using 'permute'. + +data StreamPermParser s st a = Perm (Maybe a) [StreamBranch s st a] + +-- type Branch st a = StreamBranch String st a + +data StreamBranch s st a = forall b. Branch (StreamPermParser s st (b -> a)) (Parsec s st b) + +-- | The parser @permute perm@ parses a permutation of parser described +-- by @perm@. For example, suppose we want to parse a permutation of: +-- an optional string of @a@'s, the character @b@ and an optional @c@. +-- This can be described by: +-- +-- > test = permute (tuple <$?> ("",many1 (char 'a')) +-- > <||> char 'b' +-- > <|?> ('_',char 'c')) +-- > where +-- > tuple a b c = (a,b,c) + +-- transform a permutation tree into a normal parser +permute :: (Stream s Identity tok) => StreamPermParser s st a -> Parsec s st a +permute (Perm def xs) + = choice (map branch xs ++ empty) + where + empty + = case def of + Nothing -> [] + Just x -> [return x] + + branch (Branch perm p) + = do{ x <- p + ; f <- permute perm + ; return (f x) + } + +-- build permutation trees +newperm :: (Stream s Identity tok) => (a -> b) -> StreamPermParser s st (a -> b) +newperm f + = Perm (Just f) [] + +add :: (Stream s Identity tok) => StreamPermParser s st (a -> b) -> Parsec s st a -> StreamPermParser s st b +add perm@(Perm _mf fs) p + = Perm Nothing (first:map insert fs) + where + first = Branch perm p + insert (Branch perm' p') + = Branch (add (mapPerms flip perm') p) p' + +addopt :: (Stream s Identity tok) => StreamPermParser s st (a -> b) -> a -> Parsec s st a -> StreamPermParser s st b +addopt perm@(Perm mf fs) x p + = Perm (fmap ($ x) mf) (first:map insert fs) + where + first = Branch perm p + insert (Branch perm' p') + = Branch (addopt (mapPerms flip perm') x p) p' + + +mapPerms :: (Stream s Identity tok) => (a -> b) -> StreamPermParser s st a -> StreamPermParser s st b +mapPerms f (Perm x xs) + = Perm (fmap f x) (map mapBranch xs) + where + mapBranch (Branch perm p) + = Branch (mapPerms (f.) perm) p diff --git a/Text/Parsec/Pos.hs b/Text/Parsec/Pos.hs new file mode 100644 --- /dev/null +++ b/Text/Parsec/Pos.hs @@ -0,0 +1,130 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.Parsec.Pos +-- Copyright : (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007 +-- License : BSD-style (see the LICENSE file) +-- +-- Maintainer : derek.a.elkins@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Textual source positions. +-- +----------------------------------------------------------------------------- + +module Text.Parsec.Pos + ( SourceName, Line, Column + , SourcePos + , sourceLine, sourceColumn, sourceName + , incSourceLine, incSourceColumn + , setSourceLine, setSourceColumn, setSourceName + , newPos, initialPos + , updatePosChar, updatePosString + ) where + +#ifdef BASE3 +import Data.Generics +#else +import Data.Data (Data) +import Data.Typeable (Typeable) +#endif + +-- < Source positions: a file name, a line and a column +-- upper left is (1,1) + +type SourceName = String +type Line = Int +type Column = Int + +-- | The abstract data type @SourcePos@ represents source positions. It +-- contains the name of the source (i.e. file name), a line number and +-- a column number. @SourcePos@ is an instance of the 'Show', 'Eq' and +-- 'Ord' class. + +data SourcePos = SourcePos SourceName !Line !Column + deriving ( Eq, Ord, Data, Typeable) + +-- | Create a new 'SourcePos' with the given source name, +-- line number and column number. + +newPos :: SourceName -> Line -> Column -> SourcePos +newPos name line column + = SourcePos name line column + +-- | Create a new 'SourcePos' with the given source name, +-- and line number and column number set to 1, the upper left. + +initialPos :: SourceName -> SourcePos +initialPos name + = newPos name 1 1 + +-- | Extracts the name of the source from a source position. + +sourceName :: SourcePos -> SourceName +sourceName (SourcePos name _line _column) = name + +-- | Extracts the line number from a source position. + +sourceLine :: SourcePos -> Line +sourceLine (SourcePos _name line _column) = line + +-- | Extracts the column number from a source position. + +sourceColumn :: SourcePos -> Column +sourceColumn (SourcePos _name _line column) = column + +-- | Increments the line number of a source position. + +incSourceLine :: SourcePos -> Line -> SourcePos +incSourceLine (SourcePos name line column) n = SourcePos name (line+n) column + +-- | Increments the column number of a source position. + +incSourceColumn :: SourcePos -> Column -> SourcePos +incSourceColumn (SourcePos name line column) n = SourcePos name line (column+n) + +-- | Set the name of the source. + +setSourceName :: SourcePos -> SourceName -> SourcePos +setSourceName (SourcePos _name line column) n = SourcePos n line column + +-- | Set the line number of a source position. + +setSourceLine :: SourcePos -> Line -> SourcePos +setSourceLine (SourcePos name _line column) n = SourcePos name n column + +-- | Set the column number of a source position. + +setSourceColumn :: SourcePos -> Column -> SourcePos +setSourceColumn (SourcePos name line _column) n = SourcePos name line n + +-- | The expression @updatePosString pos s@ updates the source position +-- @pos@ by calling 'updatePosChar' on every character in @s@, ie. +-- @foldl updatePosChar pos string@. + +updatePosString :: SourcePos -> String -> SourcePos +updatePosString pos string + = foldl updatePosChar pos string + +-- | Update a source position given a character. If the character is a +-- newline (\'\\n\') or carriage return (\'\\r\') the line number is +-- incremented by 1. If the character is a tab (\'\t\') the column +-- number is incremented to the nearest 8'th column, ie. @column + 8 - +-- ((column-1) \`mod\` 8)@. In all other cases, the column is +-- incremented by 1. + +updatePosChar :: SourcePos -> Char -> SourcePos +updatePosChar (SourcePos name line column) c + = case c of + '\n' -> SourcePos name (line+1) 1 + '\t' -> SourcePos name line (column + 8 - ((column-1) `mod` 8)) + _ -> SourcePos name line (column + 1) + +instance Show SourcePos where + show (SourcePos name line column) + | null name = showLineColumn + | otherwise = "\"" ++ name ++ "\" " ++ showLineColumn + where + showLineColumn = "(line " ++ show line ++ + ", column " ++ show column ++ + ")" diff --git a/Text/Parsec/Prim.hs b/Text/Parsec/Prim.hs new file mode 100644 --- /dev/null +++ b/Text/Parsec/Prim.hs @@ -0,0 +1,740 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.Parsec.Prim +-- Copyright : (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007 +-- License : BSD-style (see the LICENSE file) +-- +-- Maintainer : derek.a.elkins@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- The primitive parser combinators. +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, + UndecidableInstances #-} + +module Text.Parsec.Prim + ( unknownError + , sysUnExpectError + , unexpected + , ParsecT + , runParsecT + , mkPT + , Parsec + , Consumed(..) + , Reply(..) + , State(..) + , parsecMap + , parserReturn + , parserBind + , mergeErrorReply + , parserFail + , parserZero + , parserPlus + , () + , (<|>) + , label + , labels + , lookAhead + , Stream(..) + , tokens + , try + , token + , tokenPrim + , tokenPrimEx + , many + , skipMany + , manyAccum + , runPT + , runP + , runParserT + , runParser + , parse + , parseTest + , getPosition + , getInput + , setPosition + , setInput + , getParserState + , setParserState + , updateParserState + , getState + , putState + , modifyState + , setState + , updateState + ) where + +import qualified Control.Applicative as Applicative ( Applicative(..), Alternative(..) ) +import Control.Monad() +import Control.Monad.Trans +import Control.Monad.Identity + +import Control.Monad.Reader.Class +import Control.Monad.State.Class +import Control.Monad.Cont.Class +import Control.Monad.Error.Class + +import Text.Parsec.Pos +import Text.Parsec.Error + +unknownError :: State s u -> ParseError +unknownError state = newErrorUnknown (statePos state) + +sysUnExpectError :: String -> SourcePos -> Reply s u a +sysUnExpectError msg pos = Error (newErrorMessage (SysUnExpect msg) pos) + +-- | The parser @unexpected msg@ always fails with an unexpected error +-- message @msg@ without consuming any input. +-- +-- The parsers 'fail', ('') and @unexpected@ are the three parsers +-- used to generate error messages. Of these, only ('') is commonly +-- used. For an example of the use of @unexpected@, see the definition +-- of 'Text.Parsec.Combinator.notFollowedBy'. + +unexpected :: (Stream s m t) => String -> ParsecT s u m a +unexpected msg + = ParsecT $ \s _ _ _ eerr -> + eerr $ newErrorMessage (UnExpect msg) (statePos s) + +-- | ParserT monad transformer and Parser type + +-- | @ParsecT s u m a@ is a parser with stream type @s@, user state type @u@, +-- underlying monad @m@ and return type @a@. Parsec is strict in the user state. +-- If this is undesirable, simply used a data type like @data Box a = Box a@ and +-- the state type @Box YourStateType@ to add a level of indirection. + +newtype ParsecT s u m a + = ParsecT {unParser :: forall b . + State s u + -> (a -> State s u -> ParseError -> m b) -- consumed ok + -> (ParseError -> m b) -- consumed err + -> (a -> State s u -> ParseError -> m b) -- empty ok + -> (ParseError -> m b) -- empty err + -> m b + } + +-- | Low-level unpacking of the ParsecT type. To run your parser, please look to +-- runPT, runP, runParserT, runParser and other such functions. +runParsecT :: Monad m => ParsecT s u m a -> State s u -> m (Consumed (m (Reply s u a))) +runParsecT p s = unParser p s cok cerr eok eerr + where cok a s' err = return . Consumed . return $ Ok a s' err + cerr err = return . Consumed . return $ Error err + eok a s' err = return . Empty . return $ Ok a s' err + eerr err = return . Empty . return $ Error err + +-- | Low-level creation of the ParsecT type. You really shouldn't have to do this. +mkPT :: Monad m => (State s u -> m (Consumed (m (Reply s u a)))) -> ParsecT s u m a +mkPT k = ParsecT $ \s cok cerr eok eerr -> do + cons <- k s + case cons of + Consumed mrep -> do + rep <- mrep + case rep of + Ok x s' err -> cok x s' err + Error err -> cerr err + Empty mrep -> do + rep <- mrep + case rep of + Ok x s' err -> eok x s' err + Error err -> eerr err + +type Parsec s u = ParsecT s u Identity + +data Consumed a = Consumed a + | Empty !a + +data Reply s u a = Ok a !(State s u) ParseError + | Error ParseError + +data State s u = State { + stateInput :: s, + statePos :: !SourcePos, + stateUser :: !u + } + +instance Functor Consumed where + fmap f (Consumed x) = Consumed (f x) + fmap f (Empty x) = Empty (f x) + +instance Functor (Reply s u) where + fmap f (Ok x s e) = Ok (f x) s e + fmap _ (Error e) = Error e -- XXX + +instance Functor (ParsecT s u m) where + fmap f p = parsecMap f p + +parsecMap :: (a -> b) -> ParsecT s u m a -> ParsecT s u m b +parsecMap f p + = ParsecT $ \s cok cerr eok eerr -> + unParser p s (cok . f) cerr (eok . f) eerr + +instance Applicative.Applicative (ParsecT s u m) where + pure = return + (<*>) = ap -- TODO: Can this be optimized? + +instance Applicative.Alternative (ParsecT s u m) where + empty = mzero + (<|>) = mplus + +instance Monad (ParsecT s u m) where + return x = parserReturn x + p >>= f = parserBind p f + fail msg = parserFail msg + +instance (MonadIO m) => MonadIO (ParsecT s u m) where + liftIO = lift . liftIO + +instance (MonadReader r m) => MonadReader r (ParsecT s u m) where + ask = lift ask + local f p = mkPT $ \s -> local f (runParsecT p s) + +-- I'm presuming the user might want a separate, non-backtracking +-- state aside from the Parsec user state. +instance (MonadState s m) => MonadState s (ParsecT s' u m) where + get = lift get + put = lift . put + +instance (MonadCont m) => MonadCont (ParsecT s u m) where + callCC f = mkPT $ \s -> + callCC $ \c -> + runParsecT (f (\a -> mkPT $ \s' -> c (pack s' a))) s + + where pack s a= Empty $ return (Ok a s (unknownError s)) + +instance (MonadError e m) => MonadError e (ParsecT s u m) where + throwError = lift . throwError + p `catchError` h = mkPT $ \s -> + runParsecT p s `catchError` \e -> + runParsecT (h e) s + +parserReturn :: a -> ParsecT s u m a +parserReturn x + = ParsecT $ \s _ _ eok _ -> + eok x s (unknownError s) + +parserBind :: ParsecT s u m a -> (a -> ParsecT s u m b) -> ParsecT s u m b +{-# INLINE parserBind #-} +parserBind m k + = ParsecT $ \s cok cerr eok eerr -> + let + -- consumed-okay case for m + mcok x s err = + let + -- if (k x) consumes, those go straigt up + pcok = cok + pcerr = cerr + + -- if (k x) doesn't consume input, but is okay, + -- we still return in the consumed continuation + peok x s err' = cok x s (mergeError err err') + + -- if (k x) doesn't consume input, but errors, + -- we return the error in the 'consumed-error' + -- continuation + peerr err' = cerr (mergeError err err') + in unParser (k x) s pcok pcerr peok peerr + + -- empty-ok case for m + meok x s err = + let + -- in these cases, (k x) can return as empty + pcok = cok + peok x s err' = eok x s (mergeError err err') + pcerr = cerr + peerr err' = eerr (mergeError err err') + in unParser (k x) s pcok pcerr peok peerr + -- consumed-error case for m + mcerr = cerr + + -- empty-error case for m + meerr = eerr + + in unParser m s mcok mcerr meok meerr + + +mergeErrorReply :: ParseError -> Reply s u a -> Reply s u a +mergeErrorReply err1 reply -- XXX where to put it? + = case reply of + Ok x state err2 -> Ok x state (mergeError err1 err2) + Error err2 -> Error (mergeError err1 err2) + +parserFail :: String -> ParsecT s u m a +parserFail msg + = ParsecT $ \s _ _ _ eerr -> + eerr $ newErrorMessage (Message msg) (statePos s) + +instance MonadPlus (ParsecT s u m) where + mzero = parserZero + mplus p1 p2 = parserPlus p1 p2 + +-- | @parserZero@ always fails without consuming any input. @parserZero@ is defined +-- equal to the 'mzero' member of the 'MonadPlus' class and to the 'Control.Applicative.empty' member +-- of the 'Control.Applicative.Applicative' class. + +parserZero :: ParsecT s u m a +parserZero + = ParsecT $ \s _ _ _ eerr -> + eerr $ unknownError s + +parserPlus :: ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a +{-# INLINE parserPlus #-} +parserPlus m n + = ParsecT $ \s cok cerr eok eerr -> + let + meerr err = + let + neok y s' err' = eok y s' (mergeError err err') + neerr err' = eerr $ mergeError err err' + in unParser n s cok cerr neok neerr + in unParser m s cok cerr eok meerr + +instance MonadTrans (ParsecT s u) where + lift amb = ParsecT $ \s _ _ eok _ -> do + a <- amb + eok a s $ unknownError s + +infix 0 +infixr 1 <|> + +-- | The parser @p msg@ behaves as parser @p@, but whenever the +-- parser @p@ fails /without consuming any input/, it replaces expect +-- error messages with the expect error message @msg@. +-- +-- This is normally used at the end of a set alternatives where we want +-- to return an error message in terms of a higher level construct +-- rather than returning all possible characters. For example, if the +-- @expr@ parser from the 'try' example would fail, the error +-- message is: '...: expecting expression'. Without the @(\)@ +-- combinator, the message would be like '...: expecting \"let\" or +-- letter', which is less friendly. + +() :: (ParsecT s u m a) -> String -> (ParsecT s u m a) +p msg = label p msg + +-- | This combinator implements choice. The parser @p \<|> q@ first +-- applies @p@. If it succeeds, the value of @p@ is returned. If @p@ +-- fails /without consuming any input/, parser @q@ is tried. This +-- combinator is defined equal to the 'mplus' member of the 'MonadPlus' +-- class and the ('Control.Applicative.<|>') member of 'Control.Applicative.Alternative'. +-- +-- The parser is called /predictive/ since @q@ is only tried when +-- parser @p@ didn't consume any input (i.e.. the look ahead is 1). +-- This non-backtracking behaviour allows for both an efficient +-- implementation of the parser combinators and the generation of good +-- error messages. + +(<|>) :: (ParsecT s u m a) -> (ParsecT s u m a) -> (ParsecT s u m a) +p1 <|> p2 = mplus p1 p2 + +label :: ParsecT s u m a -> String -> ParsecT s u m a +label p msg + = labels p [msg] + +labels :: ParsecT s u m a -> [String] -> ParsecT s u m a +labels p msgs = + ParsecT $ \s cok cerr eok eerr -> + let eok' x s' error = eok x s' $ if errorIsUnknown error + then error + else setExpectErrors error msgs + eerr' err = eerr $ setExpectErrors err msgs + + in unParser p s cok cerr eok' eerr' + + where + setExpectErrors err [] = setErrorMessage (Expect "") err + setExpectErrors err [msg] = setErrorMessage (Expect msg) err + setExpectErrors err (msg:msgs) + = foldr (\msg' err' -> addErrorMessage (Expect msg') err') + (setErrorMessage (Expect msg) err) msgs + +-- TODO: There should be a stronger statement that can be made about this + +-- | An instance of @Stream@ has stream type @s@, underlying monad @m@ and token type @t@ determined by the stream +-- +-- Some rough guidelines for a \"correct\" instance of Stream: +-- +-- * unfoldM uncons gives the [t] corresponding to the stream +-- +-- * A @Stream@ instance is responsible for maintaining the \"position within the stream\" in the stream state @s@. This is trivial unless you are using the monad in a non-trivial way. + +class (Monad m) => Stream s m t | s -> t where + uncons :: s -> m (Maybe (t,s)) + +tokens :: (Stream s m t, Eq t) + => ([t] -> String) -- Pretty print a list of tokens + -> (SourcePos -> [t] -> SourcePos) + -> [t] -- List of tokens to parse + -> ParsecT s u m [t] +{-# INLINE tokens #-} +tokens _ _ [] + = ParsecT $ \s _ _ eok _ -> + eok [] s $ unknownError s +tokens showTokens nextposs tts@(tok:toks) + = ParsecT $ \(State input pos u) cok cerr eok eerr -> + let + errEof = (setErrorMessage (Expect (showTokens tts)) + (newErrorMessage (SysUnExpect "") pos)) + + errExpect x = (setErrorMessage (Expect (showTokens tts)) + (newErrorMessage (SysUnExpect (showTokens [x])) pos)) + + walk [] rs = ok rs + walk (t:ts) rs = do + sr <- uncons rs + case sr of + Nothing -> cerr $ errEof + Just (x,xs) | t == x -> walk ts xs + | otherwise -> cerr $ errExpect x + + ok rs = let pos' = nextposs pos tts + s' = State rs pos' u + in cok tts s' (newErrorUnknown pos') + in do + sr <- uncons input + case sr of + Nothing -> eerr $ errEof + Just (x,xs) + | tok == x -> walk toks xs + | otherwise -> eerr $ errExpect x + +-- | The parser @try p@ behaves like parser @p@, except that it +-- pretends that it hasn't consumed any input when an error occurs. +-- +-- This combinator is used whenever arbitrary look ahead is needed. +-- Since it pretends that it hasn't consumed any input when @p@ fails, +-- the ('<|>') combinator will try its second alternative even when the +-- first parser failed while consuming input. +-- +-- The @try@ combinator can for example be used to distinguish +-- identifiers and reserved words. Both reserved words and identifiers +-- are a sequence of letters. Whenever we expect a certain reserved +-- word where we can also expect an identifier we have to use the @try@ +-- combinator. Suppose we write: +-- +-- > expr = letExpr <|> identifier "expression" +-- > +-- > letExpr = do{ string "let"; ... } +-- > identifier = many1 letter +-- +-- If the user writes \"lexical\", the parser fails with: @unexpected +-- \'x\', expecting \'t\' in \"let\"@. Indeed, since the ('<|>') combinator +-- only tries alternatives when the first alternative hasn't consumed +-- input, the @identifier@ parser is never tried (because the prefix +-- \"le\" of the @string \"let\"@ parser is already consumed). The +-- right behaviour can be obtained by adding the @try@ combinator: +-- +-- > expr = letExpr <|> identifier "expression" +-- > +-- > letExpr = do{ try (string "let"); ... } +-- > identifier = many1 letter + +try :: ParsecT s u m a -> ParsecT s u m a +try p = + ParsecT $ \s cok _ eok eerr -> + unParser p s cok eerr eok eerr + +-- | @lookAhead p@ parses @p@ without consuming any input. +-- +-- If @p@ fails and consumes some input, so does @lookAhead@. Combine with 'try' +-- if this is undesirable. + +lookAhead :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m a +lookAhead p = do{ state <- getParserState + ; x <- p' + ; setParserState state + ; return x + } + where + p' = ParsecT $ \s cok cerr eok eerr -> + unParser p s eok cerr eok eerr + +-- | The parser @tokenPrim showTok posFromTok testTok@ accepts a token @t@ +-- with result @x@ when the function @testTok t@ returns @'Just' x@. The +-- source position of the @t@ should be returned by @posFromTok t@ and +-- the token can be shown using @showTok t@. +-- +-- This combinator is expressed in terms of 'tokenPrim'. +-- It is used to accept user defined token streams. For example, +-- suppose that we have a stream of basic tokens tupled with source +-- positions. We can than define a parser that accepts single tokens as: +-- +-- > mytoken x +-- > = token showTok posFromTok testTok +-- > where +-- > showTok (pos,t) = show t +-- > posFromTok (pos,t) = pos +-- > testTok (pos,t) = if x == t then Just t else Nothing + +token :: (Stream s Identity t) + => (t -> String) -- ^ Token pretty-printing function. + -> (t -> SourcePos) -- ^ Computes the position of a token. + -> (t -> Maybe a) -- ^ Matching function for the token to parse. + -> Parsec s u a +token showToken tokpos test = tokenPrim showToken nextpos test + where + nextpos _ tok ts = case runIdentity (uncons ts) of + Nothing -> tokpos tok + Just (tok',_) -> tokpos tok' + +-- | The parser @token showTok nextPos testTok@ accepts a token @t@ +-- with result @x@ when the function @testTok t@ returns @'Just' x@. The +-- token can be shown using @showTok t@. The position of the /next/ +-- token should be returned when @nextPos@ is called with the current +-- source position @pos@, the current token @t@ and the rest of the +-- tokens @toks@, @nextPos pos t toks@. +-- +-- This is the most primitive combinator for accepting tokens. For +-- example, the 'Text.Parsec.Char.char' parser could be implemented as: +-- +-- > char c +-- > = tokenPrim showChar nextPos testChar +-- > where +-- > showChar x = "'" ++ x ++ "'" +-- > testChar x = if x == c then Just x else Nothing +-- > nextPos pos x xs = updatePosChar pos x + +tokenPrim :: (Stream s m t) + => (t -> String) -- ^ Token pretty-printing function. + -> (SourcePos -> t -> s -> SourcePos) -- ^ Next position calculating function. + -> (t -> Maybe a) -- ^ Matching function for the token to parse. + -> ParsecT s u m a +{-# INLINE tokenPrim #-} +tokenPrim showToken nextpos test = tokenPrimEx showToken nextpos Nothing test + +tokenPrimEx :: (Stream s m t) + => (t -> String) + -> (SourcePos -> t -> s -> SourcePos) + -> Maybe (SourcePos -> t -> s -> u -> u) + -> (t -> Maybe a) + -> ParsecT s u m a +{-# INLINE tokenPrimEx #-} +tokenPrimEx showToken nextpos Nothing test + = ParsecT $ \(State input pos user) cok cerr eok eerr -> do + r <- uncons input + case r of + Nothing -> eerr $ unexpectError "" pos + Just (c,cs) + -> case test c of + Just x -> let newpos = nextpos pos c cs + newstate = State cs newpos user + in seq newpos $ seq newstate $ + cok x newstate (newErrorUnknown newpos) + Nothing -> eerr $ unexpectError (showToken c) pos +tokenPrimEx showToken nextpos (Just nextState) test + = ParsecT $ \(State input pos user) cok cerr eok eerr -> do + r <- uncons input + case r of + Nothing -> eerr $ unexpectError "" pos + Just (c,cs) + -> case test c of + Just x -> let newpos = nextpos pos c cs + newUser = nextState pos c cs user + newstate = State cs newpos newUser + in seq newpos $ seq newstate $ + cok x newstate $ newErrorUnknown newpos + Nothing -> eerr $ unexpectError (showToken c) pos + +unexpectError msg pos = newErrorMessage (SysUnExpect msg) pos + + +-- | @many p@ applies the parser @p@ /zero/ or more times. Returns a +-- list of the returned values of @p@. +-- +-- > identifier = do{ c <- letter +-- > ; cs <- many (alphaNum <|> char '_') +-- > ; return (c:cs) +-- > } + +many :: ParsecT s u m a -> ParsecT s u m [a] +many p + = do xs <- manyAccum (:) p + return (reverse xs) + +-- | @skipMany p@ applies the parser @p@ /zero/ or more times, skipping +-- its result. +-- +-- > spaces = skipMany space + +skipMany :: ParsecT s u m a -> ParsecT s u m () +skipMany p + = do manyAccum (\_ _ -> []) p + return () + +manyAccum :: (a -> [a] -> [a]) + -> ParsecT s u m a + -> ParsecT s u m [a] +manyAccum acc p = + ParsecT $ \s cok cerr eok eerr -> + let walk xs x s' err = + unParser p s' + (seq xs $ walk $ acc x xs) -- consumed-ok + cerr -- consumed-err + manyErr -- empty-ok + (\e -> cok (acc x xs) s' e) -- empty-err + in unParser p s (walk []) cerr manyErr (\e -> eok [] s e) + +manyErr = error "Text.ParserCombinators.Parsec.Prim.many: combinator 'many' is applied to a parser that accepts an empty string." + + +-- < Running a parser: monadic (runPT) and pure (runP) + +runPT :: (Stream s m t) + => ParsecT s u m a -> u -> SourceName -> s -> m (Either ParseError a) +runPT p u name s + = do res <- runParsecT p (State s (initialPos name) u) + r <- parserReply res + case r of + Ok x _ _ -> return (Right x) + Error err -> return (Left err) + where + parserReply res + = case res of + Consumed r -> r + Empty r -> r + +runP :: (Stream s Identity t) + => Parsec s u a -> u -> SourceName -> s -> Either ParseError a +runP p u name s = runIdentity $ runPT p u name s + +-- | The most general way to run a parser. @runParserT p state filePath +-- input@ runs parser @p@ on the input list of tokens @input@, +-- obtained from source @filePath@ with the initial user state @st@. +-- The @filePath@ is only used in error messages and may be the empty +-- string. Returns a computation in the underlying monad @m@ that return either a 'ParseError' ('Left') or a +-- value of type @a@ ('Right'). + +runParserT :: (Stream s m t) + => ParsecT s u m a -> u -> SourceName -> s -> m (Either ParseError a) +runParserT = runPT + +-- | The most general way to run a parser over the Identity monad. @runParser p state filePath +-- input@ runs parser @p@ on the input list of tokens @input@, +-- obtained from source @filePath@ with the initial user state @st@. +-- The @filePath@ is only used in error messages and may be the empty +-- string. Returns either a 'ParseError' ('Left') or a +-- value of type @a@ ('Right'). +-- +-- > parseFromFile p fname +-- > = do{ input <- readFile fname +-- > ; return (runParser p () fname input) +-- > } + +runParser :: (Stream s Identity t) + => Parsec s u a -> u -> SourceName -> s -> Either ParseError a +runParser = runP + +-- | @parse p filePath input@ runs a parser @p@ over Identity without user +-- state. The @filePath@ is only used in error messages and may be the +-- empty string. Returns either a 'ParseError' ('Left') +-- or a value of type @a@ ('Right'). +-- +-- > main = case (parse numbers "" "11, 2, 43") of +-- > Left err -> print err +-- > Right xs -> print (sum xs) +-- > +-- > numbers = commaSep integer + +parse :: (Stream s Identity t) + => Parsec s () a -> SourceName -> s -> Either ParseError a +parse p = runP p () + +-- | The expression @parseTest p input@ applies a parser @p@ against +-- input @input@ and prints the result to stdout. Used for testing +-- parsers. + +parseTest :: (Stream s Identity t, Show a) + => Parsec s () a -> s -> IO () +parseTest p input + = case parse p "" input of + Left err -> do putStr "parse error at " + print err + Right x -> print x + +-- < Parser state combinators + +-- | Returns the current source position. See also 'SourcePos'. + +getPosition :: (Monad m) => ParsecT s u m SourcePos +getPosition = do state <- getParserState + return (statePos state) + +-- | Returns the current input + +getInput :: (Monad m) => ParsecT s u m s +getInput = do state <- getParserState + return (stateInput state) + +-- | @setPosition pos@ sets the current source position to @pos@. + +setPosition :: (Monad m) => SourcePos -> ParsecT s u m () +setPosition pos + = do updateParserState (\(State input _ user) -> State input pos user) + return () + +-- | @setInput input@ continues parsing with @input@. The 'getInput' and +-- @setInput@ functions can for example be used to deal with #include +-- files. + +setInput :: (Monad m) => s -> ParsecT s u m () +setInput input + = do updateParserState (\(State _ pos user) -> State input pos user) + return () + +-- | Returns the full parser state as a 'State' record. + +getParserState :: (Monad m) => ParsecT s u m (State s u) +getParserState = updateParserState id + +-- | @setParserState st@ set the full parser state to @st@. + +setParserState :: (Monad m) => State s u -> ParsecT s u m (State s u) +setParserState st = updateParserState (const st) + +-- | @updateParserState f@ applies function @f@ to the parser state. + +updateParserState :: (State s u -> State s u) -> ParsecT s u m (State s u) +updateParserState f = + ParsecT $ \s _ _ eok _ -> + let s' = f s + in eok s' s' $ unknownError s' + +-- < User state combinators + +-- | Returns the current user state. + +getState :: (Monad m) => ParsecT s u m u +getState = stateUser `liftM` getParserState + +-- | @putState st@ set the user state to @st@. + +putState :: (Monad m) => u -> ParsecT s u m () +putState u = do updateParserState $ \s -> s { stateUser = u } + return () + +-- | @updateState f@ applies function @f@ to the user state. Suppose +-- that we want to count identifiers in a source, we could use the user +-- state as: +-- +-- > expr = do{ x <- identifier +-- > ; updateState (+1) +-- > ; return (Id x) +-- > } + +modifyState :: (Monad m) => (u -> u) -> ParsecT s u m () +modifyState f = do updateParserState $ \s -> s { stateUser = f (stateUser s) } + return () + +-- XXX Compat + +-- | An alias for putState for backwards compatibility. + +setState :: (Monad m) => u -> ParsecT s u m () +setState = putState + +-- | An alias for modifyState for backwards compatibility. + +updateState :: (Monad m) => (u -> u) -> ParsecT s u m () +updateState = modifyState diff --git a/Text/Parsec/String.hs b/Text/Parsec/String.hs new file mode 100644 --- /dev/null +++ b/Text/Parsec/String.hs @@ -0,0 +1,45 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.Parsec.String +-- Copyright : (c) Paolo Martini 2007 +-- License : BSD-style (see the file libraries/parsec/LICENSE) +-- +-- Maintainer : derek.a.elkins@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Make Strings an instance of 'Stream' with 'Char' token type. +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Text.Parsec.String + ( Parser, GenParser, parseFromFile + ) where + +import Text.Parsec.Error +import Text.Parsec.Prim + +instance (Monad m) => Stream [tok] m tok where + uncons [] = return $ Nothing + uncons (t:ts) = return $ Just (t,ts) + {-# INLINE uncons #-} + +type Parser = Parsec String () +type GenParser tok st = Parsec [tok] st + +-- | @parseFromFile p filePath@ runs a string parser @p@ on the +-- input read from @filePath@ using 'Prelude.readFile'. Returns either a 'ParseError' +-- ('Left') or a value of type @a@ ('Right'). +-- +-- > main = do{ result <- parseFromFile numbers "digits.txt" +-- > ; case result of +-- > Left err -> print err +-- > Right xs -> print (sum xs) +-- > } +parseFromFile :: Parser a -> String -> IO (Either ParseError a) +parseFromFile p fname + = do input <- readFile fname + return (runP p () fname input) diff --git a/Text/Parsec/Text.hs b/Text/Parsec/Text.hs new file mode 100644 --- /dev/null +++ b/Text/Parsec/Text.hs @@ -0,0 +1,31 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.Parsec.String +-- Copyright : (c) Antoine Latter 2011 +-- License : BSD-style (see the file libraries/parsec/LICENSE) +-- +-- Maintainer : aslatter@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Make Text an instance of 'Stream' with 'Char' token type. +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Text.Parsec.Text + ( Parser, GenParser + ) where + +import qualified Data.Text as Text +import Text.Parsec.Error +import Text.Parsec.Prim + +instance (Monad m) => Stream Text.Text m Char where + uncons = return . Text.uncons + {-# INLINE uncons #-} + +type Parser = Parsec Text.Text () +type GenParser st = Parsec Text.Text st diff --git a/Text/Parsec/Text/Lazy.hs b/Text/Parsec/Text/Lazy.hs new file mode 100644 --- /dev/null +++ b/Text/Parsec/Text/Lazy.hs @@ -0,0 +1,31 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.Parsec.String +-- Copyright : (c) Antoine Latter 2011 +-- License : BSD-style (see the file libraries/parsec/LICENSE) +-- +-- Maintainer : aslatter@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Make Text an instance of 'Stream' with 'Char' token type. +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Text.Parsec.Text.Lazy + ( Parser, GenParser + ) where + +import qualified Data.Text.Lazy as Text +import Text.Parsec.Error +import Text.Parsec.Prim + +instance (Monad m) => Stream Text.Text m Char where + uncons = return . Text.uncons + {-# INLINE uncons #-} + +type Parser = Parsec Text.Text () +type GenParser st = Parsec Text.Text st diff --git a/Text/Parsec/Token.hs b/Text/Parsec/Token.hs new file mode 100644 --- /dev/null +++ b/Text/Parsec/Token.hs @@ -0,0 +1,722 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.Parsec.Token +-- Copyright : (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007 +-- License : BSD-style (see the LICENSE file) +-- +-- Maintainer : derek.a.elkins@gmail.com +-- Stability : provisional +-- Portability : non-portable (uses local universal quantification: PolymorphicComponents) +-- +-- A helper module to parse lexical elements (tokens). See 'makeTokenParser' +-- for a description of how to use it. +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE PolymorphicComponents #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +module Text.Parsec.Token + ( LanguageDef + , GenLanguageDef (..) + , TokenParser + , GenTokenParser (..) + , makeTokenParser + ) where + +import Data.Char ( isAlpha, toLower, toUpper, isSpace, digitToInt ) +import Data.List ( nub, sort ) +import Control.Monad.Identity +import Text.Parsec.Prim +import Text.Parsec.Char +import Text.Parsec.Combinator + +----------------------------------------------------------- +-- Language Definition +----------------------------------------------------------- + +type LanguageDef st = GenLanguageDef String st Identity + +-- | The @GenLanguageDef@ type is a record that contains all parameterizable +-- features of the 'Text.Parsec.Token' module. The module 'Text.Parsec.Language' +-- contains some default definitions. + +data GenLanguageDef s u m + = LanguageDef { + + -- | Describes the start of a block comment. Use the empty string if the + -- language doesn't support block comments. For example \"\/*\". + + commentStart :: String, + + -- | Describes the end of a block comment. Use the empty string if the + -- language doesn't support block comments. For example \"*\/\". + + commentEnd :: String, + + -- | Describes the start of a line comment. Use the empty string if the + -- language doesn't support line comments. For example \"\/\/\". + + commentLine :: String, + + -- | Set to 'True' if the language supports nested block comments. + + nestedComments :: Bool, + + -- | This parser should accept any start characters of identifiers. For + -- example @letter \<|> char \"_\"@. + + identStart :: ParsecT s u m Char, + + -- | This parser should accept any legal tail characters of identifiers. + -- For example @alphaNum \<|> char \"_\"@. + + identLetter :: ParsecT s u m Char, + + -- | This parser should accept any start characters of operators. For + -- example @oneOf \":!#$%&*+.\/\<=>?\@\\\\^|-~\"@ + + opStart :: ParsecT s u m Char, + + -- | This parser should accept any legal tail characters of operators. + -- Note that this parser should even be defined if the language doesn't + -- support user-defined operators, or otherwise the 'reservedOp' + -- parser won't work correctly. + + opLetter :: ParsecT s u m Char, + + -- | The list of reserved identifiers. + + reservedNames :: [String], + + -- | The list of reserved operators. + + reservedOpNames:: [String], + + -- | Set to 'True' if the language is case sensitive. + + caseSensitive :: Bool + + } + +----------------------------------------------------------- +-- A first class module: TokenParser +----------------------------------------------------------- + +type TokenParser st = GenTokenParser String st Identity + +-- | The type of the record that holds lexical parsers that work on +-- @s@ streams with state @u@ over a monad @m@. + +data GenTokenParser s u m + = TokenParser { + + -- | This lexeme parser parses a legal identifier. Returns the identifier + -- string. This parser will fail on identifiers that are reserved + -- words. Legal identifier (start) characters and reserved words are + -- defined in the 'LanguageDef' that is passed to + -- 'makeTokenParser'. An @identifier@ is treated as + -- a single token using 'try'. + + identifier :: ParsecT s u m String, + + -- | The lexeme parser @reserved name@ parses @symbol + -- name@, but it also checks that the @name@ is not a prefix of a + -- valid identifier. A @reserved@ word is treated as a single token + -- using 'try'. + + reserved :: String -> ParsecT s u m (), + + -- | This lexeme parser parses a legal operator. Returns the name of the + -- operator. This parser will fail on any operators that are reserved + -- operators. Legal operator (start) characters and reserved operators + -- are defined in the 'LanguageDef' that is passed to + -- 'makeTokenParser'. An @operator@ is treated as a + -- single token using 'try'. + + operator :: ParsecT s u m String, + + -- |The lexeme parser @reservedOp name@ parses @symbol + -- name@, but it also checks that the @name@ is not a prefix of a + -- valid operator. A @reservedOp@ is treated as a single token using + -- 'try'. + + reservedOp :: String -> ParsecT s u m (), + + + -- | This lexeme parser parses a single literal character. Returns the + -- literal character value. This parsers deals correctly with escape + -- sequences. The literal character is parsed according to the grammar + -- rules defined in the Haskell report (which matches most programming + -- languages quite closely). + + charLiteral :: ParsecT s u m Char, + + -- | This lexeme parser parses a literal string. Returns the literal + -- string value. This parsers deals correctly with escape sequences and + -- gaps. The literal string is parsed according to the grammar rules + -- defined in the Haskell report (which matches most programming + -- languages quite closely). + + stringLiteral :: ParsecT s u m String, + + -- | This lexeme parser parses a natural number (a positive whole + -- number). Returns the value of the number. The number can be + -- specified in 'decimal', 'hexadecimal' or + -- 'octal'. The number is parsed according to the grammar + -- rules in the Haskell report. + + natural :: ParsecT s u m Integer, + + -- | This lexeme parser parses an integer (a whole number). This parser + -- is like 'natural' except that it can be prefixed with + -- sign (i.e. \'-\' or \'+\'). Returns the value of the number. The + -- number can be specified in 'decimal', 'hexadecimal' + -- or 'octal'. The number is parsed according + -- to the grammar rules in the Haskell report. + + integer :: ParsecT s u m Integer, + + -- | This lexeme parser parses a floating point value. Returns the value + -- of the number. The number is parsed according to the grammar rules + -- defined in the Haskell report. + + float :: ParsecT s u m Double, + + -- | This lexeme parser parses either 'natural' or a 'float'. + -- Returns the value of the number. This parsers deals with + -- any overlap in the grammar rules for naturals and floats. The number + -- is parsed according to the grammar rules defined in the Haskell report. + + naturalOrFloat :: ParsecT s u m (Either Integer Double), + + -- | Parses a positive whole number in the decimal system. Returns the + -- value of the number. + + decimal :: ParsecT s u m Integer, + + -- | Parses a positive whole number in the hexadecimal system. The number + -- should be prefixed with \"0x\" or \"0X\". Returns the value of the + -- number. + + hexadecimal :: ParsecT s u m Integer, + + -- | Parses a positive whole number in the octal system. The number + -- should be prefixed with \"0o\" or \"0O\". Returns the value of the + -- number. + + octal :: ParsecT s u m Integer, + + -- | Lexeme parser @symbol s@ parses 'string' @s@ and skips + -- trailing white space. + + symbol :: String -> ParsecT s u m String, + + -- | @lexeme p@ first applies parser @p@ and than the 'whiteSpace' + -- parser, returning the value of @p@. Every lexical + -- token (lexeme) is defined using @lexeme@, this way every parse + -- starts at a point without white space. Parsers that use @lexeme@ are + -- called /lexeme/ parsers in this document. + -- + -- The only point where the 'whiteSpace' parser should be + -- called explicitly is the start of the main parser in order to skip + -- any leading white space. + -- + -- > mainParser = do{ whiteSpace + -- > ; ds <- many (lexeme digit) + -- > ; eof + -- > ; return (sum ds) + -- > } + + lexeme :: forall a. ParsecT s u m a -> ParsecT s u m a, + + -- | Parses any white space. White space consists of /zero/ or more + -- occurrences of a 'space', a line comment or a block (multi + -- line) comment. Block comments may be nested. How comments are + -- started and ended is defined in the 'LanguageDef' + -- that is passed to 'makeTokenParser'. + + whiteSpace :: ParsecT s u m (), + + -- | Lexeme parser @parens p@ parses @p@ enclosed in parenthesis, + -- returning the value of @p@. + + parens :: forall a. ParsecT s u m a -> ParsecT s u m a, + + -- | Lexeme parser @braces p@ parses @p@ enclosed in braces (\'{\' and + -- \'}\'), returning the value of @p@. + + braces :: forall a. ParsecT s u m a -> ParsecT s u m a, + + -- | Lexeme parser @angles p@ parses @p@ enclosed in angle brackets (\'\<\' + -- and \'>\'), returning the value of @p@. + + angles :: forall a. ParsecT s u m a -> ParsecT s u m a, + + -- | Lexeme parser @brackets p@ parses @p@ enclosed in brackets (\'[\' + -- and \']\'), returning the value of @p@. + + brackets :: forall a. ParsecT s u m a -> ParsecT s u m a, + + -- | DEPRECATED: Use 'brackets'. + + squares :: forall a. ParsecT s u m a -> ParsecT s u m a, + + -- | Lexeme parser |semi| parses the character \';\' and skips any + -- trailing white space. Returns the string \";\". + + semi :: ParsecT s u m String, + + -- | Lexeme parser @comma@ parses the character \',\' and skips any + -- trailing white space. Returns the string \",\". + + comma :: ParsecT s u m String, + + -- | Lexeme parser @colon@ parses the character \':\' and skips any + -- trailing white space. Returns the string \":\". + + colon :: ParsecT s u m String, + + -- | Lexeme parser @dot@ parses the character \'.\' and skips any + -- trailing white space. Returns the string \".\". + + dot :: ParsecT s u m String, + + -- | Lexeme parser @semiSep p@ parses /zero/ or more occurrences of @p@ + -- separated by 'semi'. Returns a list of values returned by + -- @p@. + + semiSep :: forall a . ParsecT s u m a -> ParsecT s u m [a], + + -- | Lexeme parser @semiSep1 p@ parses /one/ or more occurrences of @p@ + -- separated by 'semi'. Returns a list of values returned by @p@. + + semiSep1 :: forall a . ParsecT s u m a -> ParsecT s u m [a], + + -- | Lexeme parser @commaSep p@ parses /zero/ or more occurrences of + -- @p@ separated by 'comma'. Returns a list of values returned + -- by @p@. + + commaSep :: forall a . ParsecT s u m a -> ParsecT s u m [a], + + -- | Lexeme parser @commaSep1 p@ parses /one/ or more occurrences of + -- @p@ separated by 'comma'. Returns a list of values returned + -- by @p@. + + commaSep1 :: forall a . ParsecT s u m a -> ParsecT s u m [a] + } + +----------------------------------------------------------- +-- Given a LanguageDef, create a token parser. +----------------------------------------------------------- + +-- | The expression @makeTokenParser language@ creates a 'GenTokenParser' +-- record that contains lexical parsers that are +-- defined using the definitions in the @language@ record. +-- +-- The use of this function is quite stylized - one imports the +-- appropiate language definition and selects the lexical parsers that +-- are needed from the resulting 'GenTokenParser'. +-- +-- > module Main where +-- > +-- > import Text.Parsec +-- > import qualified Text.Parsec.Token as P +-- > import Text.Parsec.Language (haskellDef) +-- > +-- > -- The parser +-- > ... +-- > +-- > expr = parens expr +-- > <|> identifier +-- > <|> ... +-- > +-- > +-- > -- The lexer +-- > lexer = P.makeTokenParser haskellDef +-- > +-- > parens = P.parens lexer +-- > braces = P.braces lexer +-- > identifier = P.identifier lexer +-- > reserved = P.reserved lexer +-- > ... + +makeTokenParser :: (Stream s m Char) + => GenLanguageDef s u m -> GenTokenParser s u m +makeTokenParser languageDef + = TokenParser{ identifier = identifier + , reserved = reserved + , operator = operator + , reservedOp = reservedOp + + , charLiteral = charLiteral + , stringLiteral = stringLiteral + , natural = natural + , integer = integer + , float = float + , naturalOrFloat = naturalOrFloat + , decimal = decimal + , hexadecimal = hexadecimal + , octal = octal + + , symbol = symbol + , lexeme = lexeme + , whiteSpace = whiteSpace + + , parens = parens + , braces = braces + , angles = angles + , brackets = brackets + , squares = brackets + , semi = semi + , comma = comma + , colon = colon + , dot = dot + , semiSep = semiSep + , semiSep1 = semiSep1 + , commaSep = commaSep + , commaSep1 = commaSep1 + } + where + + ----------------------------------------------------------- + -- Bracketing + ----------------------------------------------------------- + parens p = between (symbol "(") (symbol ")") p + braces p = between (symbol "{") (symbol "}") p + angles p = between (symbol "<") (symbol ">") p + brackets p = between (symbol "[") (symbol "]") p + + semi = symbol ";" + comma = symbol "," + dot = symbol "." + colon = symbol ":" + + commaSep p = sepBy p comma + semiSep p = sepBy p semi + + commaSep1 p = sepBy1 p comma + semiSep1 p = sepBy1 p semi + + + ----------------------------------------------------------- + -- Chars & Strings + ----------------------------------------------------------- + charLiteral = lexeme (between (char '\'') + (char '\'' "end of character") + characterChar ) + "character" + + characterChar = charLetter <|> charEscape + "literal character" + + charEscape = do{ char '\\'; escapeCode } + charLetter = satisfy (\c -> (c /= '\'') && (c /= '\\') && (c > '\026')) + + + + stringLiteral = lexeme ( + do{ str <- between (char '"') + (char '"' "end of string") + (many stringChar) + ; return (foldr (maybe id (:)) "" str) + } + "literal string") + + stringChar = do{ c <- stringLetter; return (Just c) } + <|> stringEscape + "string character" + + stringLetter = satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026')) + + stringEscape = do{ char '\\' + ; do{ escapeGap ; return Nothing } + <|> do{ escapeEmpty; return Nothing } + <|> do{ esc <- escapeCode; return (Just esc) } + } + + escapeEmpty = char '&' + escapeGap = do{ many1 space + ; char '\\' "end of string gap" + } + + + + -- escape codes + escapeCode = charEsc <|> charNum <|> charAscii <|> charControl + "escape code" + + charControl = do{ char '^' + ; code <- upper + ; return (toEnum (fromEnum code - fromEnum 'A')) + } + + charNum = do{ code <- decimal + <|> do{ char 'o'; number 8 octDigit } + <|> do{ char 'x'; number 16 hexDigit } + ; return (toEnum (fromInteger code)) + } + + charEsc = choice (map parseEsc escMap) + where + parseEsc (c,code) = do{ char c; return code } + + charAscii = choice (map parseAscii asciiMap) + where + parseAscii (asc,code) = try (do{ string asc; return code }) + + + -- escape code tables + escMap = zip ("abfnrtv\\\"\'") ("\a\b\f\n\r\t\v\\\"\'") + asciiMap = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2) + + ascii2codes = ["BS","HT","LF","VT","FF","CR","SO","SI","EM", + "FS","GS","RS","US","SP"] + ascii3codes = ["NUL","SOH","STX","ETX","EOT","ENQ","ACK","BEL", + "DLE","DC1","DC2","DC3","DC4","NAK","SYN","ETB", + "CAN","SUB","ESC","DEL"] + + ascii2 = ['\BS','\HT','\LF','\VT','\FF','\CR','\SO','\SI', + '\EM','\FS','\GS','\RS','\US','\SP'] + ascii3 = ['\NUL','\SOH','\STX','\ETX','\EOT','\ENQ','\ACK', + '\BEL','\DLE','\DC1','\DC2','\DC3','\DC4','\NAK', + '\SYN','\ETB','\CAN','\SUB','\ESC','\DEL'] + + + ----------------------------------------------------------- + -- Numbers + ----------------------------------------------------------- + naturalOrFloat = lexeme (natFloat) "number" + + float = lexeme floating "float" + integer = lexeme int "integer" + natural = lexeme nat "natural" + + + -- floats + floating = do{ n <- decimal + ; fractExponent n + } + + + natFloat = do{ char '0' + ; zeroNumFloat + } + <|> decimalFloat + + zeroNumFloat = do{ n <- hexadecimal <|> octal + ; return (Left n) + } + <|> decimalFloat + <|> fractFloat 0 + <|> return (Left 0) + + decimalFloat = do{ n <- decimal + ; option (Left n) + (fractFloat n) + } + + fractFloat n = do{ f <- fractExponent n + ; return (Right f) + } + + fractExponent n = do{ fract <- fraction + ; expo <- option 1.0 exponent' + ; return ((fromInteger n + fract)*expo) + } + <|> + do{ expo <- exponent' + ; return ((fromInteger n)*expo) + } + + fraction = do{ char '.' + ; digits <- many1 digit "fraction" + ; return (foldr op 0.0 digits) + } + "fraction" + where + op d f = (f + fromIntegral (digitToInt d))/10.0 + + exponent' = do{ oneOf "eE" + ; f <- sign + ; e <- decimal "exponent" + ; return (power (f e)) + } + "exponent" + where + power e | e < 0 = 1.0/power(-e) + | otherwise = fromInteger (10^e) + + + -- integers and naturals + int = do{ f <- lexeme sign + ; n <- nat + ; return (f n) + } + + sign = (char '-' >> return negate) + <|> (char '+' >> return id) + <|> return id + + nat = zeroNumber <|> decimal + + zeroNumber = do{ char '0' + ; hexadecimal <|> octal <|> decimal <|> return 0 + } + "" + + decimal = number 10 digit + hexadecimal = do{ oneOf "xX"; number 16 hexDigit } + octal = do{ oneOf "oO"; number 8 octDigit } + + number base baseDigit + = do{ digits <- many1 baseDigit + ; let n = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 digits + ; seq n (return n) + } + + ----------------------------------------------------------- + -- Operators & reserved ops + ----------------------------------------------------------- + reservedOp name = + lexeme $ try $ + do{ string name + ; notFollowedBy (opLetter languageDef) ("end of " ++ show name) + } + + operator = + lexeme $ try $ + do{ name <- oper + ; if (isReservedOp name) + then unexpected ("reserved operator " ++ show name) + else return name + } + + oper = + do{ c <- (opStart languageDef) + ; cs <- many (opLetter languageDef) + ; return (c:cs) + } + "operator" + + isReservedOp name = + isReserved (sort (reservedOpNames languageDef)) name + + + ----------------------------------------------------------- + -- Identifiers & Reserved words + ----------------------------------------------------------- + reserved name = + lexeme $ try $ + do{ caseString name + ; notFollowedBy (identLetter languageDef) ("end of " ++ show name) + } + + caseString name + | caseSensitive languageDef = string name + | otherwise = do{ walk name; return name } + where + walk [] = return () + walk (c:cs) = do{ caseChar c msg; walk cs } + + caseChar c | isAlpha c = char (toLower c) <|> char (toUpper c) + | otherwise = char c + + msg = show name + + + identifier = + lexeme $ try $ + do{ name <- ident + ; if (isReservedName name) + then unexpected ("reserved word " ++ show name) + else return name + } + + + ident + = do{ c <- identStart languageDef + ; cs <- many (identLetter languageDef) + ; return (c:cs) + } + "identifier" + + isReservedName name + = isReserved theReservedNames caseName + where + caseName | caseSensitive languageDef = name + | otherwise = map toLower name + + + isReserved names name + = scan names + where + scan [] = False + scan (r:rs) = case (compare r name) of + LT -> scan rs + EQ -> True + GT -> False + + theReservedNames + | caseSensitive languageDef = sort reserved + | otherwise = sort . map (map toLower) $ reserved + where + reserved = reservedNames languageDef + + + + ----------------------------------------------------------- + -- White space & symbols + ----------------------------------------------------------- + symbol name + = lexeme (string name) + + lexeme p + = do{ x <- p; whiteSpace; return x } + + + --whiteSpace + whiteSpace + | noLine && noMulti = skipMany (simpleSpace "") + | noLine = skipMany (simpleSpace <|> multiLineComment "") + | noMulti = skipMany (simpleSpace <|> oneLineComment "") + | otherwise = skipMany (simpleSpace <|> oneLineComment <|> multiLineComment "") + where + noLine = null (commentLine languageDef) + noMulti = null (commentStart languageDef) + + + simpleSpace = + skipMany1 (satisfy isSpace) + + oneLineComment = + do{ try (string (commentLine languageDef)) + ; skipMany (satisfy (/= '\n')) + ; return () + } + + multiLineComment = + do { try (string (commentStart languageDef)) + ; inComment + } + + inComment + | nestedComments languageDef = inCommentMulti + | otherwise = inCommentSingle + + inCommentMulti + = do{ try (string (commentEnd languageDef)) ; return () } + <|> do{ multiLineComment ; inCommentMulti } + <|> do{ skipMany1 (noneOf startEnd) ; inCommentMulti } + <|> do{ oneOf startEnd ; inCommentMulti } + "end of comment" + where + startEnd = nub (commentEnd languageDef ++ commentStart languageDef) + + inCommentSingle + = do{ try (string (commentEnd languageDef)); return () } + <|> do{ skipMany1 (noneOf startEnd) ; inCommentSingle } + <|> do{ oneOf startEnd ; inCommentSingle } + "end of comment" + where + startEnd = nub (commentEnd languageDef ++ commentStart languageDef) diff --git a/Text/ParserCombinators/Parsec.hs b/Text/ParserCombinators/Parsec.hs new file mode 100644 --- /dev/null +++ b/Text/ParserCombinators/Parsec.hs @@ -0,0 +1,41 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.ParserCombinators.Parsec +-- Copyright : (c) Paolo Martini 2007 +-- License : BSD-style (see the LICENSE file) +-- +-- Maintainer : derek.a.elkins@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Parsec compatibility module +-- +----------------------------------------------------------------------------- + +module Text.ParserCombinators.Parsec + ( -- complete modules + module Text.ParserCombinators.Parsec.Prim + , module Text.ParserCombinators.Parsec.Combinator + , module Text.ParserCombinators.Parsec.Char + + -- module Text.ParserCombinators.Parsec.Error + , ParseError + , errorPos + + -- module Text.ParserCombinators.Parsec.Pos + , SourcePos + , SourceName, Line, Column + , sourceName, sourceLine, sourceColumn + , incSourceLine, incSourceColumn + , setSourceLine, setSourceColumn, setSourceName + + ) where + +import Text.Parsec.String() + +import Text.ParserCombinators.Parsec.Prim +import Text.ParserCombinators.Parsec.Combinator +import Text.ParserCombinators.Parsec.Char + +import Text.ParserCombinators.Parsec.Error +import Text.ParserCombinators.Parsec.Pos diff --git a/Text/ParserCombinators/Parsec/Char.hs b/Text/ParserCombinators/Parsec/Char.hs new file mode 100644 --- /dev/null +++ b/Text/ParserCombinators/Parsec/Char.hs @@ -0,0 +1,40 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.ParserCombinators.Parsec.Char +-- Copyright : (c) Paolo Martini 2007 +-- License : BSD-style (see the LICENSE file) +-- +-- Maintainer : derek.a.elkins@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Parsec compatibility module +-- +----------------------------------------------------------------------------- + +module Text.ParserCombinators.Parsec.Char + ( CharParser, + spaces, + space, + newline, + tab, + upper, + lower, + alphaNum, + letter, + digit, + hexDigit, + octDigit, + char, + string, + anyChar, + oneOf, + noneOf, + satisfy + ) where + + +import Text.Parsec.Char +import Text.Parsec.String + +type CharParser st = GenParser Char st diff --git a/Text/ParserCombinators/Parsec/Combinator.hs b/Text/ParserCombinators/Parsec/Combinator.hs new file mode 100644 --- /dev/null +++ b/Text/ParserCombinators/Parsec/Combinator.hs @@ -0,0 +1,42 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.ParserCombinators.Parsec.Combinator +-- Copyright : (c) Paolo Martini 2007 +-- License : BSD-style (see the LICENSE file) +-- +-- Maintainer : derek.a.elkins@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Parsec compatibility module +-- +----------------------------------------------------------------------------- + +module Text.ParserCombinators.Parsec.Combinator + ( choice, + count, + between, + option, + optionMaybe, + optional, + skipMany1, + many1, + sepBy, + sepBy1, + endBy, + endBy1, + sepEndBy, + sepEndBy1, + chainl, + chainl1, + chainr, + chainr1, + eof, + notFollowedBy, + manyTill, + lookAhead, + anyToken + ) where + + +import Text.Parsec.Combinator diff --git a/Text/ParserCombinators/Parsec/Error.hs b/Text/ParserCombinators/Parsec/Error.hs new file mode 100644 --- /dev/null +++ b/Text/ParserCombinators/Parsec/Error.hs @@ -0,0 +1,40 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.ParserCombinators.Parsec.Error +-- Copyright : (c) Paolo Martini 2007 +-- License : BSD-style (see the LICENSE file) +-- +-- Maintainer : derek.a.elkins@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Parsec compatibility module +-- +----------------------------------------------------------------------------- + +module Text.ParserCombinators.Parsec.Error + ( Message (SysUnExpect,UnExpect,Expect,Message), + messageString, + messageCompare, + messageEq, + ParseError, + errorPos, + errorMessages, + errorIsUnknown, + showErrorMessages, + newErrorMessage, + newErrorUnknown, + addErrorMessage, + setErrorPos, + setErrorMessage, + mergeError + ) where + +import Text.Parsec.Error + + +messageCompare :: Message -> Message -> Ordering +messageCompare = compare + +messageEq :: Message -> Message -> Bool +messageEq = (==) diff --git a/Text/ParserCombinators/Parsec/Expr.hs b/Text/ParserCombinators/Parsec/Expr.hs new file mode 100644 --- /dev/null +++ b/Text/ParserCombinators/Parsec/Expr.hs @@ -0,0 +1,42 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.ParserCombinators.Parsec.Expr +-- Copyright : (c) Paolo Martini 2007 +-- License : BSD-style (see the LICENSE file) +-- +-- Maintainer : derek.a.elkins@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Parsec compatibility module +-- +----------------------------------------------------------------------------- + +module Text.ParserCombinators.Parsec.Expr + ( Assoc (AssocNone,AssocLeft,AssocRight), + Operator(..), + OperatorTable, + buildExpressionParser + ) where + +import Text.Parsec.Expr(Assoc(..)) +import qualified Text.Parsec.Expr as N +import Text.ParserCombinators.Parsec(GenParser) + +import Control.Monad.Identity + +data Operator tok st a = Infix (GenParser tok st (a -> a -> a)) Assoc + | Prefix (GenParser tok st (a -> a)) + | Postfix (GenParser tok st (a -> a)) + +type OperatorTable tok st a = [[Operator tok st a]] + +convert :: Operator tok st a -> N.Operator [tok] st Identity a +convert (Infix p a) = N.Infix p a +convert (Prefix p) = N.Prefix p +convert (Postfix p) = N.Postfix p + +buildExpressionParser :: OperatorTable tok st a + -> GenParser tok st a + -> GenParser tok st a +buildExpressionParser = N.buildExpressionParser . map (map convert) diff --git a/Text/ParserCombinators/Parsec/Language.hs b/Text/ParserCombinators/Parsec/Language.hs new file mode 100644 --- /dev/null +++ b/Text/ParserCombinators/Parsec/Language.hs @@ -0,0 +1,28 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.ParserCombinators.Parsec.Language +-- Copyright : (c) Paolo Martini 2007 +-- License : BSD-style (see the LICENSE file) +-- +-- Maintainer : derek.a.elkins@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Parsec compatibility module +-- +----------------------------------------------------------------------------- + +module Text.ParserCombinators.Parsec.Language + ( haskellDef, + haskell, + mondrianDef, + mondrian, + emptyDef, + haskellStyle, + javaStyle, + LanguageDef, + GenLanguageDef(..), + ) where + +import Text.Parsec.Token +import Text.Parsec.Language diff --git a/Text/ParserCombinators/Parsec/Perm.hs b/Text/ParserCombinators/Parsec/Perm.hs new file mode 100644 --- /dev/null +++ b/Text/ParserCombinators/Parsec/Perm.hs @@ -0,0 +1,24 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.ParserCombinators.Parsec.Perm +-- Copyright : (c) Paolo Martini 2007 +-- License : BSD-style (see the LICENSE file) +-- +-- Maintainer : derek.a.elkins@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Parsec compatibility module +-- +----------------------------------------------------------------------------- + +module Text.ParserCombinators.Parsec.Perm + ( PermParser, + permute, + (<||>), + (<$$>), + (<|?>), + (<$?>) + ) where + +import Text.Parsec.Perm diff --git a/Text/ParserCombinators/Parsec/Pos.hs b/Text/ParserCombinators/Parsec/Pos.hs new file mode 100644 --- /dev/null +++ b/Text/ParserCombinators/Parsec/Pos.hs @@ -0,0 +1,35 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.ParserCombinators.Parsec.Pos +-- Copyright : (c) Paolo Martini 2007 +-- License : BSD-style (see the LICENSE file) +-- +-- Maintainer : derek.a.elkins@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Parsec compatibility module +-- +----------------------------------------------------------------------------- + +module Text.ParserCombinators.Parsec.Pos + ( SourceName, + Line, + Column, + SourcePos, + sourceLine, + sourceColumn, + sourceName, + incSourceLine, + incSourceColumn, + setSourceLine, + setSourceColumn, + setSourceName, + newPos, + initialPos, + updatePosChar, + updatePosString + ) where + + +import Text.Parsec.Pos diff --git a/Text/ParserCombinators/Parsec/Prim.hs b/Text/ParserCombinators/Parsec/Prim.hs new file mode 100644 --- /dev/null +++ b/Text/ParserCombinators/Parsec/Prim.hs @@ -0,0 +1,65 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.ParserCombinators.Parsec.Prim +-- Copyright : (c) Paolo Martini 2007 +-- License : BSD-style (see the LICENSE file) +-- +-- Maintainer : derek.a.elkins@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Parsec compatibility module +-- +----------------------------------------------------------------------------- + +module Text.ParserCombinators.Parsec.Prim + ( (), + (<|>), + Parser, + GenParser, + runParser, + parse, + parseFromFile, + parseTest, + token, + tokens, + tokenPrim, + tokenPrimEx, + try, + label, + labels, + unexpected, + pzero, + many, + skipMany, + getState, + setState, + updateState, + getPosition, + setPosition, + getInput, + setInput, + State(..), + getParserState, + setParserState + ) where + +import Text.Parsec.Prim hiding (runParser, try) +import qualified Text.Parsec.Prim as N -- 'N' for 'New' +import Text.Parsec.String + +import Text.Parsec.Error +import Text.Parsec.Pos + +pzero :: GenParser tok st a +pzero = parserZero + +runParser :: GenParser tok st a + -> st + -> SourceName + -> [tok] + -> Either ParseError a +runParser = N.runParser + +try :: GenParser tok st a -> GenParser tok st a +try = N.try diff --git a/Text/ParserCombinators/Parsec/Token.hs b/Text/ParserCombinators/Parsec/Token.hs new file mode 100644 --- /dev/null +++ b/Text/ParserCombinators/Parsec/Token.hs @@ -0,0 +1,23 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.ParserCombinators.Parsec.Token +-- Copyright : (c) Paolo Martini 2007 +-- License : BSD-style (see the LICENSE file) +-- +-- Maintainer : derek.a.elkins@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Parsec compatibility module +-- +----------------------------------------------------------------------------- + +module Text.ParserCombinators.Parsec.Token + ( LanguageDef, + GenLanguageDef(..), + TokenParser, + GenTokenParser(..), + makeTokenParser + ) where + +import Text.Parsec.Token diff --git a/cabal-install-bundle.cabal b/cabal-install-bundle.cabal new file mode 100644 --- /dev/null +++ b/cabal-install-bundle.cabal @@ -0,0 +1,205 @@ +Name: cabal-install-bundle +Version: 0.10.2 +Synopsis: The (bundled) command-line interface for Cabal and Hackage. +Description: This is cabal-install with bundled dependencies. Easier to bootstrap. +License: BSD3 +Maintainer: paczesiowa@gmail.com +Category: Distribution +build-type: Configure +Cabal-Version: >= 1.8 +extra-tmp-files: + config.log config.status autom4te.cache network.buildinfo + include/HsNetworkConfig.h +extra-source-files: + config.guess config.sub install-sh + configure.ac configure network.buildinfo.in + include/HsNetworkConfig.h.in include/HsNet.h + -- C sources only used on some systems + cbits/ancilData.c cbits/asyncAccept.c cbits/initWinSock.c + cbits/winSockErr.c + cbits/crc32.h cbits/inffast.h cbits/inflate.h + cbits/trees.h cbits/deflate.h cbits/inffixed.h + cbits/inftrees.h cbits/zutil.h + +Executable cabal + Main-Is: Main.hs + ghc-options: -Wall + include-dirs: include + includes: HsNet.h zlib.h + install-includes: HsNet.h HsNetworkConfig.h + extra-libraries: z + c-sources: cbits/HsNet.c + Other-Modules: + System.Random + Codec.Compression.GZip, + Codec.Compression.Zlib, + Codec.Compression.Zlib.Raw, + Codec.Compression.Zlib.Internal + Codec.Compression.Zlib.Stream + Control.Monad.Cont + Control.Monad.Cont.Class + Control.Monad.Error + Control.Monad.Error.Class + Control.Monad.Identity + Control.Monad.List + Control.Monad.RWS + Control.Monad.RWS.Class + Control.Monad.RWS.Lazy + Control.Monad.RWS.Strict + Control.Monad.Reader + Control.Monad.Reader.Class + Control.Monad.State + Control.Monad.State.Class + Control.Monad.State.Lazy + Control.Monad.State.Strict + Control.Monad.Trans + Control.Monad.Writer + Control.Monad.Writer.Class + Control.Monad.Writer.Lazy + Control.Monad.Writer.Strict + Control.Applicative.Backwards + Control.Applicative.Lift + Control.Monad.IO.Class + Control.Monad.Trans.Class + Control.Monad.Trans.Cont + Control.Monad.Trans.Error + Control.Monad.Trans.Identity + Control.Monad.Trans.List + Control.Monad.Trans.Maybe + Control.Monad.Trans.Reader + Control.Monad.Trans.RWS + Control.Monad.Trans.RWS.Lazy + Control.Monad.Trans.RWS.Strict + Control.Monad.Trans.State + Control.Monad.Trans.State.Lazy + Control.Monad.Trans.State.Strict + Control.Monad.Trans.Writer + Control.Monad.Trans.Writer.Lazy + Control.Monad.Trans.Writer.Strict + Data.Functor.Compose + Data.Functor.Constant + Data.Functor.Identity + Data.Functor.Product + Data.Functor.Reverse + Text.Parsec, + Text.Parsec.String, + Text.Parsec.ByteString, + Text.Parsec.ByteString.Lazy, + Text.Parsec.Text, + Text.Parsec.Text.Lazy, + Text.Parsec.Pos, + Text.Parsec.Error, + Text.Parsec.Prim, + Text.Parsec.Char, + Text.Parsec.Combinator, + Text.Parsec.Token, + Text.Parsec.Expr, + Text.Parsec.Language, + Text.Parsec.Perm, + Text.ParserCombinators.Parsec, + Text.ParserCombinators.Parsec.Char, + Text.ParserCombinators.Parsec.Combinator, + Text.ParserCombinators.Parsec.Error, + Text.ParserCombinators.Parsec.Expr, + Text.ParserCombinators.Parsec.Language, + Text.ParserCombinators.Parsec.Perm, + Text.ParserCombinators.Parsec.Pos, + Text.ParserCombinators.Parsec.Prim, + Text.ParserCombinators.Parsec.Token + Network + Network.BSD + Network.Socket + Network.Socket.ByteString + Network.Socket.ByteString.Lazy + Network.Socket.Internal + Network.URI + Network.Socket.ByteString.Internal + Network.Socket.ByteString.IOVec + Network.Socket.ByteString.MsgHdr + Network.BufferType, + Network.Stream, + Network.StreamDebugger, + Network.StreamSocket, + Network.TCP, + Network.HTTP, + Network.HTTP.Headers, + Network.HTTP.Base, + Network.HTTP.Stream, + Network.HTTP.Auth, + Network.HTTP.Cookie, + Network.HTTP.Proxy, + Network.HTTP.HandleStream, + Network.Browser + Network.HTTP.Base64, + Network.HTTP.MD5Aux, + Network.HTTP.Utils + Distribution.Client.BuildReports.Anonymous + Distribution.Client.BuildReports.Storage + Distribution.Client.BuildReports.Types + Distribution.Client.BuildReports.Upload + Distribution.Client.Check + Distribution.Client.Config + Distribution.Client.Configure + Distribution.Client.Dependency + Distribution.Client.Dependency.TopDown + Distribution.Client.Dependency.TopDown.Constraints + Distribution.Client.Dependency.TopDown.Types + Distribution.Client.Dependency.Types + Distribution.Client.Dependency.Modular + Distribution.Client.Dependency.Modular.Assignment + Distribution.Client.Dependency.Modular.Builder + Distribution.Client.Dependency.Modular.Configured + Distribution.Client.Dependency.Modular.ConfiguredConversion + Distribution.Client.Dependency.Modular.Dependency + Distribution.Client.Dependency.Modular.Explore + Distribution.Client.Dependency.Modular.Flag + Distribution.Client.Dependency.Modular.Index + Distribution.Client.Dependency.Modular.IndexConversion + Distribution.Client.Dependency.Modular.Log + Distribution.Client.Dependency.Modular.Message + Distribution.Client.Dependency.Modular.Package + Distribution.Client.Dependency.Modular.Preference + Distribution.Client.Dependency.Modular.PSQ + Distribution.Client.Dependency.Modular.Solver + Distribution.Client.Dependency.Modular.Tree + Distribution.Client.Dependency.Modular.Validate + Distribution.Client.Dependency.Modular.Version + Distribution.Client.Fetch + Distribution.Client.FetchUtils + Distribution.Client.GZipUtils + Distribution.Client.Haddock + Distribution.Client.HttpUtils + Distribution.Client.IndexUtils + Distribution.Client.Init + Distribution.Client.Init.Heuristics + Distribution.Client.Init.Licenses + Distribution.Client.Init.Types + Distribution.Client.Install + Distribution.Client.InstallPlan + Distribution.Client.InstallSymlink + Distribution.Client.List + Distribution.Client.PackageIndex + Distribution.Client.PackageUtils + 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 + Paths_cabal_install_bundle + + build-depends: base >= 2 && < 99, Cabal >= 1.10, filepath, time, process, directory, pretty, containers, array, old-time, bytestring, unix + + extensions: CPP, DeriveDataTypeable, ForeignFunctionInterface, TypeSynonymInstances, ExistentialQuantification, PolymorphicComponents, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, DeriveDataTypeable, FunctionalDependencies + +source-repository head + type: git + location: git://github.com/Paczesiowa/cabal-install-bundle.git diff --git a/cbits/HsNet.c b/cbits/HsNet.c new file mode 100644 --- /dev/null +++ b/cbits/HsNet.c @@ -0,0 +1,8 @@ +/* ----------------------------------------------------------------------------- + * (c) The University of Glasgow 2002 + * + * static versions of the inline functions from HsNet.h + * -------------------------------------------------------------------------- */ + +#define INLINE +#include "HsNet.h" diff --git a/cbits/ancilData.c b/cbits/ancilData.c new file mode 100644 --- /dev/null +++ b/cbits/ancilData.c @@ -0,0 +1,237 @@ +/* + * Copyright(c), 2002 The GHC Team. + */ + +#ifdef aix_HOST_OS +#define _LINUX_SOURCE_COMPAT +// Required to get CMSG_SPACE/CMSG_LEN macros. See #265. +// Alternative is to #define COMPAT_43 and use the +// HAVE_STRUCT_MSGHDR_MSG_ACCRIGHTS code instead, but that means +// fiddling with the configure script too. +#endif + +#include "HsNet.h" +#include + +#if HAVE_STRUCT_MSGHDR_MSG_CONTROL || HAVE_STRUCT_MSGHDR_MSG_ACCRIGHTS /* until end */ + +/* + * Support for transmitting file descriptors. + * + * + */ + + +/* + * sendmsg() and recvmsg() wrappers for transmitting + * ancillary socket data. + * + * Doesn't provide the full generality of either, specifically: + * + * - no support for scattered read/writes. + * - only possible to send one ancillary chunk of data at a time. + * + * + * NOTE: recv/sendAncillary() is being phased out in preference + * of the more specific send/recvFd(), as the latter is + * really the only application of recv/sendAncillary() and + * stand the chance of being supported on platforms that + * don't have send/recvmsg() (but do have ioctl() support + * for this kind of thing, for instance.) + * + */ + +int +sendFd(int sock, + int outfd) +{ + struct msghdr msg = {0}; + struct iovec iov[1]; + char buf[2]; +#if HAVE_STRUCT_MSGHDR_MSG_ACCRIGHTS + msg.msg_accrights = (void*)&outfd; + msg.msg_accrightslen = sizeof(int); +#else + struct cmsghdr *cmsg; + char ancBuffer[CMSG_SPACE(sizeof(int))]; + char* dPtr; + + msg.msg_control = ancBuffer; + msg.msg_controllen = sizeof(ancBuffer); + + cmsg = CMSG_FIRSTHDR(&msg); + cmsg->cmsg_level = SOL_SOCKET; + cmsg->cmsg_type = SCM_RIGHTS; + cmsg->cmsg_len = CMSG_LEN(sizeof(int)); + dPtr = (char*)CMSG_DATA(cmsg); + + *(int*)dPtr = outfd; + msg.msg_controllen = cmsg->cmsg_len; +#endif + + buf[0] = 0; buf[1] = '\0'; + iov[0].iov_base = buf; + iov[0].iov_len = 2; + + msg.msg_iov = iov; + msg.msg_iovlen = 1; + + return sendmsg(sock,&msg,0); +} + +int +sendAncillary(int sock, + int level, + int type, + int flags, + void* data, + int len) +{ + struct msghdr msg = {0}; + struct iovec iov[1]; + char buf[2]; +#if HAVE_STRUCT_MSGHDR_MSG_ACCRIGHTS + /* Contains the older BSD msghdr fields only, so no room + for 'type' or 'level' data. + */ + msg.msg_accrights = data; + msg.msg_accrightslen=len; +#else + struct cmsghdr *cmsg; + char ancBuffer[CMSG_SPACE(len)]; + char* dPtr; + + msg.msg_control = ancBuffer; + msg.msg_controllen = sizeof(ancBuffer); + + cmsg = CMSG_FIRSTHDR(&msg); + cmsg->cmsg_level = level; + cmsg->cmsg_type = type; + cmsg->cmsg_len = CMSG_LEN(len); + dPtr = (char*)CMSG_DATA(cmsg); + + memcpy(dPtr, data, len); + msg.msg_controllen = cmsg->cmsg_len; +#endif + buf[0] = 0; buf[1] = '\0'; + iov[0].iov_base = buf; + iov[0].iov_len = 2; + + msg.msg_iov = iov; + msg.msg_iovlen = 1; + + return sendmsg(sock,&msg,flags); +} + +int +recvFd(int sock) +{ + struct msghdr msg = {0}; + char duffBuf[10]; + int rc; + int len = sizeof(int); + struct iovec iov[1]; +#if HAVE_STRUCT_MSGHDR_MSG_CONTROL + struct cmsghdr *cmsg = NULL; + struct cmsghdr *cptr; +#else + int* fdBuffer; +#endif + + iov[0].iov_base = duffBuf; + iov[0].iov_len = sizeof(duffBuf); + msg.msg_iov = iov; + msg.msg_iovlen = 1; + +#if HAVE_STRUCT_MSGHDR_MSG_CONTROL + cmsg = (struct cmsghdr*)malloc(CMSG_SPACE(len)); + if (cmsg==NULL) { + return -1; + } + + msg.msg_control = (void *)cmsg; + msg.msg_controllen = CMSG_LEN(len); +#else + fdBuffer = (int*)malloc(len); + if (fdBuffer) { + msg.msg_accrights = (void *)fdBuffer; + } else { + return -1; + } + msg.msg_accrightslen = len; +#endif + + if ((rc = recvmsg(sock,&msg,0)) < 0) { + return rc; + } + +#if HAVE_STRUCT_MSGHDR_MSG_CONTROL + cptr = (struct cmsghdr*)CMSG_FIRSTHDR(&msg); + return *(int*)CMSG_DATA(cptr); +#else + return *(int*)fdBuffer; +#endif +} + + +int +recvAncillary(int sock, + int* pLevel, + int* pType, + int flags, + void** pData, + int* pLen) +{ + struct msghdr msg = {0}; + char duffBuf[10]; + int rc; + struct iovec iov[1]; +#if HAVE_STRUCT_MSGHDR_MSG_CONTROL + struct cmsghdr *cmsg = NULL; + struct cmsghdr *cptr; +#endif + + iov[0].iov_base = duffBuf; + iov[0].iov_len = sizeof(duffBuf); + msg.msg_iov = iov; + msg.msg_iovlen = 1; + +#if HAVE_STRUCT_MSGHDR_MSG_CONTROL + cmsg = (struct cmsghdr*)malloc(CMSG_SPACE(*pLen)); + if (cmsg==NULL) { + return -1; + } + + msg.msg_control = (void *)cmsg; + msg.msg_controllen = CMSG_LEN(*pLen); +#else + *pData = (void*)malloc(*pLen); + if (*pData) { + msg.msg_accrights = *pData; + } else { + return -1; + } + msg.msg_accrightslen = *pLen; +#endif + + if ((rc = recvmsg(sock,&msg,flags)) < 0) { + return rc; + } + +#if HAVE_STRUCT_MSGHDR_MSG_CONTROL + cptr = (struct cmsghdr*)CMSG_FIRSTHDR(&msg); + + *pLevel = cptr->cmsg_level; + *pType = cptr->cmsg_type; + /* The length of the data portion only */ + *pLen = cptr->cmsg_len - sizeof(struct cmsghdr); + *pData = CMSG_DATA(cptr); +#else + /* Sensible defaults, I hope.. */ + *pLevel = 0; + *pType = 0; +#endif + + return rc; +} +#endif diff --git a/cbits/asyncAccept.c b/cbits/asyncAccept.c new file mode 100644 --- /dev/null +++ b/cbits/asyncAccept.c @@ -0,0 +1,72 @@ +/* + * (c) sof, 2003. + */ + +#include "HsNet.h" +#include "HsFFI.h" + +#if defined(HAVE_WINSOCK2_H) && !defined(__CYGWIN__) && !defined(__HUGS__) + +/* all the way to the end */ + +/* + * To support non-blocking accept()s with WinSock, we use the asyncDoProc# + * primop, which lets a Haskell thread call an external routine without + * blocking the progress of other threads. + * + * As can readily be seen, this is a low-level mechanism. + * + */ + +typedef struct AcceptData { + int fdSock; + int newSock; + void* sockAddr; + int size; +} AcceptData; + +/* + * Fill in parameter block that's passed along when the RTS invokes the + * accept()-calling proc below (acceptDoProc()) + */ +void* +newAcceptParams(int sock, + int sz, + void* sockaddr) +{ + AcceptData* data = (AcceptData*)malloc(sizeof(AcceptData)); + if (!data) return NULL; + data->fdSock = sock; + data->newSock = 0; + data->sockAddr = sockaddr; + data->size = sz; + + return data; +} + +/* Accessors for return code and accept()'s socket result. */ + +int +acceptNewSock(void* d) +{ + return (((AcceptData*)d)->newSock); +} + +/* Routine invoked by an RTS worker thread */ +int +acceptDoProc(void* param) +{ + SOCKET s; + + AcceptData* data = (AcceptData*)param; + s = accept( data->fdSock, + data->sockAddr, + &data->size); + data->newSock = s; + if ( s == INVALID_SOCKET ) { + return GetLastError(); + } else { + return 0; + } +} +#endif diff --git a/cbits/crc32.h b/cbits/crc32.h new file mode 100644 --- /dev/null +++ b/cbits/crc32.h @@ -0,0 +1,441 @@ +/* crc32.h -- tables for rapid CRC calculation + * Generated automatically by crc32.c + */ + +local const unsigned long FAR crc_table[TBLS][256] = +{ + { + 0x00000000UL, 0x77073096UL, 0xee0e612cUL, 0x990951baUL, 0x076dc419UL, + 0x706af48fUL, 0xe963a535UL, 0x9e6495a3UL, 0x0edb8832UL, 0x79dcb8a4UL, + 0xe0d5e91eUL, 0x97d2d988UL, 0x09b64c2bUL, 0x7eb17cbdUL, 0xe7b82d07UL, + 0x90bf1d91UL, 0x1db71064UL, 0x6ab020f2UL, 0xf3b97148UL, 0x84be41deUL, + 0x1adad47dUL, 0x6ddde4ebUL, 0xf4d4b551UL, 0x83d385c7UL, 0x136c9856UL, + 0x646ba8c0UL, 0xfd62f97aUL, 0x8a65c9ecUL, 0x14015c4fUL, 0x63066cd9UL, + 0xfa0f3d63UL, 0x8d080df5UL, 0x3b6e20c8UL, 0x4c69105eUL, 0xd56041e4UL, + 0xa2677172UL, 0x3c03e4d1UL, 0x4b04d447UL, 0xd20d85fdUL, 0xa50ab56bUL, + 0x35b5a8faUL, 0x42b2986cUL, 0xdbbbc9d6UL, 0xacbcf940UL, 0x32d86ce3UL, + 0x45df5c75UL, 0xdcd60dcfUL, 0xabd13d59UL, 0x26d930acUL, 0x51de003aUL, + 0xc8d75180UL, 0xbfd06116UL, 0x21b4f4b5UL, 0x56b3c423UL, 0xcfba9599UL, + 0xb8bda50fUL, 0x2802b89eUL, 0x5f058808UL, 0xc60cd9b2UL, 0xb10be924UL, + 0x2f6f7c87UL, 0x58684c11UL, 0xc1611dabUL, 0xb6662d3dUL, 0x76dc4190UL, + 0x01db7106UL, 0x98d220bcUL, 0xefd5102aUL, 0x71b18589UL, 0x06b6b51fUL, + 0x9fbfe4a5UL, 0xe8b8d433UL, 0x7807c9a2UL, 0x0f00f934UL, 0x9609a88eUL, + 0xe10e9818UL, 0x7f6a0dbbUL, 0x086d3d2dUL, 0x91646c97UL, 0xe6635c01UL, + 0x6b6b51f4UL, 0x1c6c6162UL, 0x856530d8UL, 0xf262004eUL, 0x6c0695edUL, + 0x1b01a57bUL, 0x8208f4c1UL, 0xf50fc457UL, 0x65b0d9c6UL, 0x12b7e950UL, + 0x8bbeb8eaUL, 0xfcb9887cUL, 0x62dd1ddfUL, 0x15da2d49UL, 0x8cd37cf3UL, + 0xfbd44c65UL, 0x4db26158UL, 0x3ab551ceUL, 0xa3bc0074UL, 0xd4bb30e2UL, + 0x4adfa541UL, 0x3dd895d7UL, 0xa4d1c46dUL, 0xd3d6f4fbUL, 0x4369e96aUL, + 0x346ed9fcUL, 0xad678846UL, 0xda60b8d0UL, 0x44042d73UL, 0x33031de5UL, + 0xaa0a4c5fUL, 0xdd0d7cc9UL, 0x5005713cUL, 0x270241aaUL, 0xbe0b1010UL, + 0xc90c2086UL, 0x5768b525UL, 0x206f85b3UL, 0xb966d409UL, 0xce61e49fUL, + 0x5edef90eUL, 0x29d9c998UL, 0xb0d09822UL, 0xc7d7a8b4UL, 0x59b33d17UL, + 0x2eb40d81UL, 0xb7bd5c3bUL, 0xc0ba6cadUL, 0xedb88320UL, 0x9abfb3b6UL, + 0x03b6e20cUL, 0x74b1d29aUL, 0xead54739UL, 0x9dd277afUL, 0x04db2615UL, + 0x73dc1683UL, 0xe3630b12UL, 0x94643b84UL, 0x0d6d6a3eUL, 0x7a6a5aa8UL, + 0xe40ecf0bUL, 0x9309ff9dUL, 0x0a00ae27UL, 0x7d079eb1UL, 0xf00f9344UL, + 0x8708a3d2UL, 0x1e01f268UL, 0x6906c2feUL, 0xf762575dUL, 0x806567cbUL, + 0x196c3671UL, 0x6e6b06e7UL, 0xfed41b76UL, 0x89d32be0UL, 0x10da7a5aUL, + 0x67dd4accUL, 0xf9b9df6fUL, 0x8ebeeff9UL, 0x17b7be43UL, 0x60b08ed5UL, + 0xd6d6a3e8UL, 0xa1d1937eUL, 0x38d8c2c4UL, 0x4fdff252UL, 0xd1bb67f1UL, + 0xa6bc5767UL, 0x3fb506ddUL, 0x48b2364bUL, 0xd80d2bdaUL, 0xaf0a1b4cUL, + 0x36034af6UL, 0x41047a60UL, 0xdf60efc3UL, 0xa867df55UL, 0x316e8eefUL, + 0x4669be79UL, 0xcb61b38cUL, 0xbc66831aUL, 0x256fd2a0UL, 0x5268e236UL, + 0xcc0c7795UL, 0xbb0b4703UL, 0x220216b9UL, 0x5505262fUL, 0xc5ba3bbeUL, + 0xb2bd0b28UL, 0x2bb45a92UL, 0x5cb36a04UL, 0xc2d7ffa7UL, 0xb5d0cf31UL, + 0x2cd99e8bUL, 0x5bdeae1dUL, 0x9b64c2b0UL, 0xec63f226UL, 0x756aa39cUL, + 0x026d930aUL, 0x9c0906a9UL, 0xeb0e363fUL, 0x72076785UL, 0x05005713UL, + 0x95bf4a82UL, 0xe2b87a14UL, 0x7bb12baeUL, 0x0cb61b38UL, 0x92d28e9bUL, + 0xe5d5be0dUL, 0x7cdcefb7UL, 0x0bdbdf21UL, 0x86d3d2d4UL, 0xf1d4e242UL, + 0x68ddb3f8UL, 0x1fda836eUL, 0x81be16cdUL, 0xf6b9265bUL, 0x6fb077e1UL, + 0x18b74777UL, 0x88085ae6UL, 0xff0f6a70UL, 0x66063bcaUL, 0x11010b5cUL, + 0x8f659effUL, 0xf862ae69UL, 0x616bffd3UL, 0x166ccf45UL, 0xa00ae278UL, + 0xd70dd2eeUL, 0x4e048354UL, 0x3903b3c2UL, 0xa7672661UL, 0xd06016f7UL, + 0x4969474dUL, 0x3e6e77dbUL, 0xaed16a4aUL, 0xd9d65adcUL, 0x40df0b66UL, + 0x37d83bf0UL, 0xa9bcae53UL, 0xdebb9ec5UL, 0x47b2cf7fUL, 0x30b5ffe9UL, + 0xbdbdf21cUL, 0xcabac28aUL, 0x53b39330UL, 0x24b4a3a6UL, 0xbad03605UL, + 0xcdd70693UL, 0x54de5729UL, 0x23d967bfUL, 0xb3667a2eUL, 0xc4614ab8UL, + 0x5d681b02UL, 0x2a6f2b94UL, 0xb40bbe37UL, 0xc30c8ea1UL, 0x5a05df1bUL, + 0x2d02ef8dUL +#ifdef BYFOUR + }, + { + 0x00000000UL, 0x191b3141UL, 0x32366282UL, 0x2b2d53c3UL, 0x646cc504UL, + 0x7d77f445UL, 0x565aa786UL, 0x4f4196c7UL, 0xc8d98a08UL, 0xd1c2bb49UL, + 0xfaefe88aUL, 0xe3f4d9cbUL, 0xacb54f0cUL, 0xb5ae7e4dUL, 0x9e832d8eUL, + 0x87981ccfUL, 0x4ac21251UL, 0x53d92310UL, 0x78f470d3UL, 0x61ef4192UL, + 0x2eaed755UL, 0x37b5e614UL, 0x1c98b5d7UL, 0x05838496UL, 0x821b9859UL, + 0x9b00a918UL, 0xb02dfadbUL, 0xa936cb9aUL, 0xe6775d5dUL, 0xff6c6c1cUL, + 0xd4413fdfUL, 0xcd5a0e9eUL, 0x958424a2UL, 0x8c9f15e3UL, 0xa7b24620UL, + 0xbea97761UL, 0xf1e8e1a6UL, 0xe8f3d0e7UL, 0xc3de8324UL, 0xdac5b265UL, + 0x5d5daeaaUL, 0x44469febUL, 0x6f6bcc28UL, 0x7670fd69UL, 0x39316baeUL, + 0x202a5aefUL, 0x0b07092cUL, 0x121c386dUL, 0xdf4636f3UL, 0xc65d07b2UL, + 0xed705471UL, 0xf46b6530UL, 0xbb2af3f7UL, 0xa231c2b6UL, 0x891c9175UL, + 0x9007a034UL, 0x179fbcfbUL, 0x0e848dbaUL, 0x25a9de79UL, 0x3cb2ef38UL, + 0x73f379ffUL, 0x6ae848beUL, 0x41c51b7dUL, 0x58de2a3cUL, 0xf0794f05UL, + 0xe9627e44UL, 0xc24f2d87UL, 0xdb541cc6UL, 0x94158a01UL, 0x8d0ebb40UL, + 0xa623e883UL, 0xbf38d9c2UL, 0x38a0c50dUL, 0x21bbf44cUL, 0x0a96a78fUL, + 0x138d96ceUL, 0x5ccc0009UL, 0x45d73148UL, 0x6efa628bUL, 0x77e153caUL, + 0xbabb5d54UL, 0xa3a06c15UL, 0x888d3fd6UL, 0x91960e97UL, 0xded79850UL, + 0xc7cca911UL, 0xece1fad2UL, 0xf5facb93UL, 0x7262d75cUL, 0x6b79e61dUL, + 0x4054b5deUL, 0x594f849fUL, 0x160e1258UL, 0x0f152319UL, 0x243870daUL, + 0x3d23419bUL, 0x65fd6ba7UL, 0x7ce65ae6UL, 0x57cb0925UL, 0x4ed03864UL, + 0x0191aea3UL, 0x188a9fe2UL, 0x33a7cc21UL, 0x2abcfd60UL, 0xad24e1afUL, + 0xb43fd0eeUL, 0x9f12832dUL, 0x8609b26cUL, 0xc94824abUL, 0xd05315eaUL, + 0xfb7e4629UL, 0xe2657768UL, 0x2f3f79f6UL, 0x362448b7UL, 0x1d091b74UL, + 0x04122a35UL, 0x4b53bcf2UL, 0x52488db3UL, 0x7965de70UL, 0x607eef31UL, + 0xe7e6f3feUL, 0xfefdc2bfUL, 0xd5d0917cUL, 0xcccba03dUL, 0x838a36faUL, + 0x9a9107bbUL, 0xb1bc5478UL, 0xa8a76539UL, 0x3b83984bUL, 0x2298a90aUL, + 0x09b5fac9UL, 0x10aecb88UL, 0x5fef5d4fUL, 0x46f46c0eUL, 0x6dd93fcdUL, + 0x74c20e8cUL, 0xf35a1243UL, 0xea412302UL, 0xc16c70c1UL, 0xd8774180UL, + 0x9736d747UL, 0x8e2de606UL, 0xa500b5c5UL, 0xbc1b8484UL, 0x71418a1aUL, + 0x685abb5bUL, 0x4377e898UL, 0x5a6cd9d9UL, 0x152d4f1eUL, 0x0c367e5fUL, + 0x271b2d9cUL, 0x3e001cddUL, 0xb9980012UL, 0xa0833153UL, 0x8bae6290UL, + 0x92b553d1UL, 0xddf4c516UL, 0xc4eff457UL, 0xefc2a794UL, 0xf6d996d5UL, + 0xae07bce9UL, 0xb71c8da8UL, 0x9c31de6bUL, 0x852aef2aUL, 0xca6b79edUL, + 0xd37048acUL, 0xf85d1b6fUL, 0xe1462a2eUL, 0x66de36e1UL, 0x7fc507a0UL, + 0x54e85463UL, 0x4df36522UL, 0x02b2f3e5UL, 0x1ba9c2a4UL, 0x30849167UL, + 0x299fa026UL, 0xe4c5aeb8UL, 0xfdde9ff9UL, 0xd6f3cc3aUL, 0xcfe8fd7bUL, + 0x80a96bbcUL, 0x99b25afdUL, 0xb29f093eUL, 0xab84387fUL, 0x2c1c24b0UL, + 0x350715f1UL, 0x1e2a4632UL, 0x07317773UL, 0x4870e1b4UL, 0x516bd0f5UL, + 0x7a468336UL, 0x635db277UL, 0xcbfad74eUL, 0xd2e1e60fUL, 0xf9ccb5ccUL, + 0xe0d7848dUL, 0xaf96124aUL, 0xb68d230bUL, 0x9da070c8UL, 0x84bb4189UL, + 0x03235d46UL, 0x1a386c07UL, 0x31153fc4UL, 0x280e0e85UL, 0x674f9842UL, + 0x7e54a903UL, 0x5579fac0UL, 0x4c62cb81UL, 0x8138c51fUL, 0x9823f45eUL, + 0xb30ea79dUL, 0xaa1596dcUL, 0xe554001bUL, 0xfc4f315aUL, 0xd7626299UL, + 0xce7953d8UL, 0x49e14f17UL, 0x50fa7e56UL, 0x7bd72d95UL, 0x62cc1cd4UL, + 0x2d8d8a13UL, 0x3496bb52UL, 0x1fbbe891UL, 0x06a0d9d0UL, 0x5e7ef3ecUL, + 0x4765c2adUL, 0x6c48916eUL, 0x7553a02fUL, 0x3a1236e8UL, 0x230907a9UL, + 0x0824546aUL, 0x113f652bUL, 0x96a779e4UL, 0x8fbc48a5UL, 0xa4911b66UL, + 0xbd8a2a27UL, 0xf2cbbce0UL, 0xebd08da1UL, 0xc0fdde62UL, 0xd9e6ef23UL, + 0x14bce1bdUL, 0x0da7d0fcUL, 0x268a833fUL, 0x3f91b27eUL, 0x70d024b9UL, + 0x69cb15f8UL, 0x42e6463bUL, 0x5bfd777aUL, 0xdc656bb5UL, 0xc57e5af4UL, + 0xee530937UL, 0xf7483876UL, 0xb809aeb1UL, 0xa1129ff0UL, 0x8a3fcc33UL, + 0x9324fd72UL + }, + { + 0x00000000UL, 0x01c26a37UL, 0x0384d46eUL, 0x0246be59UL, 0x0709a8dcUL, + 0x06cbc2ebUL, 0x048d7cb2UL, 0x054f1685UL, 0x0e1351b8UL, 0x0fd13b8fUL, + 0x0d9785d6UL, 0x0c55efe1UL, 0x091af964UL, 0x08d89353UL, 0x0a9e2d0aUL, + 0x0b5c473dUL, 0x1c26a370UL, 0x1de4c947UL, 0x1fa2771eUL, 0x1e601d29UL, + 0x1b2f0bacUL, 0x1aed619bUL, 0x18abdfc2UL, 0x1969b5f5UL, 0x1235f2c8UL, + 0x13f798ffUL, 0x11b126a6UL, 0x10734c91UL, 0x153c5a14UL, 0x14fe3023UL, + 0x16b88e7aUL, 0x177ae44dUL, 0x384d46e0UL, 0x398f2cd7UL, 0x3bc9928eUL, + 0x3a0bf8b9UL, 0x3f44ee3cUL, 0x3e86840bUL, 0x3cc03a52UL, 0x3d025065UL, + 0x365e1758UL, 0x379c7d6fUL, 0x35dac336UL, 0x3418a901UL, 0x3157bf84UL, + 0x3095d5b3UL, 0x32d36beaUL, 0x331101ddUL, 0x246be590UL, 0x25a98fa7UL, + 0x27ef31feUL, 0x262d5bc9UL, 0x23624d4cUL, 0x22a0277bUL, 0x20e69922UL, + 0x2124f315UL, 0x2a78b428UL, 0x2bbade1fUL, 0x29fc6046UL, 0x283e0a71UL, + 0x2d711cf4UL, 0x2cb376c3UL, 0x2ef5c89aUL, 0x2f37a2adUL, 0x709a8dc0UL, + 0x7158e7f7UL, 0x731e59aeUL, 0x72dc3399UL, 0x7793251cUL, 0x76514f2bUL, + 0x7417f172UL, 0x75d59b45UL, 0x7e89dc78UL, 0x7f4bb64fUL, 0x7d0d0816UL, + 0x7ccf6221UL, 0x798074a4UL, 0x78421e93UL, 0x7a04a0caUL, 0x7bc6cafdUL, + 0x6cbc2eb0UL, 0x6d7e4487UL, 0x6f38fadeUL, 0x6efa90e9UL, 0x6bb5866cUL, + 0x6a77ec5bUL, 0x68315202UL, 0x69f33835UL, 0x62af7f08UL, 0x636d153fUL, + 0x612bab66UL, 0x60e9c151UL, 0x65a6d7d4UL, 0x6464bde3UL, 0x662203baUL, + 0x67e0698dUL, 0x48d7cb20UL, 0x4915a117UL, 0x4b531f4eUL, 0x4a917579UL, + 0x4fde63fcUL, 0x4e1c09cbUL, 0x4c5ab792UL, 0x4d98dda5UL, 0x46c49a98UL, + 0x4706f0afUL, 0x45404ef6UL, 0x448224c1UL, 0x41cd3244UL, 0x400f5873UL, + 0x4249e62aUL, 0x438b8c1dUL, 0x54f16850UL, 0x55330267UL, 0x5775bc3eUL, + 0x56b7d609UL, 0x53f8c08cUL, 0x523aaabbUL, 0x507c14e2UL, 0x51be7ed5UL, + 0x5ae239e8UL, 0x5b2053dfUL, 0x5966ed86UL, 0x58a487b1UL, 0x5deb9134UL, + 0x5c29fb03UL, 0x5e6f455aUL, 0x5fad2f6dUL, 0xe1351b80UL, 0xe0f771b7UL, + 0xe2b1cfeeUL, 0xe373a5d9UL, 0xe63cb35cUL, 0xe7fed96bUL, 0xe5b86732UL, + 0xe47a0d05UL, 0xef264a38UL, 0xeee4200fUL, 0xeca29e56UL, 0xed60f461UL, + 0xe82fe2e4UL, 0xe9ed88d3UL, 0xebab368aUL, 0xea695cbdUL, 0xfd13b8f0UL, + 0xfcd1d2c7UL, 0xfe976c9eUL, 0xff5506a9UL, 0xfa1a102cUL, 0xfbd87a1bUL, + 0xf99ec442UL, 0xf85cae75UL, 0xf300e948UL, 0xf2c2837fUL, 0xf0843d26UL, + 0xf1465711UL, 0xf4094194UL, 0xf5cb2ba3UL, 0xf78d95faUL, 0xf64fffcdUL, + 0xd9785d60UL, 0xd8ba3757UL, 0xdafc890eUL, 0xdb3ee339UL, 0xde71f5bcUL, + 0xdfb39f8bUL, 0xddf521d2UL, 0xdc374be5UL, 0xd76b0cd8UL, 0xd6a966efUL, + 0xd4efd8b6UL, 0xd52db281UL, 0xd062a404UL, 0xd1a0ce33UL, 0xd3e6706aUL, + 0xd2241a5dUL, 0xc55efe10UL, 0xc49c9427UL, 0xc6da2a7eUL, 0xc7184049UL, + 0xc25756ccUL, 0xc3953cfbUL, 0xc1d382a2UL, 0xc011e895UL, 0xcb4dafa8UL, + 0xca8fc59fUL, 0xc8c97bc6UL, 0xc90b11f1UL, 0xcc440774UL, 0xcd866d43UL, + 0xcfc0d31aUL, 0xce02b92dUL, 0x91af9640UL, 0x906dfc77UL, 0x922b422eUL, + 0x93e92819UL, 0x96a63e9cUL, 0x976454abUL, 0x9522eaf2UL, 0x94e080c5UL, + 0x9fbcc7f8UL, 0x9e7eadcfUL, 0x9c381396UL, 0x9dfa79a1UL, 0x98b56f24UL, + 0x99770513UL, 0x9b31bb4aUL, 0x9af3d17dUL, 0x8d893530UL, 0x8c4b5f07UL, + 0x8e0de15eUL, 0x8fcf8b69UL, 0x8a809decUL, 0x8b42f7dbUL, 0x89044982UL, + 0x88c623b5UL, 0x839a6488UL, 0x82580ebfUL, 0x801eb0e6UL, 0x81dcdad1UL, + 0x8493cc54UL, 0x8551a663UL, 0x8717183aUL, 0x86d5720dUL, 0xa9e2d0a0UL, + 0xa820ba97UL, 0xaa6604ceUL, 0xaba46ef9UL, 0xaeeb787cUL, 0xaf29124bUL, + 0xad6fac12UL, 0xacadc625UL, 0xa7f18118UL, 0xa633eb2fUL, 0xa4755576UL, + 0xa5b73f41UL, 0xa0f829c4UL, 0xa13a43f3UL, 0xa37cfdaaUL, 0xa2be979dUL, + 0xb5c473d0UL, 0xb40619e7UL, 0xb640a7beUL, 0xb782cd89UL, 0xb2cddb0cUL, + 0xb30fb13bUL, 0xb1490f62UL, 0xb08b6555UL, 0xbbd72268UL, 0xba15485fUL, + 0xb853f606UL, 0xb9919c31UL, 0xbcde8ab4UL, 0xbd1ce083UL, 0xbf5a5edaUL, + 0xbe9834edUL + }, + { + 0x00000000UL, 0xb8bc6765UL, 0xaa09c88bUL, 0x12b5afeeUL, 0x8f629757UL, + 0x37def032UL, 0x256b5fdcUL, 0x9dd738b9UL, 0xc5b428efUL, 0x7d084f8aUL, + 0x6fbde064UL, 0xd7018701UL, 0x4ad6bfb8UL, 0xf26ad8ddUL, 0xe0df7733UL, + 0x58631056UL, 0x5019579fUL, 0xe8a530faUL, 0xfa109f14UL, 0x42acf871UL, + 0xdf7bc0c8UL, 0x67c7a7adUL, 0x75720843UL, 0xcdce6f26UL, 0x95ad7f70UL, + 0x2d111815UL, 0x3fa4b7fbUL, 0x8718d09eUL, 0x1acfe827UL, 0xa2738f42UL, + 0xb0c620acUL, 0x087a47c9UL, 0xa032af3eUL, 0x188ec85bUL, 0x0a3b67b5UL, + 0xb28700d0UL, 0x2f503869UL, 0x97ec5f0cUL, 0x8559f0e2UL, 0x3de59787UL, + 0x658687d1UL, 0xdd3ae0b4UL, 0xcf8f4f5aUL, 0x7733283fUL, 0xeae41086UL, + 0x525877e3UL, 0x40edd80dUL, 0xf851bf68UL, 0xf02bf8a1UL, 0x48979fc4UL, + 0x5a22302aUL, 0xe29e574fUL, 0x7f496ff6UL, 0xc7f50893UL, 0xd540a77dUL, + 0x6dfcc018UL, 0x359fd04eUL, 0x8d23b72bUL, 0x9f9618c5UL, 0x272a7fa0UL, + 0xbafd4719UL, 0x0241207cUL, 0x10f48f92UL, 0xa848e8f7UL, 0x9b14583dUL, + 0x23a83f58UL, 0x311d90b6UL, 0x89a1f7d3UL, 0x1476cf6aUL, 0xaccaa80fUL, + 0xbe7f07e1UL, 0x06c36084UL, 0x5ea070d2UL, 0xe61c17b7UL, 0xf4a9b859UL, + 0x4c15df3cUL, 0xd1c2e785UL, 0x697e80e0UL, 0x7bcb2f0eUL, 0xc377486bUL, + 0xcb0d0fa2UL, 0x73b168c7UL, 0x6104c729UL, 0xd9b8a04cUL, 0x446f98f5UL, + 0xfcd3ff90UL, 0xee66507eUL, 0x56da371bUL, 0x0eb9274dUL, 0xb6054028UL, + 0xa4b0efc6UL, 0x1c0c88a3UL, 0x81dbb01aUL, 0x3967d77fUL, 0x2bd27891UL, + 0x936e1ff4UL, 0x3b26f703UL, 0x839a9066UL, 0x912f3f88UL, 0x299358edUL, + 0xb4446054UL, 0x0cf80731UL, 0x1e4da8dfUL, 0xa6f1cfbaUL, 0xfe92dfecUL, + 0x462eb889UL, 0x549b1767UL, 0xec277002UL, 0x71f048bbUL, 0xc94c2fdeUL, + 0xdbf98030UL, 0x6345e755UL, 0x6b3fa09cUL, 0xd383c7f9UL, 0xc1366817UL, + 0x798a0f72UL, 0xe45d37cbUL, 0x5ce150aeUL, 0x4e54ff40UL, 0xf6e89825UL, + 0xae8b8873UL, 0x1637ef16UL, 0x048240f8UL, 0xbc3e279dUL, 0x21e91f24UL, + 0x99557841UL, 0x8be0d7afUL, 0x335cb0caUL, 0xed59b63bUL, 0x55e5d15eUL, + 0x47507eb0UL, 0xffec19d5UL, 0x623b216cUL, 0xda874609UL, 0xc832e9e7UL, + 0x708e8e82UL, 0x28ed9ed4UL, 0x9051f9b1UL, 0x82e4565fUL, 0x3a58313aUL, + 0xa78f0983UL, 0x1f336ee6UL, 0x0d86c108UL, 0xb53aa66dUL, 0xbd40e1a4UL, + 0x05fc86c1UL, 0x1749292fUL, 0xaff54e4aUL, 0x322276f3UL, 0x8a9e1196UL, + 0x982bbe78UL, 0x2097d91dUL, 0x78f4c94bUL, 0xc048ae2eUL, 0xd2fd01c0UL, + 0x6a4166a5UL, 0xf7965e1cUL, 0x4f2a3979UL, 0x5d9f9697UL, 0xe523f1f2UL, + 0x4d6b1905UL, 0xf5d77e60UL, 0xe762d18eUL, 0x5fdeb6ebUL, 0xc2098e52UL, + 0x7ab5e937UL, 0x680046d9UL, 0xd0bc21bcUL, 0x88df31eaUL, 0x3063568fUL, + 0x22d6f961UL, 0x9a6a9e04UL, 0x07bda6bdUL, 0xbf01c1d8UL, 0xadb46e36UL, + 0x15080953UL, 0x1d724e9aUL, 0xa5ce29ffUL, 0xb77b8611UL, 0x0fc7e174UL, + 0x9210d9cdUL, 0x2aacbea8UL, 0x38191146UL, 0x80a57623UL, 0xd8c66675UL, + 0x607a0110UL, 0x72cfaefeUL, 0xca73c99bUL, 0x57a4f122UL, 0xef189647UL, + 0xfdad39a9UL, 0x45115eccUL, 0x764dee06UL, 0xcef18963UL, 0xdc44268dUL, + 0x64f841e8UL, 0xf92f7951UL, 0x41931e34UL, 0x5326b1daUL, 0xeb9ad6bfUL, + 0xb3f9c6e9UL, 0x0b45a18cUL, 0x19f00e62UL, 0xa14c6907UL, 0x3c9b51beUL, + 0x842736dbUL, 0x96929935UL, 0x2e2efe50UL, 0x2654b999UL, 0x9ee8defcUL, + 0x8c5d7112UL, 0x34e11677UL, 0xa9362eceUL, 0x118a49abUL, 0x033fe645UL, + 0xbb838120UL, 0xe3e09176UL, 0x5b5cf613UL, 0x49e959fdUL, 0xf1553e98UL, + 0x6c820621UL, 0xd43e6144UL, 0xc68bceaaUL, 0x7e37a9cfUL, 0xd67f4138UL, + 0x6ec3265dUL, 0x7c7689b3UL, 0xc4caeed6UL, 0x591dd66fUL, 0xe1a1b10aUL, + 0xf3141ee4UL, 0x4ba87981UL, 0x13cb69d7UL, 0xab770eb2UL, 0xb9c2a15cUL, + 0x017ec639UL, 0x9ca9fe80UL, 0x241599e5UL, 0x36a0360bUL, 0x8e1c516eUL, + 0x866616a7UL, 0x3eda71c2UL, 0x2c6fde2cUL, 0x94d3b949UL, 0x090481f0UL, + 0xb1b8e695UL, 0xa30d497bUL, 0x1bb12e1eUL, 0x43d23e48UL, 0xfb6e592dUL, + 0xe9dbf6c3UL, 0x516791a6UL, 0xccb0a91fUL, 0x740cce7aUL, 0x66b96194UL, + 0xde0506f1UL + }, + { + 0x00000000UL, 0x96300777UL, 0x2c610eeeUL, 0xba510999UL, 0x19c46d07UL, + 0x8ff46a70UL, 0x35a563e9UL, 0xa395649eUL, 0x3288db0eUL, 0xa4b8dc79UL, + 0x1ee9d5e0UL, 0x88d9d297UL, 0x2b4cb609UL, 0xbd7cb17eUL, 0x072db8e7UL, + 0x911dbf90UL, 0x6410b71dUL, 0xf220b06aUL, 0x4871b9f3UL, 0xde41be84UL, + 0x7dd4da1aUL, 0xebe4dd6dUL, 0x51b5d4f4UL, 0xc785d383UL, 0x56986c13UL, + 0xc0a86b64UL, 0x7af962fdUL, 0xecc9658aUL, 0x4f5c0114UL, 0xd96c0663UL, + 0x633d0ffaUL, 0xf50d088dUL, 0xc8206e3bUL, 0x5e10694cUL, 0xe44160d5UL, + 0x727167a2UL, 0xd1e4033cUL, 0x47d4044bUL, 0xfd850dd2UL, 0x6bb50aa5UL, + 0xfaa8b535UL, 0x6c98b242UL, 0xd6c9bbdbUL, 0x40f9bcacUL, 0xe36cd832UL, + 0x755cdf45UL, 0xcf0dd6dcUL, 0x593dd1abUL, 0xac30d926UL, 0x3a00de51UL, + 0x8051d7c8UL, 0x1661d0bfUL, 0xb5f4b421UL, 0x23c4b356UL, 0x9995bacfUL, + 0x0fa5bdb8UL, 0x9eb80228UL, 0x0888055fUL, 0xb2d90cc6UL, 0x24e90bb1UL, + 0x877c6f2fUL, 0x114c6858UL, 0xab1d61c1UL, 0x3d2d66b6UL, 0x9041dc76UL, + 0x0671db01UL, 0xbc20d298UL, 0x2a10d5efUL, 0x8985b171UL, 0x1fb5b606UL, + 0xa5e4bf9fUL, 0x33d4b8e8UL, 0xa2c90778UL, 0x34f9000fUL, 0x8ea80996UL, + 0x18980ee1UL, 0xbb0d6a7fUL, 0x2d3d6d08UL, 0x976c6491UL, 0x015c63e6UL, + 0xf4516b6bUL, 0x62616c1cUL, 0xd8306585UL, 0x4e0062f2UL, 0xed95066cUL, + 0x7ba5011bUL, 0xc1f40882UL, 0x57c40ff5UL, 0xc6d9b065UL, 0x50e9b712UL, + 0xeab8be8bUL, 0x7c88b9fcUL, 0xdf1ddd62UL, 0x492dda15UL, 0xf37cd38cUL, + 0x654cd4fbUL, 0x5861b24dUL, 0xce51b53aUL, 0x7400bca3UL, 0xe230bbd4UL, + 0x41a5df4aUL, 0xd795d83dUL, 0x6dc4d1a4UL, 0xfbf4d6d3UL, 0x6ae96943UL, + 0xfcd96e34UL, 0x468867adUL, 0xd0b860daUL, 0x732d0444UL, 0xe51d0333UL, + 0x5f4c0aaaUL, 0xc97c0dddUL, 0x3c710550UL, 0xaa410227UL, 0x10100bbeUL, + 0x86200cc9UL, 0x25b56857UL, 0xb3856f20UL, 0x09d466b9UL, 0x9fe461ceUL, + 0x0ef9de5eUL, 0x98c9d929UL, 0x2298d0b0UL, 0xb4a8d7c7UL, 0x173db359UL, + 0x810db42eUL, 0x3b5cbdb7UL, 0xad6cbac0UL, 0x2083b8edUL, 0xb6b3bf9aUL, + 0x0ce2b603UL, 0x9ad2b174UL, 0x3947d5eaUL, 0xaf77d29dUL, 0x1526db04UL, + 0x8316dc73UL, 0x120b63e3UL, 0x843b6494UL, 0x3e6a6d0dUL, 0xa85a6a7aUL, + 0x0bcf0ee4UL, 0x9dff0993UL, 0x27ae000aUL, 0xb19e077dUL, 0x44930ff0UL, + 0xd2a30887UL, 0x68f2011eUL, 0xfec20669UL, 0x5d5762f7UL, 0xcb676580UL, + 0x71366c19UL, 0xe7066b6eUL, 0x761bd4feUL, 0xe02bd389UL, 0x5a7ada10UL, + 0xcc4add67UL, 0x6fdfb9f9UL, 0xf9efbe8eUL, 0x43beb717UL, 0xd58eb060UL, + 0xe8a3d6d6UL, 0x7e93d1a1UL, 0xc4c2d838UL, 0x52f2df4fUL, 0xf167bbd1UL, + 0x6757bca6UL, 0xdd06b53fUL, 0x4b36b248UL, 0xda2b0dd8UL, 0x4c1b0aafUL, + 0xf64a0336UL, 0x607a0441UL, 0xc3ef60dfUL, 0x55df67a8UL, 0xef8e6e31UL, + 0x79be6946UL, 0x8cb361cbUL, 0x1a8366bcUL, 0xa0d26f25UL, 0x36e26852UL, + 0x95770cccUL, 0x03470bbbUL, 0xb9160222UL, 0x2f260555UL, 0xbe3bbac5UL, + 0x280bbdb2UL, 0x925ab42bUL, 0x046ab35cUL, 0xa7ffd7c2UL, 0x31cfd0b5UL, + 0x8b9ed92cUL, 0x1daede5bUL, 0xb0c2649bUL, 0x26f263ecUL, 0x9ca36a75UL, + 0x0a936d02UL, 0xa906099cUL, 0x3f360eebUL, 0x85670772UL, 0x13570005UL, + 0x824abf95UL, 0x147ab8e2UL, 0xae2bb17bUL, 0x381bb60cUL, 0x9b8ed292UL, + 0x0dbed5e5UL, 0xb7efdc7cUL, 0x21dfdb0bUL, 0xd4d2d386UL, 0x42e2d4f1UL, + 0xf8b3dd68UL, 0x6e83da1fUL, 0xcd16be81UL, 0x5b26b9f6UL, 0xe177b06fUL, + 0x7747b718UL, 0xe65a0888UL, 0x706a0fffUL, 0xca3b0666UL, 0x5c0b0111UL, + 0xff9e658fUL, 0x69ae62f8UL, 0xd3ff6b61UL, 0x45cf6c16UL, 0x78e20aa0UL, + 0xeed20dd7UL, 0x5483044eUL, 0xc2b30339UL, 0x612667a7UL, 0xf71660d0UL, + 0x4d476949UL, 0xdb776e3eUL, 0x4a6ad1aeUL, 0xdc5ad6d9UL, 0x660bdf40UL, + 0xf03bd837UL, 0x53aebca9UL, 0xc59ebbdeUL, 0x7fcfb247UL, 0xe9ffb530UL, + 0x1cf2bdbdUL, 0x8ac2bacaUL, 0x3093b353UL, 0xa6a3b424UL, 0x0536d0baUL, + 0x9306d7cdUL, 0x2957de54UL, 0xbf67d923UL, 0x2e7a66b3UL, 0xb84a61c4UL, + 0x021b685dUL, 0x942b6f2aUL, 0x37be0bb4UL, 0xa18e0cc3UL, 0x1bdf055aUL, + 0x8def022dUL + }, + { + 0x00000000UL, 0x41311b19UL, 0x82623632UL, 0xc3532d2bUL, 0x04c56c64UL, + 0x45f4777dUL, 0x86a75a56UL, 0xc796414fUL, 0x088ad9c8UL, 0x49bbc2d1UL, + 0x8ae8effaUL, 0xcbd9f4e3UL, 0x0c4fb5acUL, 0x4d7eaeb5UL, 0x8e2d839eUL, + 0xcf1c9887UL, 0x5112c24aUL, 0x1023d953UL, 0xd370f478UL, 0x9241ef61UL, + 0x55d7ae2eUL, 0x14e6b537UL, 0xd7b5981cUL, 0x96848305UL, 0x59981b82UL, + 0x18a9009bUL, 0xdbfa2db0UL, 0x9acb36a9UL, 0x5d5d77e6UL, 0x1c6c6cffUL, + 0xdf3f41d4UL, 0x9e0e5acdUL, 0xa2248495UL, 0xe3159f8cUL, 0x2046b2a7UL, + 0x6177a9beUL, 0xa6e1e8f1UL, 0xe7d0f3e8UL, 0x2483dec3UL, 0x65b2c5daUL, + 0xaaae5d5dUL, 0xeb9f4644UL, 0x28cc6b6fUL, 0x69fd7076UL, 0xae6b3139UL, + 0xef5a2a20UL, 0x2c09070bUL, 0x6d381c12UL, 0xf33646dfUL, 0xb2075dc6UL, + 0x715470edUL, 0x30656bf4UL, 0xf7f32abbUL, 0xb6c231a2UL, 0x75911c89UL, + 0x34a00790UL, 0xfbbc9f17UL, 0xba8d840eUL, 0x79dea925UL, 0x38efb23cUL, + 0xff79f373UL, 0xbe48e86aUL, 0x7d1bc541UL, 0x3c2ade58UL, 0x054f79f0UL, + 0x447e62e9UL, 0x872d4fc2UL, 0xc61c54dbUL, 0x018a1594UL, 0x40bb0e8dUL, + 0x83e823a6UL, 0xc2d938bfUL, 0x0dc5a038UL, 0x4cf4bb21UL, 0x8fa7960aUL, + 0xce968d13UL, 0x0900cc5cUL, 0x4831d745UL, 0x8b62fa6eUL, 0xca53e177UL, + 0x545dbbbaUL, 0x156ca0a3UL, 0xd63f8d88UL, 0x970e9691UL, 0x5098d7deUL, + 0x11a9ccc7UL, 0xd2fae1ecUL, 0x93cbfaf5UL, 0x5cd76272UL, 0x1de6796bUL, + 0xdeb55440UL, 0x9f844f59UL, 0x58120e16UL, 0x1923150fUL, 0xda703824UL, + 0x9b41233dUL, 0xa76bfd65UL, 0xe65ae67cUL, 0x2509cb57UL, 0x6438d04eUL, + 0xa3ae9101UL, 0xe29f8a18UL, 0x21cca733UL, 0x60fdbc2aUL, 0xafe124adUL, + 0xeed03fb4UL, 0x2d83129fUL, 0x6cb20986UL, 0xab2448c9UL, 0xea1553d0UL, + 0x29467efbUL, 0x687765e2UL, 0xf6793f2fUL, 0xb7482436UL, 0x741b091dUL, + 0x352a1204UL, 0xf2bc534bUL, 0xb38d4852UL, 0x70de6579UL, 0x31ef7e60UL, + 0xfef3e6e7UL, 0xbfc2fdfeUL, 0x7c91d0d5UL, 0x3da0cbccUL, 0xfa368a83UL, + 0xbb07919aUL, 0x7854bcb1UL, 0x3965a7a8UL, 0x4b98833bUL, 0x0aa99822UL, + 0xc9fab509UL, 0x88cbae10UL, 0x4f5def5fUL, 0x0e6cf446UL, 0xcd3fd96dUL, + 0x8c0ec274UL, 0x43125af3UL, 0x022341eaUL, 0xc1706cc1UL, 0x804177d8UL, + 0x47d73697UL, 0x06e62d8eUL, 0xc5b500a5UL, 0x84841bbcUL, 0x1a8a4171UL, + 0x5bbb5a68UL, 0x98e87743UL, 0xd9d96c5aUL, 0x1e4f2d15UL, 0x5f7e360cUL, + 0x9c2d1b27UL, 0xdd1c003eUL, 0x120098b9UL, 0x533183a0UL, 0x9062ae8bUL, + 0xd153b592UL, 0x16c5f4ddUL, 0x57f4efc4UL, 0x94a7c2efUL, 0xd596d9f6UL, + 0xe9bc07aeUL, 0xa88d1cb7UL, 0x6bde319cUL, 0x2aef2a85UL, 0xed796bcaUL, + 0xac4870d3UL, 0x6f1b5df8UL, 0x2e2a46e1UL, 0xe136de66UL, 0xa007c57fUL, + 0x6354e854UL, 0x2265f34dUL, 0xe5f3b202UL, 0xa4c2a91bUL, 0x67918430UL, + 0x26a09f29UL, 0xb8aec5e4UL, 0xf99fdefdUL, 0x3accf3d6UL, 0x7bfde8cfUL, + 0xbc6ba980UL, 0xfd5ab299UL, 0x3e099fb2UL, 0x7f3884abUL, 0xb0241c2cUL, + 0xf1150735UL, 0x32462a1eUL, 0x73773107UL, 0xb4e17048UL, 0xf5d06b51UL, + 0x3683467aUL, 0x77b25d63UL, 0x4ed7facbUL, 0x0fe6e1d2UL, 0xccb5ccf9UL, + 0x8d84d7e0UL, 0x4a1296afUL, 0x0b238db6UL, 0xc870a09dUL, 0x8941bb84UL, + 0x465d2303UL, 0x076c381aUL, 0xc43f1531UL, 0x850e0e28UL, 0x42984f67UL, + 0x03a9547eUL, 0xc0fa7955UL, 0x81cb624cUL, 0x1fc53881UL, 0x5ef42398UL, + 0x9da70eb3UL, 0xdc9615aaUL, 0x1b0054e5UL, 0x5a314ffcUL, 0x996262d7UL, + 0xd85379ceUL, 0x174fe149UL, 0x567efa50UL, 0x952dd77bUL, 0xd41ccc62UL, + 0x138a8d2dUL, 0x52bb9634UL, 0x91e8bb1fUL, 0xd0d9a006UL, 0xecf37e5eUL, + 0xadc26547UL, 0x6e91486cUL, 0x2fa05375UL, 0xe836123aUL, 0xa9070923UL, + 0x6a542408UL, 0x2b653f11UL, 0xe479a796UL, 0xa548bc8fUL, 0x661b91a4UL, + 0x272a8abdUL, 0xe0bccbf2UL, 0xa18dd0ebUL, 0x62defdc0UL, 0x23efe6d9UL, + 0xbde1bc14UL, 0xfcd0a70dUL, 0x3f838a26UL, 0x7eb2913fUL, 0xb924d070UL, + 0xf815cb69UL, 0x3b46e642UL, 0x7a77fd5bUL, 0xb56b65dcUL, 0xf45a7ec5UL, + 0x370953eeUL, 0x763848f7UL, 0xb1ae09b8UL, 0xf09f12a1UL, 0x33cc3f8aUL, + 0x72fd2493UL + }, + { + 0x00000000UL, 0x376ac201UL, 0x6ed48403UL, 0x59be4602UL, 0xdca80907UL, + 0xebc2cb06UL, 0xb27c8d04UL, 0x85164f05UL, 0xb851130eUL, 0x8f3bd10fUL, + 0xd685970dUL, 0xe1ef550cUL, 0x64f91a09UL, 0x5393d808UL, 0x0a2d9e0aUL, + 0x3d475c0bUL, 0x70a3261cUL, 0x47c9e41dUL, 0x1e77a21fUL, 0x291d601eUL, + 0xac0b2f1bUL, 0x9b61ed1aUL, 0xc2dfab18UL, 0xf5b56919UL, 0xc8f23512UL, + 0xff98f713UL, 0xa626b111UL, 0x914c7310UL, 0x145a3c15UL, 0x2330fe14UL, + 0x7a8eb816UL, 0x4de47a17UL, 0xe0464d38UL, 0xd72c8f39UL, 0x8e92c93bUL, + 0xb9f80b3aUL, 0x3cee443fUL, 0x0b84863eUL, 0x523ac03cUL, 0x6550023dUL, + 0x58175e36UL, 0x6f7d9c37UL, 0x36c3da35UL, 0x01a91834UL, 0x84bf5731UL, + 0xb3d59530UL, 0xea6bd332UL, 0xdd011133UL, 0x90e56b24UL, 0xa78fa925UL, + 0xfe31ef27UL, 0xc95b2d26UL, 0x4c4d6223UL, 0x7b27a022UL, 0x2299e620UL, + 0x15f32421UL, 0x28b4782aUL, 0x1fdeba2bUL, 0x4660fc29UL, 0x710a3e28UL, + 0xf41c712dUL, 0xc376b32cUL, 0x9ac8f52eUL, 0xada2372fUL, 0xc08d9a70UL, + 0xf7e75871UL, 0xae591e73UL, 0x9933dc72UL, 0x1c259377UL, 0x2b4f5176UL, + 0x72f11774UL, 0x459bd575UL, 0x78dc897eUL, 0x4fb64b7fUL, 0x16080d7dUL, + 0x2162cf7cUL, 0xa4748079UL, 0x931e4278UL, 0xcaa0047aUL, 0xfdcac67bUL, + 0xb02ebc6cUL, 0x87447e6dUL, 0xdefa386fUL, 0xe990fa6eUL, 0x6c86b56bUL, + 0x5bec776aUL, 0x02523168UL, 0x3538f369UL, 0x087faf62UL, 0x3f156d63UL, + 0x66ab2b61UL, 0x51c1e960UL, 0xd4d7a665UL, 0xe3bd6464UL, 0xba032266UL, + 0x8d69e067UL, 0x20cbd748UL, 0x17a11549UL, 0x4e1f534bUL, 0x7975914aUL, + 0xfc63de4fUL, 0xcb091c4eUL, 0x92b75a4cUL, 0xa5dd984dUL, 0x989ac446UL, + 0xaff00647UL, 0xf64e4045UL, 0xc1248244UL, 0x4432cd41UL, 0x73580f40UL, + 0x2ae64942UL, 0x1d8c8b43UL, 0x5068f154UL, 0x67023355UL, 0x3ebc7557UL, + 0x09d6b756UL, 0x8cc0f853UL, 0xbbaa3a52UL, 0xe2147c50UL, 0xd57ebe51UL, + 0xe839e25aUL, 0xdf53205bUL, 0x86ed6659UL, 0xb187a458UL, 0x3491eb5dUL, + 0x03fb295cUL, 0x5a456f5eUL, 0x6d2fad5fUL, 0x801b35e1UL, 0xb771f7e0UL, + 0xeecfb1e2UL, 0xd9a573e3UL, 0x5cb33ce6UL, 0x6bd9fee7UL, 0x3267b8e5UL, + 0x050d7ae4UL, 0x384a26efUL, 0x0f20e4eeUL, 0x569ea2ecUL, 0x61f460edUL, + 0xe4e22fe8UL, 0xd388ede9UL, 0x8a36abebUL, 0xbd5c69eaUL, 0xf0b813fdUL, + 0xc7d2d1fcUL, 0x9e6c97feUL, 0xa90655ffUL, 0x2c101afaUL, 0x1b7ad8fbUL, + 0x42c49ef9UL, 0x75ae5cf8UL, 0x48e900f3UL, 0x7f83c2f2UL, 0x263d84f0UL, + 0x115746f1UL, 0x944109f4UL, 0xa32bcbf5UL, 0xfa958df7UL, 0xcdff4ff6UL, + 0x605d78d9UL, 0x5737bad8UL, 0x0e89fcdaUL, 0x39e33edbUL, 0xbcf571deUL, + 0x8b9fb3dfUL, 0xd221f5ddUL, 0xe54b37dcUL, 0xd80c6bd7UL, 0xef66a9d6UL, + 0xb6d8efd4UL, 0x81b22dd5UL, 0x04a462d0UL, 0x33cea0d1UL, 0x6a70e6d3UL, + 0x5d1a24d2UL, 0x10fe5ec5UL, 0x27949cc4UL, 0x7e2adac6UL, 0x494018c7UL, + 0xcc5657c2UL, 0xfb3c95c3UL, 0xa282d3c1UL, 0x95e811c0UL, 0xa8af4dcbUL, + 0x9fc58fcaUL, 0xc67bc9c8UL, 0xf1110bc9UL, 0x740744ccUL, 0x436d86cdUL, + 0x1ad3c0cfUL, 0x2db902ceUL, 0x4096af91UL, 0x77fc6d90UL, 0x2e422b92UL, + 0x1928e993UL, 0x9c3ea696UL, 0xab546497UL, 0xf2ea2295UL, 0xc580e094UL, + 0xf8c7bc9fUL, 0xcfad7e9eUL, 0x9613389cUL, 0xa179fa9dUL, 0x246fb598UL, + 0x13057799UL, 0x4abb319bUL, 0x7dd1f39aUL, 0x3035898dUL, 0x075f4b8cUL, + 0x5ee10d8eUL, 0x698bcf8fUL, 0xec9d808aUL, 0xdbf7428bUL, 0x82490489UL, + 0xb523c688UL, 0x88649a83UL, 0xbf0e5882UL, 0xe6b01e80UL, 0xd1dadc81UL, + 0x54cc9384UL, 0x63a65185UL, 0x3a181787UL, 0x0d72d586UL, 0xa0d0e2a9UL, + 0x97ba20a8UL, 0xce0466aaUL, 0xf96ea4abUL, 0x7c78ebaeUL, 0x4b1229afUL, + 0x12ac6fadUL, 0x25c6adacUL, 0x1881f1a7UL, 0x2feb33a6UL, 0x765575a4UL, + 0x413fb7a5UL, 0xc429f8a0UL, 0xf3433aa1UL, 0xaafd7ca3UL, 0x9d97bea2UL, + 0xd073c4b5UL, 0xe71906b4UL, 0xbea740b6UL, 0x89cd82b7UL, 0x0cdbcdb2UL, + 0x3bb10fb3UL, 0x620f49b1UL, 0x55658bb0UL, 0x6822d7bbUL, 0x5f4815baUL, + 0x06f653b8UL, 0x319c91b9UL, 0xb48adebcUL, 0x83e01cbdUL, 0xda5e5abfUL, + 0xed3498beUL + }, + { + 0x00000000UL, 0x6567bcb8UL, 0x8bc809aaUL, 0xeeafb512UL, 0x5797628fUL, + 0x32f0de37UL, 0xdc5f6b25UL, 0xb938d79dUL, 0xef28b4c5UL, 0x8a4f087dUL, + 0x64e0bd6fUL, 0x018701d7UL, 0xb8bfd64aUL, 0xddd86af2UL, 0x3377dfe0UL, + 0x56106358UL, 0x9f571950UL, 0xfa30a5e8UL, 0x149f10faUL, 0x71f8ac42UL, + 0xc8c07bdfUL, 0xada7c767UL, 0x43087275UL, 0x266fcecdUL, 0x707fad95UL, + 0x1518112dUL, 0xfbb7a43fUL, 0x9ed01887UL, 0x27e8cf1aUL, 0x428f73a2UL, + 0xac20c6b0UL, 0xc9477a08UL, 0x3eaf32a0UL, 0x5bc88e18UL, 0xb5673b0aUL, + 0xd00087b2UL, 0x6938502fUL, 0x0c5fec97UL, 0xe2f05985UL, 0x8797e53dUL, + 0xd1878665UL, 0xb4e03addUL, 0x5a4f8fcfUL, 0x3f283377UL, 0x8610e4eaUL, + 0xe3775852UL, 0x0dd8ed40UL, 0x68bf51f8UL, 0xa1f82bf0UL, 0xc49f9748UL, + 0x2a30225aUL, 0x4f579ee2UL, 0xf66f497fUL, 0x9308f5c7UL, 0x7da740d5UL, + 0x18c0fc6dUL, 0x4ed09f35UL, 0x2bb7238dUL, 0xc518969fUL, 0xa07f2a27UL, + 0x1947fdbaUL, 0x7c204102UL, 0x928ff410UL, 0xf7e848a8UL, 0x3d58149bUL, + 0x583fa823UL, 0xb6901d31UL, 0xd3f7a189UL, 0x6acf7614UL, 0x0fa8caacUL, + 0xe1077fbeUL, 0x8460c306UL, 0xd270a05eUL, 0xb7171ce6UL, 0x59b8a9f4UL, + 0x3cdf154cUL, 0x85e7c2d1UL, 0xe0807e69UL, 0x0e2fcb7bUL, 0x6b4877c3UL, + 0xa20f0dcbUL, 0xc768b173UL, 0x29c70461UL, 0x4ca0b8d9UL, 0xf5986f44UL, + 0x90ffd3fcUL, 0x7e5066eeUL, 0x1b37da56UL, 0x4d27b90eUL, 0x284005b6UL, + 0xc6efb0a4UL, 0xa3880c1cUL, 0x1ab0db81UL, 0x7fd76739UL, 0x9178d22bUL, + 0xf41f6e93UL, 0x03f7263bUL, 0x66909a83UL, 0x883f2f91UL, 0xed589329UL, + 0x546044b4UL, 0x3107f80cUL, 0xdfa84d1eUL, 0xbacff1a6UL, 0xecdf92feUL, + 0x89b82e46UL, 0x67179b54UL, 0x027027ecUL, 0xbb48f071UL, 0xde2f4cc9UL, + 0x3080f9dbUL, 0x55e74563UL, 0x9ca03f6bUL, 0xf9c783d3UL, 0x176836c1UL, + 0x720f8a79UL, 0xcb375de4UL, 0xae50e15cUL, 0x40ff544eUL, 0x2598e8f6UL, + 0x73888baeUL, 0x16ef3716UL, 0xf8408204UL, 0x9d273ebcUL, 0x241fe921UL, + 0x41785599UL, 0xafd7e08bUL, 0xcab05c33UL, 0x3bb659edUL, 0x5ed1e555UL, + 0xb07e5047UL, 0xd519ecffUL, 0x6c213b62UL, 0x094687daUL, 0xe7e932c8UL, + 0x828e8e70UL, 0xd49eed28UL, 0xb1f95190UL, 0x5f56e482UL, 0x3a31583aUL, + 0x83098fa7UL, 0xe66e331fUL, 0x08c1860dUL, 0x6da63ab5UL, 0xa4e140bdUL, + 0xc186fc05UL, 0x2f294917UL, 0x4a4ef5afUL, 0xf3762232UL, 0x96119e8aUL, + 0x78be2b98UL, 0x1dd99720UL, 0x4bc9f478UL, 0x2eae48c0UL, 0xc001fdd2UL, + 0xa566416aUL, 0x1c5e96f7UL, 0x79392a4fUL, 0x97969f5dUL, 0xf2f123e5UL, + 0x05196b4dUL, 0x607ed7f5UL, 0x8ed162e7UL, 0xebb6de5fUL, 0x528e09c2UL, + 0x37e9b57aUL, 0xd9460068UL, 0xbc21bcd0UL, 0xea31df88UL, 0x8f566330UL, + 0x61f9d622UL, 0x049e6a9aUL, 0xbda6bd07UL, 0xd8c101bfUL, 0x366eb4adUL, + 0x53090815UL, 0x9a4e721dUL, 0xff29cea5UL, 0x11867bb7UL, 0x74e1c70fUL, + 0xcdd91092UL, 0xa8beac2aUL, 0x46111938UL, 0x2376a580UL, 0x7566c6d8UL, + 0x10017a60UL, 0xfeaecf72UL, 0x9bc973caUL, 0x22f1a457UL, 0x479618efUL, + 0xa939adfdUL, 0xcc5e1145UL, 0x06ee4d76UL, 0x6389f1ceUL, 0x8d2644dcUL, + 0xe841f864UL, 0x51792ff9UL, 0x341e9341UL, 0xdab12653UL, 0xbfd69aebUL, + 0xe9c6f9b3UL, 0x8ca1450bUL, 0x620ef019UL, 0x07694ca1UL, 0xbe519b3cUL, + 0xdb362784UL, 0x35999296UL, 0x50fe2e2eUL, 0x99b95426UL, 0xfcdee89eUL, + 0x12715d8cUL, 0x7716e134UL, 0xce2e36a9UL, 0xab498a11UL, 0x45e63f03UL, + 0x208183bbUL, 0x7691e0e3UL, 0x13f65c5bUL, 0xfd59e949UL, 0x983e55f1UL, + 0x2106826cUL, 0x44613ed4UL, 0xaace8bc6UL, 0xcfa9377eUL, 0x38417fd6UL, + 0x5d26c36eUL, 0xb389767cUL, 0xd6eecac4UL, 0x6fd61d59UL, 0x0ab1a1e1UL, + 0xe41e14f3UL, 0x8179a84bUL, 0xd769cb13UL, 0xb20e77abUL, 0x5ca1c2b9UL, + 0x39c67e01UL, 0x80fea99cUL, 0xe5991524UL, 0x0b36a036UL, 0x6e511c8eUL, + 0xa7166686UL, 0xc271da3eUL, 0x2cde6f2cUL, 0x49b9d394UL, 0xf0810409UL, + 0x95e6b8b1UL, 0x7b490da3UL, 0x1e2eb11bUL, 0x483ed243UL, 0x2d596efbUL, + 0xc3f6dbe9UL, 0xa6916751UL, 0x1fa9b0ccUL, 0x7ace0c74UL, 0x9461b966UL, + 0xf10605deUL +#endif + } +}; diff --git a/cbits/deflate.h b/cbits/deflate.h new file mode 100644 --- /dev/null +++ b/cbits/deflate.h @@ -0,0 +1,342 @@ +/* deflate.h -- internal compression state + * Copyright (C) 1995-2010 Jean-loup Gailly + * For conditions of distribution and use, see copyright notice in zlib.h + */ + +/* WARNING: this file should *not* be used by applications. It is + part of the implementation of the compression library and is + subject to change. Applications should only use zlib.h. + */ + +/* @(#) $Id$ */ + +#ifndef DEFLATE_H +#define DEFLATE_H + +#include "zutil.h" + +/* define NO_GZIP when compiling if you want to disable gzip header and + trailer creation by deflate(). NO_GZIP would be used to avoid linking in + the crc code when it is not needed. For shared libraries, gzip encoding + should be left enabled. */ +#ifndef NO_GZIP +# define GZIP +#endif + +/* =========================================================================== + * Internal compression state. + */ + +#define LENGTH_CODES 29 +/* number of length codes, not counting the special END_BLOCK code */ + +#define LITERALS 256 +/* number of literal bytes 0..255 */ + +#define L_CODES (LITERALS+1+LENGTH_CODES) +/* number of Literal or Length codes, including the END_BLOCK code */ + +#define D_CODES 30 +/* number of distance codes */ + +#define BL_CODES 19 +/* number of codes used to transfer the bit lengths */ + +#define HEAP_SIZE (2*L_CODES+1) +/* maximum heap size */ + +#define MAX_BITS 15 +/* All codes must not exceed MAX_BITS bits */ + +#define INIT_STATE 42 +#define EXTRA_STATE 69 +#define NAME_STATE 73 +#define COMMENT_STATE 91 +#define HCRC_STATE 103 +#define BUSY_STATE 113 +#define FINISH_STATE 666 +/* Stream status */ + + +/* Data structure describing a single value and its code string. */ +typedef struct ct_data_s { + union { + ush freq; /* frequency count */ + ush code; /* bit string */ + } fc; + union { + ush dad; /* father node in Huffman tree */ + ush len; /* length of bit string */ + } dl; +} FAR ct_data; + +#define Freq fc.freq +#define Code fc.code +#define Dad dl.dad +#define Len dl.len + +typedef struct static_tree_desc_s static_tree_desc; + +typedef struct tree_desc_s { + ct_data *dyn_tree; /* the dynamic tree */ + int max_code; /* largest code with non zero frequency */ + static_tree_desc *stat_desc; /* the corresponding static tree */ +} FAR tree_desc; + +typedef ush Pos; +typedef Pos FAR Posf; +typedef unsigned IPos; + +/* A Pos is an index in the character window. We use short instead of int to + * save space in the various tables. IPos is used only for parameter passing. + */ + +typedef struct internal_state { + z_streamp strm; /* pointer back to this zlib stream */ + int status; /* as the name implies */ + Bytef *pending_buf; /* output still pending */ + ulg pending_buf_size; /* size of pending_buf */ + Bytef *pending_out; /* next pending byte to output to the stream */ + uInt pending; /* nb of bytes in the pending buffer */ + int wrap; /* bit 0 true for zlib, bit 1 true for gzip */ + gz_headerp gzhead; /* gzip header information to write */ + uInt gzindex; /* where in extra, name, or comment */ + Byte method; /* STORED (for zip only) or DEFLATED */ + int last_flush; /* value of flush param for previous deflate call */ + + /* used by deflate.c: */ + + uInt w_size; /* LZ77 window size (32K by default) */ + uInt w_bits; /* log2(w_size) (8..16) */ + uInt w_mask; /* w_size - 1 */ + + Bytef *window; + /* Sliding window. Input bytes are read into the second half of the window, + * and move to the first half later to keep a dictionary of at least wSize + * bytes. With this organization, matches are limited to a distance of + * wSize-MAX_MATCH bytes, but this ensures that IO is always + * performed with a length multiple of the block size. Also, it limits + * the window size to 64K, which is quite useful on MSDOS. + * To do: use the user input buffer as sliding window. + */ + + ulg window_size; + /* Actual size of window: 2*wSize, except when the user input buffer + * is directly used as sliding window. + */ + + Posf *prev; + /* Link to older string with same hash index. To limit the size of this + * array to 64K, this link is maintained only for the last 32K strings. + * An index in this array is thus a window index modulo 32K. + */ + + Posf *head; /* Heads of the hash chains or NIL. */ + + uInt ins_h; /* hash index of string to be inserted */ + uInt hash_size; /* number of elements in hash table */ + uInt hash_bits; /* log2(hash_size) */ + uInt hash_mask; /* hash_size-1 */ + + uInt hash_shift; + /* Number of bits by which ins_h must be shifted at each input + * step. It must be such that after MIN_MATCH steps, the oldest + * byte no longer takes part in the hash key, that is: + * hash_shift * MIN_MATCH >= hash_bits + */ + + long block_start; + /* Window position at the beginning of the current output block. Gets + * negative when the window is moved backwards. + */ + + uInt match_length; /* length of best match */ + IPos prev_match; /* previous match */ + int match_available; /* set if previous match exists */ + uInt strstart; /* start of string to insert */ + uInt match_start; /* start of matching string */ + uInt lookahead; /* number of valid bytes ahead in window */ + + uInt prev_length; + /* Length of the best match at previous step. Matches not greater than this + * are discarded. This is used in the lazy match evaluation. + */ + + uInt max_chain_length; + /* To speed up deflation, hash chains are never searched beyond this + * length. A higher limit improves compression ratio but degrades the + * speed. + */ + + uInt max_lazy_match; + /* Attempt to find a better match only when the current match is strictly + * smaller than this value. This mechanism is used only for compression + * levels >= 4. + */ +# define max_insert_length max_lazy_match + /* Insert new strings in the hash table only if the match length is not + * greater than this length. This saves time but degrades compression. + * max_insert_length is used only for compression levels <= 3. + */ + + int level; /* compression level (1..9) */ + int strategy; /* favor or force Huffman coding*/ + + uInt good_match; + /* Use a faster search when the previous match is longer than this */ + + int nice_match; /* Stop searching when current match exceeds this */ + + /* used by trees.c: */ + /* Didn't use ct_data typedef below to supress compiler warning */ + struct ct_data_s dyn_ltree[HEAP_SIZE]; /* literal and length tree */ + struct ct_data_s dyn_dtree[2*D_CODES+1]; /* distance tree */ + struct ct_data_s bl_tree[2*BL_CODES+1]; /* Huffman tree for bit lengths */ + + struct tree_desc_s l_desc; /* desc. for literal tree */ + struct tree_desc_s d_desc; /* desc. for distance tree */ + struct tree_desc_s bl_desc; /* desc. for bit length tree */ + + ush bl_count[MAX_BITS+1]; + /* number of codes at each bit length for an optimal tree */ + + int heap[2*L_CODES+1]; /* heap used to build the Huffman trees */ + int heap_len; /* number of elements in the heap */ + int heap_max; /* element of largest frequency */ + /* The sons of heap[n] are heap[2*n] and heap[2*n+1]. heap[0] is not used. + * The same heap array is used to build all trees. + */ + + uch depth[2*L_CODES+1]; + /* Depth of each subtree used as tie breaker for trees of equal frequency + */ + + uchf *l_buf; /* buffer for literals or lengths */ + + uInt lit_bufsize; + /* Size of match buffer for literals/lengths. There are 4 reasons for + * limiting lit_bufsize to 64K: + * - frequencies can be kept in 16 bit counters + * - if compression is not successful for the first block, all input + * data is still in the window so we can still emit a stored block even + * when input comes from standard input. (This can also be done for + * all blocks if lit_bufsize is not greater than 32K.) + * - if compression is not successful for a file smaller than 64K, we can + * even emit a stored file instead of a stored block (saving 5 bytes). + * This is applicable only for zip (not gzip or zlib). + * - creating new Huffman trees less frequently may not provide fast + * adaptation to changes in the input data statistics. (Take for + * example a binary file with poorly compressible code followed by + * a highly compressible string table.) Smaller buffer sizes give + * fast adaptation but have of course the overhead of transmitting + * trees more frequently. + * - I can't count above 4 + */ + + uInt last_lit; /* running index in l_buf */ + + ushf *d_buf; + /* Buffer for distances. To simplify the code, d_buf and l_buf have + * the same number of elements. To use different lengths, an extra flag + * array would be necessary. + */ + + ulg opt_len; /* bit length of current block with optimal trees */ + ulg static_len; /* bit length of current block with static trees */ + uInt matches; /* number of string matches in current block */ + int last_eob_len; /* bit length of EOB code for last block */ + +#ifdef DEBUG + ulg compressed_len; /* total bit length of compressed file mod 2^32 */ + ulg bits_sent; /* bit length of compressed data sent mod 2^32 */ +#endif + + ush bi_buf; + /* Output buffer. bits are inserted starting at the bottom (least + * significant bits). + */ + int bi_valid; + /* Number of valid bits in bi_buf. All bits above the last valid bit + * are always zero. + */ + + ulg high_water; + /* High water mark offset in window for initialized bytes -- bytes above + * this are set to zero in order to avoid memory check warnings when + * longest match routines access bytes past the input. This is then + * updated to the new high water mark. + */ + +} FAR deflate_state; + +/* Output a byte on the stream. + * IN assertion: there is enough room in pending_buf. + */ +#define put_byte(s, c) {s->pending_buf[s->pending++] = (c);} + + +#define MIN_LOOKAHEAD (MAX_MATCH+MIN_MATCH+1) +/* Minimum amount of lookahead, except at the end of the input file. + * See deflate.c for comments about the MIN_MATCH+1. + */ + +#define MAX_DIST(s) ((s)->w_size-MIN_LOOKAHEAD) +/* In order to simplify the code, particularly on 16 bit machines, match + * distances are limited to MAX_DIST instead of WSIZE. + */ + +#define WIN_INIT MAX_MATCH +/* Number of bytes after end of data in window to initialize in order to avoid + memory checker errors from longest match routines */ + + /* in trees.c */ +void ZLIB_INTERNAL _tr_init OF((deflate_state *s)); +int ZLIB_INTERNAL _tr_tally OF((deflate_state *s, unsigned dist, unsigned lc)); +void ZLIB_INTERNAL _tr_flush_block OF((deflate_state *s, charf *buf, + ulg stored_len, int last)); +void ZLIB_INTERNAL _tr_align OF((deflate_state *s)); +void ZLIB_INTERNAL _tr_stored_block OF((deflate_state *s, charf *buf, + ulg stored_len, int last)); + +#define d_code(dist) \ + ((dist) < 256 ? _dist_code[dist] : _dist_code[256+((dist)>>7)]) +/* Mapping from a distance to a distance code. dist is the distance - 1 and + * must not have side effects. _dist_code[256] and _dist_code[257] are never + * used. + */ + +#ifndef DEBUG +/* Inline versions of _tr_tally for speed: */ + +#if defined(GEN_TREES_H) || !defined(STDC) + extern uch ZLIB_INTERNAL _length_code[]; + extern uch ZLIB_INTERNAL _dist_code[]; +#else + extern const uch ZLIB_INTERNAL _length_code[]; + extern const uch ZLIB_INTERNAL _dist_code[]; +#endif + +# define _tr_tally_lit(s, c, flush) \ + { uch cc = (c); \ + s->d_buf[s->last_lit] = 0; \ + s->l_buf[s->last_lit++] = cc; \ + s->dyn_ltree[cc].Freq++; \ + flush = (s->last_lit == s->lit_bufsize-1); \ + } +# define _tr_tally_dist(s, distance, length, flush) \ + { uch len = (length); \ + ush dist = (distance); \ + s->d_buf[s->last_lit] = dist; \ + s->l_buf[s->last_lit++] = len; \ + dist--; \ + s->dyn_ltree[_length_code[len]+LITERALS+1].Freq++; \ + s->dyn_dtree[d_code(dist)].Freq++; \ + flush = (s->last_lit == s->lit_bufsize-1); \ + } +#else +# define _tr_tally_lit(s, c, flush) flush = _tr_tally(s, 0, c) +# define _tr_tally_dist(s, distance, length, flush) \ + flush = _tr_tally(s, distance, length) +#endif + +#endif /* DEFLATE_H */ diff --git a/cbits/inffast.h b/cbits/inffast.h new file mode 100644 --- /dev/null +++ b/cbits/inffast.h @@ -0,0 +1,11 @@ +/* inffast.h -- header to use inffast.c + * Copyright (C) 1995-2003, 2010 Mark Adler + * For conditions of distribution and use, see copyright notice in zlib.h + */ + +/* WARNING: this file should *not* be used by applications. It is + part of the implementation of the compression library and is + subject to change. Applications should only use zlib.h. + */ + +void ZLIB_INTERNAL inflate_fast OF((z_streamp strm, unsigned start)); diff --git a/cbits/inffixed.h b/cbits/inffixed.h new file mode 100644 --- /dev/null +++ b/cbits/inffixed.h @@ -0,0 +1,94 @@ + /* inffixed.h -- table for decoding fixed codes + * Generated automatically by makefixed(). + */ + + /* WARNING: this file should *not* be used by applications. It + is part of the implementation of the compression library and + is subject to change. Applications should only use zlib.h. + */ + + static const code lenfix[512] = { + {96,7,0},{0,8,80},{0,8,16},{20,8,115},{18,7,31},{0,8,112},{0,8,48}, + {0,9,192},{16,7,10},{0,8,96},{0,8,32},{0,9,160},{0,8,0},{0,8,128}, + {0,8,64},{0,9,224},{16,7,6},{0,8,88},{0,8,24},{0,9,144},{19,7,59}, + {0,8,120},{0,8,56},{0,9,208},{17,7,17},{0,8,104},{0,8,40},{0,9,176}, + {0,8,8},{0,8,136},{0,8,72},{0,9,240},{16,7,4},{0,8,84},{0,8,20}, + {21,8,227},{19,7,43},{0,8,116},{0,8,52},{0,9,200},{17,7,13},{0,8,100}, + {0,8,36},{0,9,168},{0,8,4},{0,8,132},{0,8,68},{0,9,232},{16,7,8}, + {0,8,92},{0,8,28},{0,9,152},{20,7,83},{0,8,124},{0,8,60},{0,9,216}, + {18,7,23},{0,8,108},{0,8,44},{0,9,184},{0,8,12},{0,8,140},{0,8,76}, + {0,9,248},{16,7,3},{0,8,82},{0,8,18},{21,8,163},{19,7,35},{0,8,114}, + {0,8,50},{0,9,196},{17,7,11},{0,8,98},{0,8,34},{0,9,164},{0,8,2}, + {0,8,130},{0,8,66},{0,9,228},{16,7,7},{0,8,90},{0,8,26},{0,9,148}, + {20,7,67},{0,8,122},{0,8,58},{0,9,212},{18,7,19},{0,8,106},{0,8,42}, + {0,9,180},{0,8,10},{0,8,138},{0,8,74},{0,9,244},{16,7,5},{0,8,86}, + {0,8,22},{64,8,0},{19,7,51},{0,8,118},{0,8,54},{0,9,204},{17,7,15}, + {0,8,102},{0,8,38},{0,9,172},{0,8,6},{0,8,134},{0,8,70},{0,9,236}, + {16,7,9},{0,8,94},{0,8,30},{0,9,156},{20,7,99},{0,8,126},{0,8,62}, + {0,9,220},{18,7,27},{0,8,110},{0,8,46},{0,9,188},{0,8,14},{0,8,142}, + {0,8,78},{0,9,252},{96,7,0},{0,8,81},{0,8,17},{21,8,131},{18,7,31}, + {0,8,113},{0,8,49},{0,9,194},{16,7,10},{0,8,97},{0,8,33},{0,9,162}, + {0,8,1},{0,8,129},{0,8,65},{0,9,226},{16,7,6},{0,8,89},{0,8,25}, + {0,9,146},{19,7,59},{0,8,121},{0,8,57},{0,9,210},{17,7,17},{0,8,105}, + {0,8,41},{0,9,178},{0,8,9},{0,8,137},{0,8,73},{0,9,242},{16,7,4}, + {0,8,85},{0,8,21},{16,8,258},{19,7,43},{0,8,117},{0,8,53},{0,9,202}, + {17,7,13},{0,8,101},{0,8,37},{0,9,170},{0,8,5},{0,8,133},{0,8,69}, + {0,9,234},{16,7,8},{0,8,93},{0,8,29},{0,9,154},{20,7,83},{0,8,125}, + {0,8,61},{0,9,218},{18,7,23},{0,8,109},{0,8,45},{0,9,186},{0,8,13}, + {0,8,141},{0,8,77},{0,9,250},{16,7,3},{0,8,83},{0,8,19},{21,8,195}, + {19,7,35},{0,8,115},{0,8,51},{0,9,198},{17,7,11},{0,8,99},{0,8,35}, + {0,9,166},{0,8,3},{0,8,131},{0,8,67},{0,9,230},{16,7,7},{0,8,91}, + {0,8,27},{0,9,150},{20,7,67},{0,8,123},{0,8,59},{0,9,214},{18,7,19}, + {0,8,107},{0,8,43},{0,9,182},{0,8,11},{0,8,139},{0,8,75},{0,9,246}, + {16,7,5},{0,8,87},{0,8,23},{64,8,0},{19,7,51},{0,8,119},{0,8,55}, + {0,9,206},{17,7,15},{0,8,103},{0,8,39},{0,9,174},{0,8,7},{0,8,135}, + {0,8,71},{0,9,238},{16,7,9},{0,8,95},{0,8,31},{0,9,158},{20,7,99}, + {0,8,127},{0,8,63},{0,9,222},{18,7,27},{0,8,111},{0,8,47},{0,9,190}, + {0,8,15},{0,8,143},{0,8,79},{0,9,254},{96,7,0},{0,8,80},{0,8,16}, + {20,8,115},{18,7,31},{0,8,112},{0,8,48},{0,9,193},{16,7,10},{0,8,96}, + {0,8,32},{0,9,161},{0,8,0},{0,8,128},{0,8,64},{0,9,225},{16,7,6}, + {0,8,88},{0,8,24},{0,9,145},{19,7,59},{0,8,120},{0,8,56},{0,9,209}, + {17,7,17},{0,8,104},{0,8,40},{0,9,177},{0,8,8},{0,8,136},{0,8,72}, + {0,9,241},{16,7,4},{0,8,84},{0,8,20},{21,8,227},{19,7,43},{0,8,116}, + {0,8,52},{0,9,201},{17,7,13},{0,8,100},{0,8,36},{0,9,169},{0,8,4}, + {0,8,132},{0,8,68},{0,9,233},{16,7,8},{0,8,92},{0,8,28},{0,9,153}, + {20,7,83},{0,8,124},{0,8,60},{0,9,217},{18,7,23},{0,8,108},{0,8,44}, + {0,9,185},{0,8,12},{0,8,140},{0,8,76},{0,9,249},{16,7,3},{0,8,82}, + {0,8,18},{21,8,163},{19,7,35},{0,8,114},{0,8,50},{0,9,197},{17,7,11}, + {0,8,98},{0,8,34},{0,9,165},{0,8,2},{0,8,130},{0,8,66},{0,9,229}, + {16,7,7},{0,8,90},{0,8,26},{0,9,149},{20,7,67},{0,8,122},{0,8,58}, + {0,9,213},{18,7,19},{0,8,106},{0,8,42},{0,9,181},{0,8,10},{0,8,138}, + {0,8,74},{0,9,245},{16,7,5},{0,8,86},{0,8,22},{64,8,0},{19,7,51}, + {0,8,118},{0,8,54},{0,9,205},{17,7,15},{0,8,102},{0,8,38},{0,9,173}, + {0,8,6},{0,8,134},{0,8,70},{0,9,237},{16,7,9},{0,8,94},{0,8,30}, + {0,9,157},{20,7,99},{0,8,126},{0,8,62},{0,9,221},{18,7,27},{0,8,110}, + {0,8,46},{0,9,189},{0,8,14},{0,8,142},{0,8,78},{0,9,253},{96,7,0}, + {0,8,81},{0,8,17},{21,8,131},{18,7,31},{0,8,113},{0,8,49},{0,9,195}, + {16,7,10},{0,8,97},{0,8,33},{0,9,163},{0,8,1},{0,8,129},{0,8,65}, + {0,9,227},{16,7,6},{0,8,89},{0,8,25},{0,9,147},{19,7,59},{0,8,121}, + {0,8,57},{0,9,211},{17,7,17},{0,8,105},{0,8,41},{0,9,179},{0,8,9}, + {0,8,137},{0,8,73},{0,9,243},{16,7,4},{0,8,85},{0,8,21},{16,8,258}, + {19,7,43},{0,8,117},{0,8,53},{0,9,203},{17,7,13},{0,8,101},{0,8,37}, + {0,9,171},{0,8,5},{0,8,133},{0,8,69},{0,9,235},{16,7,8},{0,8,93}, + {0,8,29},{0,9,155},{20,7,83},{0,8,125},{0,8,61},{0,9,219},{18,7,23}, + {0,8,109},{0,8,45},{0,9,187},{0,8,13},{0,8,141},{0,8,77},{0,9,251}, + {16,7,3},{0,8,83},{0,8,19},{21,8,195},{19,7,35},{0,8,115},{0,8,51}, + {0,9,199},{17,7,11},{0,8,99},{0,8,35},{0,9,167},{0,8,3},{0,8,131}, + {0,8,67},{0,9,231},{16,7,7},{0,8,91},{0,8,27},{0,9,151},{20,7,67}, + {0,8,123},{0,8,59},{0,9,215},{18,7,19},{0,8,107},{0,8,43},{0,9,183}, + {0,8,11},{0,8,139},{0,8,75},{0,9,247},{16,7,5},{0,8,87},{0,8,23}, + {64,8,0},{19,7,51},{0,8,119},{0,8,55},{0,9,207},{17,7,15},{0,8,103}, + {0,8,39},{0,9,175},{0,8,7},{0,8,135},{0,8,71},{0,9,239},{16,7,9}, + {0,8,95},{0,8,31},{0,9,159},{20,7,99},{0,8,127},{0,8,63},{0,9,223}, + {18,7,27},{0,8,111},{0,8,47},{0,9,191},{0,8,15},{0,8,143},{0,8,79}, + {0,9,255} + }; + + static const code distfix[32] = { + {16,5,1},{23,5,257},{19,5,17},{27,5,4097},{17,5,5},{25,5,1025}, + {21,5,65},{29,5,16385},{16,5,3},{24,5,513},{20,5,33},{28,5,8193}, + {18,5,9},{26,5,2049},{22,5,129},{64,5,0},{16,5,2},{23,5,385}, + {19,5,25},{27,5,6145},{17,5,7},{25,5,1537},{21,5,97},{29,5,24577}, + {16,5,4},{24,5,769},{20,5,49},{28,5,12289},{18,5,13},{26,5,3073}, + {22,5,193},{64,5,0} + }; diff --git a/cbits/inflate.h b/cbits/inflate.h new file mode 100644 --- /dev/null +++ b/cbits/inflate.h @@ -0,0 +1,122 @@ +/* inflate.h -- internal inflate state definition + * Copyright (C) 1995-2009 Mark Adler + * For conditions of distribution and use, see copyright notice in zlib.h + */ + +/* WARNING: this file should *not* be used by applications. It is + part of the implementation of the compression library and is + subject to change. Applications should only use zlib.h. + */ + +/* define NO_GZIP when compiling if you want to disable gzip header and + trailer decoding by inflate(). NO_GZIP would be used to avoid linking in + the crc code when it is not needed. For shared libraries, gzip decoding + should be left enabled. */ +#ifndef NO_GZIP +# define GUNZIP +#endif + +/* Possible inflate modes between inflate() calls */ +typedef enum { + HEAD, /* i: waiting for magic header */ + FLAGS, /* i: waiting for method and flags (gzip) */ + TIME, /* i: waiting for modification time (gzip) */ + OS, /* i: waiting for extra flags and operating system (gzip) */ + EXLEN, /* i: waiting for extra length (gzip) */ + EXTRA, /* i: waiting for extra bytes (gzip) */ + NAME, /* i: waiting for end of file name (gzip) */ + COMMENT, /* i: waiting for end of comment (gzip) */ + HCRC, /* i: waiting for header crc (gzip) */ + DICTID, /* i: waiting for dictionary check value */ + DICT, /* waiting for inflateSetDictionary() call */ + TYPE, /* i: waiting for type bits, including last-flag bit */ + TYPEDO, /* i: same, but skip check to exit inflate on new block */ + STORED, /* i: waiting for stored size (length and complement) */ + COPY_, /* i/o: same as COPY below, but only first time in */ + COPY, /* i/o: waiting for input or output to copy stored block */ + TABLE, /* i: waiting for dynamic block table lengths */ + LENLENS, /* i: waiting for code length code lengths */ + CODELENS, /* i: waiting for length/lit and distance code lengths */ + LEN_, /* i: same as LEN below, but only first time in */ + LEN, /* i: waiting for length/lit/eob code */ + LENEXT, /* i: waiting for length extra bits */ + DIST, /* i: waiting for distance code */ + DISTEXT, /* i: waiting for distance extra bits */ + MATCH, /* o: waiting for output space to copy string */ + LIT, /* o: waiting for output space to write literal */ + CHECK, /* i: waiting for 32-bit check value */ + LENGTH, /* i: waiting for 32-bit length (gzip) */ + DONE, /* finished check, done -- remain here until reset */ + BAD, /* got a data error -- remain here until reset */ + MEM, /* got an inflate() memory error -- remain here until reset */ + SYNC /* looking for synchronization bytes to restart inflate() */ +} inflate_mode; + +/* + State transitions between above modes - + + (most modes can go to BAD or MEM on error -- not shown for clarity) + + Process header: + HEAD -> (gzip) or (zlib) or (raw) + (gzip) -> FLAGS -> TIME -> OS -> EXLEN -> EXTRA -> NAME -> COMMENT -> + HCRC -> TYPE + (zlib) -> DICTID or TYPE + DICTID -> DICT -> TYPE + (raw) -> TYPEDO + Read deflate blocks: + TYPE -> TYPEDO -> STORED or TABLE or LEN_ or CHECK + STORED -> COPY_ -> COPY -> TYPE + TABLE -> LENLENS -> CODELENS -> LEN_ + LEN_ -> LEN + Read deflate codes in fixed or dynamic block: + LEN -> LENEXT or LIT or TYPE + LENEXT -> DIST -> DISTEXT -> MATCH -> LEN + LIT -> LEN + Process trailer: + CHECK -> LENGTH -> DONE + */ + +/* state maintained between inflate() calls. Approximately 10K bytes. */ +struct inflate_state { + inflate_mode mode; /* current inflate mode */ + int last; /* true if processing last block */ + int wrap; /* bit 0 true for zlib, bit 1 true for gzip */ + int havedict; /* true if dictionary provided */ + int flags; /* gzip header method and flags (0 if zlib) */ + unsigned dmax; /* zlib header max distance (INFLATE_STRICT) */ + unsigned long check; /* protected copy of check value */ + unsigned long total; /* protected copy of output count */ + gz_headerp head; /* where to save gzip header information */ + /* sliding window */ + unsigned wbits; /* log base 2 of requested window size */ + unsigned wsize; /* window size or zero if not using window */ + unsigned whave; /* valid bytes in the window */ + unsigned wnext; /* window write index */ + unsigned char FAR *window; /* allocated sliding window, if needed */ + /* bit accumulator */ + unsigned long hold; /* input bit accumulator */ + unsigned bits; /* number of bits in "in" */ + /* for string and stored block copying */ + unsigned length; /* literal or length of data to copy */ + unsigned offset; /* distance back to copy string from */ + /* for table and code decoding */ + unsigned extra; /* extra bits needed */ + /* fixed and dynamic code tables */ + code const FAR *lencode; /* starting table for length/literal codes */ + code const FAR *distcode; /* starting table for distance codes */ + unsigned lenbits; /* index bits for lencode */ + unsigned distbits; /* index bits for distcode */ + /* dynamic table building */ + unsigned ncode; /* number of code length code lengths */ + unsigned nlen; /* number of length code lengths */ + unsigned ndist; /* number of distance code lengths */ + unsigned have; /* number of code lengths in lens[] */ + code FAR *next; /* next available space in codes[] */ + unsigned short lens[320]; /* temporary storage for code lengths */ + unsigned short work[288]; /* work area for code table building */ + code codes[ENOUGH]; /* space for code tables */ + int sane; /* if false, allow invalid distance too far */ + int back; /* bits back of last unprocessed length/lit */ + unsigned was; /* initial length of match */ +}; diff --git a/cbits/inftrees.h b/cbits/inftrees.h new file mode 100644 --- /dev/null +++ b/cbits/inftrees.h @@ -0,0 +1,62 @@ +/* inftrees.h -- header to use inftrees.c + * Copyright (C) 1995-2005, 2010 Mark Adler + * For conditions of distribution and use, see copyright notice in zlib.h + */ + +/* WARNING: this file should *not* be used by applications. It is + part of the implementation of the compression library and is + subject to change. Applications should only use zlib.h. + */ + +/* Structure for decoding tables. Each entry provides either the + information needed to do the operation requested by the code that + indexed that table entry, or it provides a pointer to another + table that indexes more bits of the code. op indicates whether + the entry is a pointer to another table, a literal, a length or + distance, an end-of-block, or an invalid code. For a table + pointer, the low four bits of op is the number of index bits of + that table. For a length or distance, the low four bits of op + is the number of extra bits to get after the code. bits is + the number of bits in this code or part of the code to drop off + of the bit buffer. val is the actual byte to output in the case + of a literal, the base length or distance, or the offset from + the current table to the next table. Each entry is four bytes. */ +typedef struct { + unsigned char op; /* operation, extra bits, table bits */ + unsigned char bits; /* bits in this part of the code */ + unsigned short val; /* offset in table or code value */ +} code; + +/* op values as set by inflate_table(): + 00000000 - literal + 0000tttt - table link, tttt != 0 is the number of table index bits + 0001eeee - length or distance, eeee is the number of extra bits + 01100000 - end of block + 01000000 - invalid code + */ + +/* Maximum size of the dynamic table. The maximum number of code structures is + 1444, which is the sum of 852 for literal/length codes and 592 for distance + codes. These values were found by exhaustive searches using the program + examples/enough.c found in the zlib distribtution. The arguments to that + program are the number of symbols, the initial root table size, and the + maximum bit length of a code. "enough 286 9 15" for literal/length codes + returns returns 852, and "enough 30 6 15" for distance codes returns 592. + The initial root table size (9 or 6) is found in the fifth argument of the + inflate_table() calls in inflate.c and infback.c. If the root table size is + changed, then these maximum sizes would be need to be recalculated and + updated. */ +#define ENOUGH_LENS 852 +#define ENOUGH_DISTS 592 +#define ENOUGH (ENOUGH_LENS+ENOUGH_DISTS) + +/* Type of code to build for inflate_table() */ +typedef enum { + CODES, + LENS, + DISTS +} codetype; + +int ZLIB_INTERNAL inflate_table OF((codetype type, unsigned short FAR *lens, + unsigned codes, code FAR * FAR *table, + unsigned FAR *bits, unsigned short FAR *work)); diff --git a/cbits/initWinSock.c b/cbits/initWinSock.c new file mode 100644 --- /dev/null +++ b/cbits/initWinSock.c @@ -0,0 +1,63 @@ +#include "HsNet.h" +#include "HsFFI.h" + +#if defined(HAVE_WINSOCK2_H) && !defined(__CYGWIN__) + +static int winsock_inited = 0; +static int winsock_uninited = 0; + +/* Initialising WinSock... */ +int +initWinSock () +{ + WORD wVersionRequested; + WSADATA wsaData; + int err; +#ifdef __HUGS__ + int optval = SO_SYNCHRONOUS_NONALERT; +#endif + + if (!winsock_inited) { + wVersionRequested = MAKEWORD( 1, 1 ); + + err = WSAStartup ( wVersionRequested, &wsaData ); + + if ( err != 0 ) { + return err; + } + + if ( LOBYTE( wsaData.wVersion ) != 1 || + HIBYTE( wsaData.wVersion ) != 1 ) { + WSACleanup(); + return (-1); + } +#ifdef __HUGS__ + /* By default, socket() creates sockets in overlapped mode + * (so that async I/O is possible). The CRT can only handle + * non-overlapped sockets, so turn off overlap mode here. + */ + setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, + &optval, sizeof(optval)); +#endif + + winsock_inited = 1; + } + return 0; +} + +static void +shutdownHandler(void) +{ + WSACleanup(); +} + +void +shutdownWinSock() +{ + if (!winsock_uninited) { + atexit(shutdownHandler); + winsock_uninited = 1; + } +} + +#endif diff --git a/cbits/trees.h b/cbits/trees.h new file mode 100644 --- /dev/null +++ b/cbits/trees.h @@ -0,0 +1,128 @@ +/* header created automatically with -DGEN_TREES_H */ + +local const ct_data static_ltree[L_CODES+2] = { +{{ 12},{ 8}}, {{140},{ 8}}, {{ 76},{ 8}}, {{204},{ 8}}, {{ 44},{ 8}}, +{{172},{ 8}}, {{108},{ 8}}, {{236},{ 8}}, {{ 28},{ 8}}, {{156},{ 8}}, +{{ 92},{ 8}}, {{220},{ 8}}, {{ 60},{ 8}}, {{188},{ 8}}, {{124},{ 8}}, +{{252},{ 8}}, {{ 2},{ 8}}, {{130},{ 8}}, {{ 66},{ 8}}, {{194},{ 8}}, +{{ 34},{ 8}}, {{162},{ 8}}, {{ 98},{ 8}}, {{226},{ 8}}, {{ 18},{ 8}}, +{{146},{ 8}}, {{ 82},{ 8}}, {{210},{ 8}}, {{ 50},{ 8}}, {{178},{ 8}}, +{{114},{ 8}}, {{242},{ 8}}, {{ 10},{ 8}}, {{138},{ 8}}, {{ 74},{ 8}}, +{{202},{ 8}}, {{ 42},{ 8}}, {{170},{ 8}}, {{106},{ 8}}, {{234},{ 8}}, +{{ 26},{ 8}}, {{154},{ 8}}, {{ 90},{ 8}}, {{218},{ 8}}, {{ 58},{ 8}}, +{{186},{ 8}}, {{122},{ 8}}, {{250},{ 8}}, {{ 6},{ 8}}, {{134},{ 8}}, +{{ 70},{ 8}}, {{198},{ 8}}, {{ 38},{ 8}}, {{166},{ 8}}, {{102},{ 8}}, +{{230},{ 8}}, {{ 22},{ 8}}, {{150},{ 8}}, {{ 86},{ 8}}, {{214},{ 8}}, +{{ 54},{ 8}}, {{182},{ 8}}, {{118},{ 8}}, {{246},{ 8}}, {{ 14},{ 8}}, +{{142},{ 8}}, {{ 78},{ 8}}, {{206},{ 8}}, {{ 46},{ 8}}, {{174},{ 8}}, +{{110},{ 8}}, {{238},{ 8}}, {{ 30},{ 8}}, {{158},{ 8}}, {{ 94},{ 8}}, +{{222},{ 8}}, {{ 62},{ 8}}, {{190},{ 8}}, {{126},{ 8}}, {{254},{ 8}}, +{{ 1},{ 8}}, {{129},{ 8}}, {{ 65},{ 8}}, {{193},{ 8}}, {{ 33},{ 8}}, +{{161},{ 8}}, {{ 97},{ 8}}, {{225},{ 8}}, {{ 17},{ 8}}, {{145},{ 8}}, +{{ 81},{ 8}}, {{209},{ 8}}, {{ 49},{ 8}}, {{177},{ 8}}, {{113},{ 8}}, +{{241},{ 8}}, {{ 9},{ 8}}, {{137},{ 8}}, {{ 73},{ 8}}, {{201},{ 8}}, +{{ 41},{ 8}}, {{169},{ 8}}, {{105},{ 8}}, {{233},{ 8}}, {{ 25},{ 8}}, +{{153},{ 8}}, {{ 89},{ 8}}, {{217},{ 8}}, {{ 57},{ 8}}, {{185},{ 8}}, +{{121},{ 8}}, {{249},{ 8}}, {{ 5},{ 8}}, {{133},{ 8}}, {{ 69},{ 8}}, +{{197},{ 8}}, {{ 37},{ 8}}, {{165},{ 8}}, {{101},{ 8}}, {{229},{ 8}}, +{{ 21},{ 8}}, {{149},{ 8}}, {{ 85},{ 8}}, {{213},{ 8}}, {{ 53},{ 8}}, +{{181},{ 8}}, {{117},{ 8}}, {{245},{ 8}}, {{ 13},{ 8}}, {{141},{ 8}}, +{{ 77},{ 8}}, {{205},{ 8}}, {{ 45},{ 8}}, {{173},{ 8}}, {{109},{ 8}}, +{{237},{ 8}}, {{ 29},{ 8}}, {{157},{ 8}}, {{ 93},{ 8}}, {{221},{ 8}}, +{{ 61},{ 8}}, {{189},{ 8}}, {{125},{ 8}}, {{253},{ 8}}, {{ 19},{ 9}}, +{{275},{ 9}}, {{147},{ 9}}, {{403},{ 9}}, {{ 83},{ 9}}, {{339},{ 9}}, +{{211},{ 9}}, {{467},{ 9}}, {{ 51},{ 9}}, {{307},{ 9}}, {{179},{ 9}}, +{{435},{ 9}}, {{115},{ 9}}, {{371},{ 9}}, {{243},{ 9}}, {{499},{ 9}}, +{{ 11},{ 9}}, {{267},{ 9}}, {{139},{ 9}}, {{395},{ 9}}, {{ 75},{ 9}}, +{{331},{ 9}}, {{203},{ 9}}, {{459},{ 9}}, {{ 43},{ 9}}, {{299},{ 9}}, +{{171},{ 9}}, {{427},{ 9}}, {{107},{ 9}}, {{363},{ 9}}, {{235},{ 9}}, +{{491},{ 9}}, {{ 27},{ 9}}, {{283},{ 9}}, {{155},{ 9}}, {{411},{ 9}}, +{{ 91},{ 9}}, {{347},{ 9}}, {{219},{ 9}}, {{475},{ 9}}, {{ 59},{ 9}}, +{{315},{ 9}}, {{187},{ 9}}, {{443},{ 9}}, {{123},{ 9}}, {{379},{ 9}}, +{{251},{ 9}}, {{507},{ 9}}, {{ 7},{ 9}}, {{263},{ 9}}, {{135},{ 9}}, +{{391},{ 9}}, {{ 71},{ 9}}, {{327},{ 9}}, {{199},{ 9}}, {{455},{ 9}}, +{{ 39},{ 9}}, {{295},{ 9}}, {{167},{ 9}}, {{423},{ 9}}, {{103},{ 9}}, +{{359},{ 9}}, {{231},{ 9}}, {{487},{ 9}}, {{ 23},{ 9}}, {{279},{ 9}}, +{{151},{ 9}}, {{407},{ 9}}, {{ 87},{ 9}}, {{343},{ 9}}, {{215},{ 9}}, +{{471},{ 9}}, {{ 55},{ 9}}, {{311},{ 9}}, {{183},{ 9}}, {{439},{ 9}}, +{{119},{ 9}}, {{375},{ 9}}, {{247},{ 9}}, {{503},{ 9}}, {{ 15},{ 9}}, +{{271},{ 9}}, {{143},{ 9}}, {{399},{ 9}}, {{ 79},{ 9}}, {{335},{ 9}}, +{{207},{ 9}}, {{463},{ 9}}, {{ 47},{ 9}}, {{303},{ 9}}, {{175},{ 9}}, +{{431},{ 9}}, {{111},{ 9}}, {{367},{ 9}}, {{239},{ 9}}, {{495},{ 9}}, +{{ 31},{ 9}}, {{287},{ 9}}, {{159},{ 9}}, {{415},{ 9}}, {{ 95},{ 9}}, +{{351},{ 9}}, {{223},{ 9}}, {{479},{ 9}}, {{ 63},{ 9}}, {{319},{ 9}}, +{{191},{ 9}}, {{447},{ 9}}, {{127},{ 9}}, {{383},{ 9}}, {{255},{ 9}}, +{{511},{ 9}}, {{ 0},{ 7}}, {{ 64},{ 7}}, {{ 32},{ 7}}, {{ 96},{ 7}}, +{{ 16},{ 7}}, {{ 80},{ 7}}, {{ 48},{ 7}}, {{112},{ 7}}, {{ 8},{ 7}}, +{{ 72},{ 7}}, {{ 40},{ 7}}, {{104},{ 7}}, {{ 24},{ 7}}, {{ 88},{ 7}}, +{{ 56},{ 7}}, {{120},{ 7}}, {{ 4},{ 7}}, {{ 68},{ 7}}, {{ 36},{ 7}}, +{{100},{ 7}}, {{ 20},{ 7}}, {{ 84},{ 7}}, {{ 52},{ 7}}, {{116},{ 7}}, +{{ 3},{ 8}}, {{131},{ 8}}, {{ 67},{ 8}}, {{195},{ 8}}, {{ 35},{ 8}}, +{{163},{ 8}}, {{ 99},{ 8}}, {{227},{ 8}} +}; + +local const ct_data static_dtree[D_CODES] = { +{{ 0},{ 5}}, {{16},{ 5}}, {{ 8},{ 5}}, {{24},{ 5}}, {{ 4},{ 5}}, +{{20},{ 5}}, {{12},{ 5}}, {{28},{ 5}}, {{ 2},{ 5}}, {{18},{ 5}}, +{{10},{ 5}}, {{26},{ 5}}, {{ 6},{ 5}}, {{22},{ 5}}, {{14},{ 5}}, +{{30},{ 5}}, {{ 1},{ 5}}, {{17},{ 5}}, {{ 9},{ 5}}, {{25},{ 5}}, +{{ 5},{ 5}}, {{21},{ 5}}, {{13},{ 5}}, {{29},{ 5}}, {{ 3},{ 5}}, +{{19},{ 5}}, {{11},{ 5}}, {{27},{ 5}}, {{ 7},{ 5}}, {{23},{ 5}} +}; + +const uch ZLIB_INTERNAL _dist_code[DIST_CODE_LEN] = { + 0, 1, 2, 3, 4, 4, 5, 5, 6, 6, 6, 6, 7, 7, 7, 7, 8, 8, 8, 8, + 8, 8, 8, 8, 9, 9, 9, 9, 9, 9, 9, 9, 10, 10, 10, 10, 10, 10, 10, 10, +10, 10, 10, 10, 10, 10, 10, 10, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, +11, 11, 11, 11, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, +12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 13, 13, 13, 13, +13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, +13, 13, 13, 13, 13, 13, 13, 13, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, +14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, +14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, +14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 15, 15, 15, 15, 15, 15, 15, 15, +15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, +15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, +15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 16, 17, +18, 18, 19, 19, 20, 20, 20, 20, 21, 21, 21, 21, 22, 22, 22, 22, 22, 22, 22, 22, +23, 23, 23, 23, 23, 23, 23, 23, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, +24, 24, 24, 24, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, +26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, +26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 27, 27, 27, 27, 27, 27, 27, 27, +27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, +27, 27, 27, 27, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, +28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, +28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, +28, 28, 28, 28, 28, 28, 28, 28, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, +29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, +29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, +29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29 +}; + +const uch ZLIB_INTERNAL _length_code[MAX_MATCH-MIN_MATCH+1]= { + 0, 1, 2, 3, 4, 5, 6, 7, 8, 8, 9, 9, 10, 10, 11, 11, 12, 12, 12, 12, +13, 13, 13, 13, 14, 14, 14, 14, 15, 15, 15, 15, 16, 16, 16, 16, 16, 16, 16, 16, +17, 17, 17, 17, 17, 17, 17, 17, 18, 18, 18, 18, 18, 18, 18, 18, 19, 19, 19, 19, +19, 19, 19, 19, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, +21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 22, 22, 22, 22, +22, 22, 22, 22, 22, 22, 22, 22, 22, 22, 22, 22, 23, 23, 23, 23, 23, 23, 23, 23, +23, 23, 23, 23, 23, 23, 23, 23, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, +24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, +25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, +25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 26, 26, 26, 26, 26, 26, 26, 26, +26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, +26, 26, 26, 26, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, +27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 28 +}; + +local const int base_length[LENGTH_CODES] = { +0, 1, 2, 3, 4, 5, 6, 7, 8, 10, 12, 14, 16, 20, 24, 28, 32, 40, 48, 56, +64, 80, 96, 112, 128, 160, 192, 224, 0 +}; + +local const int base_dist[D_CODES] = { + 0, 1, 2, 3, 4, 6, 8, 12, 16, 24, + 32, 48, 64, 96, 128, 192, 256, 384, 512, 768, + 1024, 1536, 2048, 3072, 4096, 6144, 8192, 12288, 16384, 24576 +}; + diff --git a/cbits/winSockErr.c b/cbits/winSockErr.c new file mode 100644 --- /dev/null +++ b/cbits/winSockErr.c @@ -0,0 +1,76 @@ +#include "HsNet.h" +#include "HsFFI.h" + +#if defined(HAVE_WINSOCK2_H) && !defined(__CYGWIN__) +#include + +/* to the end */ + +const char* +getWSErrorDescr(int err) +{ + static char otherErrMsg[256]; + + switch (err) { + case WSAEINTR: return "Interrupted function call (WSAEINTR)"; + case WSAEBADF: return "bad socket descriptor (WSAEBADF)"; + case WSAEACCES: return "Permission denied (WSAEACCESS)"; + case WSAEFAULT: return "Bad address (WSAEFAULT)"; + case WSAEINVAL: return "Invalid argument (WSAEINVAL)"; + case WSAEMFILE: return "Too many open files (WSAEMFILE)"; + case WSAEWOULDBLOCK: return "Resource temporarily unavailable (WSAEWOULDBLOCK)"; + case WSAEINPROGRESS: return "Operation now in progress (WSAEINPROGRESS)"; + case WSAEALREADY: return "Operation already in progress (WSAEALREADY)"; + case WSAENOTSOCK: return "Socket operation on non-socket (WSAENOTSOCK)"; + case WSAEDESTADDRREQ: return "Destination address required (WSAEDESTADDRREQ)"; + case WSAEMSGSIZE: return "Message too long (WSAEMSGSIZE)"; + case WSAEPROTOTYPE: return "Protocol wrong type for socket (WSAEPROTOTYPE)"; + case WSAENOPROTOOPT: return "Bad protocol option (WSAENOPROTOOPT)"; + case WSAEPROTONOSUPPORT: return "Protocol not supported (WSAEPROTONOSUPPORT)"; + case WSAESOCKTNOSUPPORT: return "Socket type not supported (WSAESOCKTNOSUPPORT)"; + case WSAEOPNOTSUPP: return "Operation not supported (WSAEOPNOTSUPP)"; + case WSAEPFNOSUPPORT: return "Protocol family not supported (WSAEPFNOSUPPORT)"; + case WSAEAFNOSUPPORT: return "Address family not supported by protocol family (WSAEAFNOSUPPORT)"; + case WSAEADDRINUSE: return "Address already in use (WSAEADDRINUSE)"; + case WSAEADDRNOTAVAIL: return "Cannot assign requested address (WSAEADDRNOTAVAIL)"; + case WSAENETDOWN: return "Network is down (WSAENETDOWN)"; + case WSAENETUNREACH: return "Network is unreachable (WSAENETUNREACH)"; + case WSAENETRESET: return "Network dropped connection on reset (WSAENETRESET)"; + case WSAECONNABORTED: return "Software caused connection abort (WSAECONNABORTED)"; + case WSAECONNRESET: return "Connection reset by peer (WSAECONNRESET)"; + case WSAENOBUFS: return "No buffer space available (WSAENOBUFS)"; + case WSAEISCONN: return "Socket is already connected (WSAEISCONN)"; + case WSAENOTCONN: return "Socket is not connected (WSAENOTCONN)"; + case WSAESHUTDOWN: return "Cannot send after socket shutdown (WSAESHUTDOWN)"; + case WSAETOOMANYREFS: return "Too many references (WSAETOOMANYREFS)"; + case WSAETIMEDOUT: return "Connection timed out (WSAETIMEDOUT)"; + case WSAECONNREFUSED: return "Connection refused (WSAECONNREFUSED)"; + case WSAELOOP: return "Too many levels of symbolic links (WSAELOOP)"; + case WSAENAMETOOLONG: return "Filename too long (WSAENAMETOOLONG)"; + case WSAEHOSTDOWN: return "Host is down (WSAEHOSTDOWN)"; + case WSAEHOSTUNREACH: return "Host is unreachable (WSAEHOSTUNREACH)"; + case WSAENOTEMPTY: return "Resource not empty (WSAENOTEMPTY)"; + case WSAEPROCLIM: return "Too many processes (WSAEPROCLIM)"; + case WSAEUSERS: return "Too many users (WSAEUSERS)"; + case WSAEDQUOT: return "Disk quota exceeded (WSAEDQUOT)"; + case WSAESTALE: return "Stale NFS file handle (WSAESTALE)"; + case WSAEREMOTE: return "Too many levels of remote in path (WSAEREMOTE)"; + case WSAEDISCON: return "Graceful shutdown in progress (WSAEDISCON)"; + case WSASYSNOTREADY: return "Network subsystem is unavailable (WSASYSNOTREADY)"; + case WSAVERNOTSUPPORTED: return "Winsock.dll version out of range (WSAVERNOTSUPPORTED)"; + case WSANOTINITIALISED: return "Successful WSAStartup not yet performed (WSANOTINITIALISED)"; +#ifdef WSATYPE_NOT_FOUND + case WSATYPE_NOT_FOUND: return "Class type not found (WSATYPE_NOT_FOUND)"; +#endif + case WSAHOST_NOT_FOUND: return "Host not found (WSAHOST_NOT_FOUND)"; + case WSATRY_AGAIN: return "Nonauthoritative host not found (WSATRY_AGAIN)"; + case WSANO_RECOVERY: return "This is a nonrecoverable error (WSANO_RECOVERY)"; + case WSANO_DATA: return "Valid name, no data record of requested type (WSANO_DATA)"; + default: + sprintf(otherErrMsg, "Unknown WinSock error: %u", err); + return otherErrMsg; + } +} + +#endif + diff --git a/cbits/zutil.h b/cbits/zutil.h new file mode 100644 --- /dev/null +++ b/cbits/zutil.h @@ -0,0 +1,274 @@ +/* zutil.h -- internal interface and configuration of the compression library + * Copyright (C) 1995-2010 Jean-loup Gailly. + * For conditions of distribution and use, see copyright notice in zlib.h + */ + +/* WARNING: this file should *not* be used by applications. It is + part of the implementation of the compression library and is + subject to change. Applications should only use zlib.h. + */ + +/* @(#) $Id$ */ + +#ifndef ZUTIL_H +#define ZUTIL_H + +#if ((__GNUC__-0) * 10 + __GNUC_MINOR__-0 >= 33) && !defined(NO_VIZ) +# define ZLIB_INTERNAL __attribute__((visibility ("hidden"))) +#else +# define ZLIB_INTERNAL +#endif + +#include "zlib.h" + +#ifdef STDC +# if !(defined(_WIN32_WCE) && defined(_MSC_VER)) +# include +# endif +# include +# include +#endif + +#ifndef local +# define local static +#endif +/* compile with -Dlocal if your debugger can't find static symbols */ + +typedef unsigned char uch; +typedef uch FAR uchf; +typedef unsigned short ush; +typedef ush FAR ushf; +typedef unsigned long ulg; + +extern const char * const z_errmsg[10]; /* indexed by 2-zlib_error */ +/* (size given to avoid silly warnings with Visual C++) */ + +#define ERR_MSG(err) z_errmsg[Z_NEED_DICT-(err)] + +#define ERR_RETURN(strm,err) \ + return (strm->msg = (char*)ERR_MSG(err), (err)) +/* To be used only when the state is known to be valid */ + + /* common constants */ + +#ifndef DEF_WBITS +# define DEF_WBITS MAX_WBITS +#endif +/* default windowBits for decompression. MAX_WBITS is for compression only */ + +#if MAX_MEM_LEVEL >= 8 +# define DEF_MEM_LEVEL 8 +#else +# define DEF_MEM_LEVEL MAX_MEM_LEVEL +#endif +/* default memLevel */ + +#define STORED_BLOCK 0 +#define STATIC_TREES 1 +#define DYN_TREES 2 +/* The three kinds of block type */ + +#define MIN_MATCH 3 +#define MAX_MATCH 258 +/* The minimum and maximum match lengths */ + +#define PRESET_DICT 0x20 /* preset dictionary flag in zlib header */ + + /* target dependencies */ + +#if defined(MSDOS) || (defined(WINDOWS) && !defined(WIN32)) +# define OS_CODE 0x00 +# if defined(__TURBOC__) || defined(__BORLANDC__) +# if (__STDC__ == 1) && (defined(__LARGE__) || defined(__COMPACT__)) + /* Allow compilation with ANSI keywords only enabled */ + void _Cdecl farfree( void *block ); + void *_Cdecl farmalloc( unsigned long nbytes ); +# else +# include +# endif +# else /* MSC or DJGPP */ +# include +# endif +#endif + +#ifdef AMIGA +# define OS_CODE 0x01 +#endif + +#if defined(VAXC) || defined(VMS) +# define OS_CODE 0x02 +# define F_OPEN(name, mode) \ + fopen((name), (mode), "mbc=60", "ctx=stm", "rfm=fix", "mrs=512") +#endif + +#if defined(ATARI) || defined(atarist) +# define OS_CODE 0x05 +#endif + +#ifdef OS2 +# define OS_CODE 0x06 +# ifdef M_I86 +# include +# endif +#endif + +#if defined(MACOS) || defined(TARGET_OS_MAC) +# define OS_CODE 0x07 +# if defined(__MWERKS__) && __dest_os != __be_os && __dest_os != __win32_os +# include /* for fdopen */ +# else +# ifndef fdopen +# define fdopen(fd,mode) NULL /* No fdopen() */ +# endif +# endif +#endif + +#ifdef TOPS20 +# define OS_CODE 0x0a +#endif + +#ifdef WIN32 +# ifndef __CYGWIN__ /* Cygwin is Unix, not Win32 */ +# define OS_CODE 0x0b +# endif +#endif + +#ifdef __50SERIES /* Prime/PRIMOS */ +# define OS_CODE 0x0f +#endif + +#if defined(_BEOS_) || defined(RISCOS) +# define fdopen(fd,mode) NULL /* No fdopen() */ +#endif + +#if (defined(_MSC_VER) && (_MSC_VER > 600)) && !defined __INTERIX +# if defined(_WIN32_WCE) +# define fdopen(fd,mode) NULL /* No fdopen() */ +# ifndef _PTRDIFF_T_DEFINED + typedef int ptrdiff_t; +# define _PTRDIFF_T_DEFINED +# endif +# else +# define fdopen(fd,type) _fdopen(fd,type) +# endif +#endif + +#if defined(__BORLANDC__) + #pragma warn -8004 + #pragma warn -8008 + #pragma warn -8066 +#endif + +/* provide prototypes for these when building zlib without LFS */ +#if !defined(_LARGEFILE64_SOURCE) || _LFS64_LARGEFILE-0 == 0 + ZEXTERN uLong ZEXPORT adler32_combine64 OF((uLong, uLong, z_off_t)); + ZEXTERN uLong ZEXPORT crc32_combine64 OF((uLong, uLong, z_off_t)); +#endif + + /* common defaults */ + +#ifndef OS_CODE +# define OS_CODE 0x03 /* assume Unix */ +#endif + +#ifndef F_OPEN +# define F_OPEN(name, mode) fopen((name), (mode)) +#endif + + /* functions */ + +#if defined(STDC99) || (defined(__TURBOC__) && __TURBOC__ >= 0x550) +# ifndef HAVE_VSNPRINTF +# define HAVE_VSNPRINTF +# endif +#endif +#if defined(__CYGWIN__) +# ifndef HAVE_VSNPRINTF +# define HAVE_VSNPRINTF +# endif +#endif +#ifndef HAVE_VSNPRINTF +# ifdef MSDOS + /* vsnprintf may exist on some MS-DOS compilers (DJGPP?), + but for now we just assume it doesn't. */ +# define NO_vsnprintf +# endif +# ifdef __TURBOC__ +# define NO_vsnprintf +# endif +# ifdef WIN32 + /* In Win32, vsnprintf is available as the "non-ANSI" _vsnprintf. */ +# if !defined(vsnprintf) && !defined(NO_vsnprintf) +# if !defined(_MSC_VER) || ( defined(_MSC_VER) && _MSC_VER < 1500 ) +# define vsnprintf _vsnprintf +# endif +# endif +# endif +# ifdef __SASC +# define NO_vsnprintf +# endif +#endif +#ifdef VMS +# define NO_vsnprintf +#endif + +#if defined(pyr) +# define NO_MEMCPY +#endif +#if defined(SMALL_MEDIUM) && !defined(_MSC_VER) && !defined(__SC__) + /* Use our own functions for small and medium model with MSC <= 5.0. + * You may have to use the same strategy for Borland C (untested). + * The __SC__ check is for Symantec. + */ +# define NO_MEMCPY +#endif +#if defined(STDC) && !defined(HAVE_MEMCPY) && !defined(NO_MEMCPY) +# define HAVE_MEMCPY +#endif +#ifdef HAVE_MEMCPY +# ifdef SMALL_MEDIUM /* MSDOS small or medium model */ +# define zmemcpy _fmemcpy +# define zmemcmp _fmemcmp +# define zmemzero(dest, len) _fmemset(dest, 0, len) +# else +# define zmemcpy memcpy +# define zmemcmp memcmp +# define zmemzero(dest, len) memset(dest, 0, len) +# endif +#else + void ZLIB_INTERNAL zmemcpy OF((Bytef* dest, const Bytef* source, uInt len)); + int ZLIB_INTERNAL zmemcmp OF((const Bytef* s1, const Bytef* s2, uInt len)); + void ZLIB_INTERNAL zmemzero OF((Bytef* dest, uInt len)); +#endif + +/* Diagnostic functions */ +#ifdef DEBUG +# include + extern int ZLIB_INTERNAL z_verbose; + extern void ZLIB_INTERNAL z_error OF((char *m)); +# define Assert(cond,msg) {if(!(cond)) z_error(msg);} +# define Trace(x) {if (z_verbose>=0) fprintf x ;} +# define Tracev(x) {if (z_verbose>0) fprintf x ;} +# define Tracevv(x) {if (z_verbose>1) fprintf x ;} +# define Tracec(c,x) {if (z_verbose>0 && (c)) fprintf x ;} +# define Tracecv(c,x) {if (z_verbose>1 && (c)) fprintf x ;} +#else +# define Assert(cond,msg) +# define Trace(x) +# define Tracev(x) +# define Tracevv(x) +# define Tracec(c,x) +# define Tracecv(c,x) +#endif + + +voidpf ZLIB_INTERNAL zcalloc OF((voidpf opaque, unsigned items, + unsigned size)); +void ZLIB_INTERNAL zcfree OF((voidpf opaque, voidpf ptr)); + +#define ZALLOC(strm, items, size) \ + (*((strm)->zalloc))((strm)->opaque, (items), (size)) +#define ZFREE(strm, addr) (*((strm)->zfree))((strm)->opaque, (voidpf)(addr)) +#define TRY_FREE(s, p) {if (p) ZFREE(s, p);} + +#endif /* ZUTIL_H */ diff --git a/config.guess b/config.guess new file mode 100644 --- /dev/null +++ b/config.guess @@ -0,0 +1,1497 @@ +#! /bin/sh +# Attempt to guess a canonical system name. +# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, +# 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation, Inc. + +timestamp='2006-02-23' + +# This file is free software; you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 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 +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, MA +# 02110-1301, USA. +# +# As a special exception to the GNU General Public License, if you +# distribute this file as part of a program that contains a +# configuration script generated by Autoconf, you may include it under +# the same distribution terms that you use for the rest of that program. + + +# Originally written by Per Bothner . +# Please send patches to . Submit a context +# diff and a properly formatted ChangeLog entry. +# +# This script attempts to guess a canonical system name similar to +# config.sub. If it succeeds, it prints the system name on stdout, and +# exits with 0. Otherwise, it exits with 1. +# +# The plan is that this can be called by configure scripts if you +# don't specify an explicit build system type. + +me=`echo "$0" | sed -e 's,.*/,,'` + +usage="\ +Usage: $0 [OPTION] + +Output the configuration name of the system \`$me' is run on. + +Operation modes: + -h, --help print this help, then exit + -t, --time-stamp print date of last modification, then exit + -v, --version print version number, then exit + +Report bugs and patches to ." + +version="\ +GNU config.guess ($timestamp) + +Originally written by Per Bothner. +Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005 +Free Software Foundation, Inc. + +This is free software; see the source for copying conditions. There is NO +warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." + +help=" +Try \`$me --help' for more information." + +# Parse command line +while test $# -gt 0 ; do + case $1 in + --time-stamp | --time* | -t ) + echo "$timestamp" ; exit ;; + --version | -v ) + echo "$version" ; exit ;; + --help | --h* | -h ) + echo "$usage"; exit ;; + -- ) # Stop option processing + shift; break ;; + - ) # Use stdin as input. + break ;; + -* ) + echo "$me: invalid option $1$help" >&2 + exit 1 ;; + * ) + break ;; + esac +done + +if test $# != 0; then + echo "$me: too many arguments$help" >&2 + exit 1 +fi + +trap 'exit 1' 1 2 15 + +# CC_FOR_BUILD -- compiler used by this script. Note that the use of a +# compiler to aid in system detection is discouraged as it requires +# temporary files to be created and, as you can see below, it is a +# headache to deal with in a portable fashion. + +# Historically, `CC_FOR_BUILD' used to be named `HOST_CC'. We still +# use `HOST_CC' if defined, but it is deprecated. + +# Portable tmp directory creation inspired by the Autoconf team. + +set_cc_for_build=' +trap "exitcode=\$?; (rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null) && exit \$exitcode" 0 ; +trap "rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null; exit 1" 1 2 13 15 ; +: ${TMPDIR=/tmp} ; + { tmp=`(umask 077 && mktemp -d "$TMPDIR/cgXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" ; } || + { test -n "$RANDOM" && tmp=$TMPDIR/cg$$-$RANDOM && (umask 077 && mkdir $tmp) ; } || + { tmp=$TMPDIR/cg-$$ && (umask 077 && mkdir $tmp) && echo "Warning: creating insecure temp directory" >&2 ; } || + { echo "$me: cannot create a temporary directory in $TMPDIR" >&2 ; exit 1 ; } ; +dummy=$tmp/dummy ; +tmpfiles="$dummy.c $dummy.o $dummy.rel $dummy" ; +case $CC_FOR_BUILD,$HOST_CC,$CC in + ,,) echo "int x;" > $dummy.c ; + for c in cc gcc c89 c99 ; do + if ($c -c -o $dummy.o $dummy.c) >/dev/null 2>&1 ; then + CC_FOR_BUILD="$c"; break ; + fi ; + done ; + if test x"$CC_FOR_BUILD" = x ; then + CC_FOR_BUILD=no_compiler_found ; + fi + ;; + ,,*) CC_FOR_BUILD=$CC ;; + ,*,*) CC_FOR_BUILD=$HOST_CC ;; +esac ; set_cc_for_build= ;' + +# This is needed to find uname on a Pyramid OSx when run in the BSD universe. +# (ghazi@noc.rutgers.edu 1994-08-24) +if (test -f /.attbin/uname) >/dev/null 2>&1 ; then + PATH=$PATH:/.attbin ; export PATH +fi + +UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown +UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown +UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown +UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown + +# Note: order is significant - the case branches are not exclusive. + +case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in + *:NetBSD:*:*) + # NetBSD (nbsd) targets should (where applicable) match one or + # more of the tupples: *-*-netbsdelf*, *-*-netbsdaout*, + # *-*-netbsdecoff* and *-*-netbsd*. For targets that recently + # switched to ELF, *-*-netbsd* would select the old + # object file format. This provides both forward + # compatibility and a consistent mechanism for selecting the + # object file format. + # + # Note: NetBSD doesn't particularly care about the vendor + # portion of the name. We always set it to "unknown". + sysctl="sysctl -n hw.machine_arch" + UNAME_MACHINE_ARCH=`(/sbin/$sysctl 2>/dev/null || \ + /usr/sbin/$sysctl 2>/dev/null || echo unknown)` + case "${UNAME_MACHINE_ARCH}" in + armeb) machine=armeb-unknown ;; + arm*) machine=arm-unknown ;; + sh3el) machine=shl-unknown ;; + sh3eb) machine=sh-unknown ;; + *) machine=${UNAME_MACHINE_ARCH}-unknown ;; + esac + # The Operating System including object format, if it has switched + # to ELF recently, or will in the future. + case "${UNAME_MACHINE_ARCH}" in + arm*|i386|m68k|ns32k|sh3*|sparc|vax) + eval $set_cc_for_build + if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \ + | grep __ELF__ >/dev/null + then + # Once all utilities can be ECOFF (netbsdecoff) or a.out (netbsdaout). + # Return netbsd for either. FIX? + os=netbsd + else + os=netbsdelf + fi + ;; + *) + os=netbsd + ;; + esac + # The OS release + # Debian GNU/NetBSD machines have a different userland, and + # thus, need a distinct triplet. However, they do not need + # kernel version information, so it can be replaced with a + # suitable tag, in the style of linux-gnu. + case "${UNAME_VERSION}" in + Debian*) + release='-gnu' + ;; + *) + release=`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'` + ;; + esac + # Since CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM: + # contains redundant information, the shorter form: + # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used. + echo "${machine}-${os}${release}" + exit ;; + *:OpenBSD:*:*) + UNAME_MACHINE_ARCH=`arch | sed 's/OpenBSD.//'` + echo ${UNAME_MACHINE_ARCH}-unknown-openbsd${UNAME_RELEASE} + exit ;; + *:ekkoBSD:*:*) + echo ${UNAME_MACHINE}-unknown-ekkobsd${UNAME_RELEASE} + exit ;; + *:SolidBSD:*:*) + echo ${UNAME_MACHINE}-unknown-solidbsd${UNAME_RELEASE} + exit ;; + macppc:MirBSD:*:*) + echo powerppc-unknown-mirbsd${UNAME_RELEASE} + exit ;; + *:MirBSD:*:*) + echo ${UNAME_MACHINE}-unknown-mirbsd${UNAME_RELEASE} + exit ;; + alpha:OSF1:*:*) + case $UNAME_RELEASE in + *4.0) + UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $3}'` + ;; + *5.*) + UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $4}'` + ;; + esac + # According to Compaq, /usr/sbin/psrinfo has been available on + # OSF/1 and Tru64 systems produced since 1995. I hope that + # covers most systems running today. This code pipes the CPU + # types through head -n 1, so we only detect the type of CPU 0. + ALPHA_CPU_TYPE=`/usr/sbin/psrinfo -v | sed -n -e 's/^ The alpha \(.*\) processor.*$/\1/p' | head -n 1` + case "$ALPHA_CPU_TYPE" in + "EV4 (21064)") + UNAME_MACHINE="alpha" ;; + "EV4.5 (21064)") + UNAME_MACHINE="alpha" ;; + "LCA4 (21066/21068)") + UNAME_MACHINE="alpha" ;; + "EV5 (21164)") + UNAME_MACHINE="alphaev5" ;; + "EV5.6 (21164A)") + UNAME_MACHINE="alphaev56" ;; + "EV5.6 (21164PC)") + UNAME_MACHINE="alphapca56" ;; + "EV5.7 (21164PC)") + UNAME_MACHINE="alphapca57" ;; + "EV6 (21264)") + UNAME_MACHINE="alphaev6" ;; + "EV6.7 (21264A)") + UNAME_MACHINE="alphaev67" ;; + "EV6.8CB (21264C)") + UNAME_MACHINE="alphaev68" ;; + "EV6.8AL (21264B)") + UNAME_MACHINE="alphaev68" ;; + "EV6.8CX (21264D)") + UNAME_MACHINE="alphaev68" ;; + "EV6.9A (21264/EV69A)") + UNAME_MACHINE="alphaev69" ;; + "EV7 (21364)") + UNAME_MACHINE="alphaev7" ;; + "EV7.9 (21364A)") + UNAME_MACHINE="alphaev79" ;; + esac + # A Pn.n version is a patched version. + # A Vn.n version is a released version. + # A Tn.n version is a released field test version. + # A Xn.n version is an unreleased experimental baselevel. + # 1.2 uses "1.2" for uname -r. + echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[PVTX]//' | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` + exit ;; + Alpha\ *:Windows_NT*:*) + # How do we know it's Interix rather than the generic POSIX subsystem? + # Should we change UNAME_MACHINE based on the output of uname instead + # of the specific Alpha model? + echo alpha-pc-interix + exit ;; + 21064:Windows_NT:50:3) + echo alpha-dec-winnt3.5 + exit ;; + Amiga*:UNIX_System_V:4.0:*) + echo m68k-unknown-sysv4 + exit ;; + *:[Aa]miga[Oo][Ss]:*:*) + echo ${UNAME_MACHINE}-unknown-amigaos + exit ;; + *:[Mm]orph[Oo][Ss]:*:*) + echo ${UNAME_MACHINE}-unknown-morphos + exit ;; + *:OS/390:*:*) + echo i370-ibm-openedition + exit ;; + *:z/VM:*:*) + echo s390-ibm-zvmoe + exit ;; + *:OS400:*:*) + echo powerpc-ibm-os400 + exit ;; + arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*) + echo arm-acorn-riscix${UNAME_RELEASE} + exit ;; + arm:riscos:*:*|arm:RISCOS:*:*) + echo arm-unknown-riscos + exit ;; + SR2?01:HI-UX/MPP:*:* | SR8000:HI-UX/MPP:*:*) + echo hppa1.1-hitachi-hiuxmpp + exit ;; + Pyramid*:OSx*:*:* | MIS*:OSx*:*:* | MIS*:SMP_DC-OSx*:*:*) + # akee@wpdis03.wpafb.af.mil (Earle F. Ake) contributed MIS and NILE. + if test "`(/bin/universe) 2>/dev/null`" = att ; then + echo pyramid-pyramid-sysv3 + else + echo pyramid-pyramid-bsd + fi + exit ;; + NILE*:*:*:dcosx) + echo pyramid-pyramid-svr4 + exit ;; + DRS?6000:unix:4.0:6*) + echo sparc-icl-nx6 + exit ;; + DRS?6000:UNIX_SV:4.2*:7* | DRS?6000:isis:4.2*:7*) + case `/usr/bin/uname -p` in + sparc) echo sparc-icl-nx7; exit ;; + esac ;; + sun4H:SunOS:5.*:*) + echo sparc-hal-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit ;; + sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*) + echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit ;; + i86pc:SunOS:5.*:*) + echo i386-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit ;; + sun4*:SunOS:6*:*) + # According to config.sub, this is the proper way to canonicalize + # SunOS6. Hard to guess exactly what SunOS6 will be like, but + # it's likely to be more like Solaris than SunOS4. + echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit ;; + sun4*:SunOS:*:*) + case "`/usr/bin/arch -k`" in + Series*|S4*) + UNAME_RELEASE=`uname -v` + ;; + esac + # Japanese Language versions have a version number like `4.1.3-JL'. + echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'` + exit ;; + sun3*:SunOS:*:*) + echo m68k-sun-sunos${UNAME_RELEASE} + exit ;; + sun*:*:4.2BSD:*) + UNAME_RELEASE=`(sed 1q /etc/motd | awk '{print substr($5,1,3)}') 2>/dev/null` + test "x${UNAME_RELEASE}" = "x" && UNAME_RELEASE=3 + case "`/bin/arch`" in + sun3) + echo m68k-sun-sunos${UNAME_RELEASE} + ;; + sun4) + echo sparc-sun-sunos${UNAME_RELEASE} + ;; + esac + exit ;; + aushp:SunOS:*:*) + echo sparc-auspex-sunos${UNAME_RELEASE} + exit ;; + # The situation for MiNT is a little confusing. The machine name + # can be virtually everything (everything which is not + # "atarist" or "atariste" at least should have a processor + # > m68000). The system name ranges from "MiNT" over "FreeMiNT" + # to the lowercase version "mint" (or "freemint"). Finally + # the system name "TOS" denotes a system which is actually not + # MiNT. But MiNT is downward compatible to TOS, so this should + # be no problem. + atarist[e]:*MiNT:*:* | atarist[e]:*mint:*:* | atarist[e]:*TOS:*:*) + echo m68k-atari-mint${UNAME_RELEASE} + exit ;; + atari*:*MiNT:*:* | atari*:*mint:*:* | atarist[e]:*TOS:*:*) + echo m68k-atari-mint${UNAME_RELEASE} + exit ;; + *falcon*:*MiNT:*:* | *falcon*:*mint:*:* | *falcon*:*TOS:*:*) + echo m68k-atari-mint${UNAME_RELEASE} + exit ;; + milan*:*MiNT:*:* | milan*:*mint:*:* | *milan*:*TOS:*:*) + echo m68k-milan-mint${UNAME_RELEASE} + exit ;; + hades*:*MiNT:*:* | hades*:*mint:*:* | *hades*:*TOS:*:*) + echo m68k-hades-mint${UNAME_RELEASE} + exit ;; + *:*MiNT:*:* | *:*mint:*:* | *:*TOS:*:*) + echo m68k-unknown-mint${UNAME_RELEASE} + exit ;; + m68k:machten:*:*) + echo m68k-apple-machten${UNAME_RELEASE} + exit ;; + powerpc:machten:*:*) + echo powerpc-apple-machten${UNAME_RELEASE} + exit ;; + RISC*:Mach:*:*) + echo mips-dec-mach_bsd4.3 + exit ;; + RISC*:ULTRIX:*:*) + echo mips-dec-ultrix${UNAME_RELEASE} + exit ;; + VAX*:ULTRIX*:*:*) + echo vax-dec-ultrix${UNAME_RELEASE} + exit ;; + 2020:CLIX:*:* | 2430:CLIX:*:*) + echo clipper-intergraph-clix${UNAME_RELEASE} + exit ;; + mips:*:*:UMIPS | mips:*:*:RISCos) + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c +#ifdef __cplusplus +#include /* for printf() prototype */ + int main (int argc, char *argv[]) { +#else + int main (argc, argv) int argc; char *argv[]; { +#endif + #if defined (host_mips) && defined (MIPSEB) + #if defined (SYSTYPE_SYSV) + printf ("mips-mips-riscos%ssysv\n", argv[1]); exit (0); + #endif + #if defined (SYSTYPE_SVR4) + printf ("mips-mips-riscos%ssvr4\n", argv[1]); exit (0); + #endif + #if defined (SYSTYPE_BSD43) || defined(SYSTYPE_BSD) + printf ("mips-mips-riscos%sbsd\n", argv[1]); exit (0); + #endif + #endif + exit (-1); + } +EOF + $CC_FOR_BUILD -o $dummy $dummy.c && + dummyarg=`echo "${UNAME_RELEASE}" | sed -n 's/\([0-9]*\).*/\1/p'` && + SYSTEM_NAME=`$dummy $dummyarg` && + { echo "$SYSTEM_NAME"; exit; } + echo mips-mips-riscos${UNAME_RELEASE} + exit ;; + Motorola:PowerMAX_OS:*:*) + echo powerpc-motorola-powermax + exit ;; + Motorola:*:4.3:PL8-*) + echo powerpc-harris-powermax + exit ;; + Night_Hawk:*:*:PowerMAX_OS | Synergy:PowerMAX_OS:*:*) + echo powerpc-harris-powermax + exit ;; + Night_Hawk:Power_UNIX:*:*) + echo powerpc-harris-powerunix + exit ;; + m88k:CX/UX:7*:*) + echo m88k-harris-cxux7 + exit ;; + m88k:*:4*:R4*) + echo m88k-motorola-sysv4 + exit ;; + m88k:*:3*:R3*) + echo m88k-motorola-sysv3 + exit ;; + AViiON:dgux:*:*) + # DG/UX returns AViiON for all architectures + UNAME_PROCESSOR=`/usr/bin/uname -p` + if [ $UNAME_PROCESSOR = mc88100 ] || [ $UNAME_PROCESSOR = mc88110 ] + then + if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx ] || \ + [ ${TARGET_BINARY_INTERFACE}x = x ] + then + echo m88k-dg-dgux${UNAME_RELEASE} + else + echo m88k-dg-dguxbcs${UNAME_RELEASE} + fi + else + echo i586-dg-dgux${UNAME_RELEASE} + fi + exit ;; + M88*:DolphinOS:*:*) # DolphinOS (SVR3) + echo m88k-dolphin-sysv3 + exit ;; + M88*:*:R3*:*) + # Delta 88k system running SVR3 + echo m88k-motorola-sysv3 + exit ;; + XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3) + echo m88k-tektronix-sysv3 + exit ;; + Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD) + echo m68k-tektronix-bsd + exit ;; + *:IRIX*:*:*) + echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'` + exit ;; + ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX. + echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id + exit ;; # Note that: echo "'`uname -s`'" gives 'AIX ' + i*86:AIX:*:*) + echo i386-ibm-aix + exit ;; + ia64:AIX:*:*) + if [ -x /usr/bin/oslevel ] ; then + IBM_REV=`/usr/bin/oslevel` + else + IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} + fi + echo ${UNAME_MACHINE}-ibm-aix${IBM_REV} + exit ;; + *:AIX:2:3) + if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #include + + main() + { + if (!__power_pc()) + exit(1); + puts("powerpc-ibm-aix3.2.5"); + exit(0); + } +EOF + if $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` + then + echo "$SYSTEM_NAME" + else + echo rs6000-ibm-aix3.2.5 + fi + elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then + echo rs6000-ibm-aix3.2.4 + else + echo rs6000-ibm-aix3.2 + fi + exit ;; + *:AIX:*:[45]) + IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | sed 1q | awk '{ print $1 }'` + if /usr/sbin/lsattr -El ${IBM_CPU_ID} | grep ' POWER' >/dev/null 2>&1; then + IBM_ARCH=rs6000 + else + IBM_ARCH=powerpc + fi + if [ -x /usr/bin/oslevel ] ; then + IBM_REV=`/usr/bin/oslevel` + else + IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} + fi + echo ${IBM_ARCH}-ibm-aix${IBM_REV} + exit ;; + *:AIX:*:*) + echo rs6000-ibm-aix + exit ;; + ibmrt:4.4BSD:*|romp-ibm:BSD:*) + echo romp-ibm-bsd4.4 + exit ;; + ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC BSD and + echo romp-ibm-bsd${UNAME_RELEASE} # 4.3 with uname added to + exit ;; # report: romp-ibm BSD 4.3 + *:BOSX:*:*) + echo rs6000-bull-bosx + exit ;; + DPX/2?00:B.O.S.:*:*) + echo m68k-bull-sysv3 + exit ;; + 9000/[34]??:4.3bsd:1.*:*) + echo m68k-hp-bsd + exit ;; + hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*) + echo m68k-hp-bsd4.4 + exit ;; + 9000/[34678]??:HP-UX:*:*) + HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` + case "${UNAME_MACHINE}" in + 9000/31? ) HP_ARCH=m68000 ;; + 9000/[34]?? ) HP_ARCH=m68k ;; + 9000/[678][0-9][0-9]) + if [ -x /usr/bin/getconf ]; then + sc_cpu_version=`/usr/bin/getconf SC_CPU_VERSION 2>/dev/null` + sc_kernel_bits=`/usr/bin/getconf SC_KERNEL_BITS 2>/dev/null` + case "${sc_cpu_version}" in + 523) HP_ARCH="hppa1.0" ;; # CPU_PA_RISC1_0 + 528) HP_ARCH="hppa1.1" ;; # CPU_PA_RISC1_1 + 532) # CPU_PA_RISC2_0 + case "${sc_kernel_bits}" in + 32) HP_ARCH="hppa2.0n" ;; + 64) HP_ARCH="hppa2.0w" ;; + '') HP_ARCH="hppa2.0" ;; # HP-UX 10.20 + esac ;; + esac + fi + if [ "${HP_ARCH}" = "" ]; then + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + + #define _HPUX_SOURCE + #include + #include + + int main () + { + #if defined(_SC_KERNEL_BITS) + long bits = sysconf(_SC_KERNEL_BITS); + #endif + long cpu = sysconf (_SC_CPU_VERSION); + + switch (cpu) + { + case CPU_PA_RISC1_0: puts ("hppa1.0"); break; + case CPU_PA_RISC1_1: puts ("hppa1.1"); break; + case CPU_PA_RISC2_0: + #if defined(_SC_KERNEL_BITS) + switch (bits) + { + case 64: puts ("hppa2.0w"); break; + case 32: puts ("hppa2.0n"); break; + default: puts ("hppa2.0"); break; + } break; + #else /* !defined(_SC_KERNEL_BITS) */ + puts ("hppa2.0"); break; + #endif + default: puts ("hppa1.0"); break; + } + exit (0); + } +EOF + (CCOPTS= $CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null) && HP_ARCH=`$dummy` + test -z "$HP_ARCH" && HP_ARCH=hppa + fi ;; + esac + if [ ${HP_ARCH} = "hppa2.0w" ] + then + eval $set_cc_for_build + + # hppa2.0w-hp-hpux* has a 64-bit kernel and a compiler generating + # 32-bit code. hppa64-hp-hpux* has the same kernel and a compiler + # generating 64-bit code. GNU and HP use different nomenclature: + # + # $ CC_FOR_BUILD=cc ./config.guess + # => hppa2.0w-hp-hpux11.23 + # $ CC_FOR_BUILD="cc +DA2.0w" ./config.guess + # => hppa64-hp-hpux11.23 + + if echo __LP64__ | (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | + grep __LP64__ >/dev/null + then + HP_ARCH="hppa2.0w" + else + HP_ARCH="hppa64" + fi + fi + echo ${HP_ARCH}-hp-hpux${HPUX_REV} + exit ;; + ia64:HP-UX:*:*) + HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` + echo ia64-hp-hpux${HPUX_REV} + exit ;; + 3050*:HI-UX:*:*) + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #include + int + main () + { + long cpu = sysconf (_SC_CPU_VERSION); + /* The order matters, because CPU_IS_HP_MC68K erroneously returns + true for CPU_PA_RISC1_0. CPU_IS_PA_RISC returns correct + results, however. */ + if (CPU_IS_PA_RISC (cpu)) + { + switch (cpu) + { + case CPU_PA_RISC1_0: puts ("hppa1.0-hitachi-hiuxwe2"); break; + case CPU_PA_RISC1_1: puts ("hppa1.1-hitachi-hiuxwe2"); break; + case CPU_PA_RISC2_0: puts ("hppa2.0-hitachi-hiuxwe2"); break; + default: puts ("hppa-hitachi-hiuxwe2"); break; + } + } + else if (CPU_IS_HP_MC68K (cpu)) + puts ("m68k-hitachi-hiuxwe2"); + else puts ("unknown-hitachi-hiuxwe2"); + exit (0); + } +EOF + $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` && + { echo "$SYSTEM_NAME"; exit; } + echo unknown-hitachi-hiuxwe2 + exit ;; + 9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:* ) + echo hppa1.1-hp-bsd + exit ;; + 9000/8??:4.3bsd:*:*) + echo hppa1.0-hp-bsd + exit ;; + *9??*:MPE/iX:*:* | *3000*:MPE/iX:*:*) + echo hppa1.0-hp-mpeix + exit ;; + hp7??:OSF1:*:* | hp8?[79]:OSF1:*:* ) + echo hppa1.1-hp-osf + exit ;; + hp8??:OSF1:*:*) + echo hppa1.0-hp-osf + exit ;; + i*86:OSF1:*:*) + if [ -x /usr/sbin/sysversion ] ; then + echo ${UNAME_MACHINE}-unknown-osf1mk + else + echo ${UNAME_MACHINE}-unknown-osf1 + fi + exit ;; + parisc*:Lites*:*:*) + echo hppa1.1-hp-lites + exit ;; + C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*) + echo c1-convex-bsd + exit ;; + C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*) + if getsysinfo -f scalar_acc + then echo c32-convex-bsd + else echo c2-convex-bsd + fi + exit ;; + C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*) + echo c34-convex-bsd + exit ;; + C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*) + echo c38-convex-bsd + exit ;; + C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*) + echo c4-convex-bsd + exit ;; + CRAY*Y-MP:*:*:*) + echo ymp-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit ;; + CRAY*[A-Z]90:*:*:*) + echo ${UNAME_MACHINE}-cray-unicos${UNAME_RELEASE} \ + | sed -e 's/CRAY.*\([A-Z]90\)/\1/' \ + -e y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ \ + -e 's/\.[^.]*$/.X/' + exit ;; + CRAY*TS:*:*:*) + echo t90-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit ;; + CRAY*T3E:*:*:*) + echo alphaev5-cray-unicosmk${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit ;; + CRAY*SV1:*:*:*) + echo sv1-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit ;; + *:UNICOS/mp:*:*) + echo craynv-cray-unicosmp${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit ;; + F30[01]:UNIX_System_V:*:* | F700:UNIX_System_V:*:*) + FUJITSU_PROC=`uname -m | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` + FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` + FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'` + echo "${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" + exit ;; + 5000:UNIX_System_V:4.*:*) + FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` + FUJITSU_REL=`echo ${UNAME_RELEASE} | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/ /_/'` + echo "sparc-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" + exit ;; + i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*) + echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE} + exit ;; + sparc*:BSD/OS:*:*) + echo sparc-unknown-bsdi${UNAME_RELEASE} + exit ;; + *:BSD/OS:*:*) + echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE} + exit ;; + *:FreeBSD:*:*) + case ${UNAME_MACHINE} in + pc98) + echo i386-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; + *) + echo ${UNAME_MACHINE}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; + esac + exit ;; + i*:CYGWIN*:*) + echo ${UNAME_MACHINE}-pc-cygwin + exit ;; + i*:MINGW*:*) + echo ${UNAME_MACHINE}-pc-mingw32 + exit ;; + i*:MSYS_NT-*:*:*) + echo ${UNAME_MACHINE}-pc-mingw32 + exit ;; + i*:windows32*:*) + # uname -m includes "-pc" on this system. + echo ${UNAME_MACHINE}-mingw32 + exit ;; + i*:PW*:*) + echo ${UNAME_MACHINE}-pc-pw32 + exit ;; + x86:Interix*:[345]*) + echo i586-pc-interix${UNAME_RELEASE} + exit ;; + EM64T:Interix*:[345]*) + echo x86_64-unknown-interix${UNAME_RELEASE} + exit ;; + [345]86:Windows_95:* | [345]86:Windows_98:* | [345]86:Windows_NT:*) + echo i${UNAME_MACHINE}-pc-mks + exit ;; + i*:Windows_NT*:* | Pentium*:Windows_NT*:*) + # How do we know it's Interix rather than the generic POSIX subsystem? + # It also conflicts with pre-2.0 versions of AT&T UWIN. Should we + # UNAME_MACHINE based on the output of uname instead of i386? + echo i586-pc-interix + exit ;; + i*:UWIN*:*) + echo ${UNAME_MACHINE}-pc-uwin + exit ;; + amd64:CYGWIN*:*:* | x86_64:CYGWIN*:*:*) + echo x86_64-unknown-cygwin + exit ;; + p*:CYGWIN*:*) + echo powerpcle-unknown-cygwin + exit ;; + prep*:SunOS:5.*:*) + echo powerpcle-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit ;; + *:GNU:*:*) + # the GNU system + echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-unknown-gnu`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'` + exit ;; + *:GNU/*:*:*) + # other systems with GNU libc and userland + echo ${UNAME_MACHINE}-unknown-`echo ${UNAME_SYSTEM} | sed 's,^[^/]*/,,' | tr '[A-Z]' '[a-z]'``echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`-gnu + exit ;; + i*86:Minix:*:*) + echo ${UNAME_MACHINE}-pc-minix + exit ;; + arm*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit ;; + cris:Linux:*:*) + echo cris-axis-linux-gnu + exit ;; + crisv32:Linux:*:*) + echo crisv32-axis-linux-gnu + exit ;; + frv:Linux:*:*) + echo frv-unknown-linux-gnu + exit ;; + ia64:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit ;; + m32r*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit ;; + m68*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit ;; + mips:Linux:*:*) + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #undef CPU + #undef mips + #undef mipsel + #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL) + CPU=mipsel + #else + #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB) + CPU=mips + #else + CPU= + #endif + #endif +EOF + eval "`$CC_FOR_BUILD -E $dummy.c 2>/dev/null | sed -n ' + /^CPU/{ + s: ::g + p + }'`" + test x"${CPU}" != x && { echo "${CPU}-unknown-linux-gnu"; exit; } + ;; + mips64:Linux:*:*) + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #undef CPU + #undef mips64 + #undef mips64el + #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL) + CPU=mips64el + #else + #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB) + CPU=mips64 + #else + CPU= + #endif + #endif +EOF + eval "`$CC_FOR_BUILD -E $dummy.c 2>/dev/null | sed -n ' + /^CPU/{ + s: ::g + p + }'`" + test x"${CPU}" != x && { echo "${CPU}-unknown-linux-gnu"; exit; } + ;; + or32:Linux:*:*) + echo or32-unknown-linux-gnu + exit ;; + ppc:Linux:*:*) + echo powerpc-unknown-linux-gnu + exit ;; + ppc64:Linux:*:*) + echo powerpc64-unknown-linux-gnu + exit ;; + alpha:Linux:*:*) + case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` in + EV5) UNAME_MACHINE=alphaev5 ;; + EV56) UNAME_MACHINE=alphaev56 ;; + PCA56) UNAME_MACHINE=alphapca56 ;; + PCA57) UNAME_MACHINE=alphapca56 ;; + EV6) UNAME_MACHINE=alphaev6 ;; + EV67) UNAME_MACHINE=alphaev67 ;; + EV68*) UNAME_MACHINE=alphaev68 ;; + esac + objdump --private-headers /bin/sh | grep ld.so.1 >/dev/null + if test "$?" = 0 ; then LIBC="libc1" ; else LIBC="" ; fi + echo ${UNAME_MACHINE}-unknown-linux-gnu${LIBC} + exit ;; + parisc:Linux:*:* | hppa:Linux:*:*) + # Look for CPU level + case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in + PA7*) echo hppa1.1-unknown-linux-gnu ;; + PA8*) echo hppa2.0-unknown-linux-gnu ;; + *) echo hppa-unknown-linux-gnu ;; + esac + exit ;; + parisc64:Linux:*:* | hppa64:Linux:*:*) + echo hppa64-unknown-linux-gnu + exit ;; + s390:Linux:*:* | s390x:Linux:*:*) + echo ${UNAME_MACHINE}-ibm-linux + exit ;; + sh64*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit ;; + sh*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit ;; + sparc:Linux:*:* | sparc64:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit ;; + vax:Linux:*:*) + echo ${UNAME_MACHINE}-dec-linux-gnu + exit ;; + x86_64:Linux:*:*) + echo x86_64-unknown-linux-gnu + exit ;; + i*86:Linux:*:*) + # The BFD linker knows what the default object file format is, so + # first see if it will tell us. cd to the root directory to prevent + # problems with other programs or directories called `ld' in the path. + # Set LC_ALL=C to ensure ld outputs messages in English. + ld_supported_targets=`cd /; LC_ALL=C ld --help 2>&1 \ + | sed -ne '/supported targets:/!d + s/[ ][ ]*/ /g + s/.*supported targets: *// + s/ .*// + p'` + case "$ld_supported_targets" in + elf32-i386) + TENTATIVE="${UNAME_MACHINE}-pc-linux-gnu" + ;; + a.out-i386-linux) + echo "${UNAME_MACHINE}-pc-linux-gnuaout" + exit ;; + coff-i386) + echo "${UNAME_MACHINE}-pc-linux-gnucoff" + exit ;; + "") + # Either a pre-BFD a.out linker (linux-gnuoldld) or + # one that does not give us useful --help. + echo "${UNAME_MACHINE}-pc-linux-gnuoldld" + exit ;; + esac + # Determine whether the default compiler is a.out or elf + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #include + #ifdef __ELF__ + # ifdef __GLIBC__ + # if __GLIBC__ >= 2 + LIBC=gnu + # else + LIBC=gnulibc1 + # endif + # else + LIBC=gnulibc1 + # endif + #else + #if defined(__INTEL_COMPILER) || defined(__PGI) || defined(__sun) + LIBC=gnu + #else + LIBC=gnuaout + #endif + #endif + #ifdef __dietlibc__ + LIBC=dietlibc + #endif +EOF + eval "`$CC_FOR_BUILD -E $dummy.c 2>/dev/null | sed -n ' + /^LIBC/{ + s: ::g + p + }'`" + test x"${LIBC}" != x && { + echo "${UNAME_MACHINE}-pc-linux-${LIBC}" + exit + } + test x"${TENTATIVE}" != x && { echo "${TENTATIVE}"; exit; } + ;; + i*86:DYNIX/ptx:4*:*) + # ptx 4.0 does uname -s correctly, with DYNIX/ptx in there. + # earlier versions are messed up and put the nodename in both + # sysname and nodename. + echo i386-sequent-sysv4 + exit ;; + i*86:UNIX_SV:4.2MP:2.*) + # Unixware is an offshoot of SVR4, but it has its own version + # number series starting with 2... + # I am not positive that other SVR4 systems won't match this, + # I just have to hope. -- rms. + # Use sysv4.2uw... so that sysv4* matches it. + echo ${UNAME_MACHINE}-pc-sysv4.2uw${UNAME_VERSION} + exit ;; + i*86:OS/2:*:*) + # If we were able to find `uname', then EMX Unix compatibility + # is probably installed. + echo ${UNAME_MACHINE}-pc-os2-emx + exit ;; + i*86:XTS-300:*:STOP) + echo ${UNAME_MACHINE}-unknown-stop + exit ;; + i*86:atheos:*:*) + echo ${UNAME_MACHINE}-unknown-atheos + exit ;; + i*86:syllable:*:*) + echo ${UNAME_MACHINE}-pc-syllable + exit ;; + i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.0*:*) + echo i386-unknown-lynxos${UNAME_RELEASE} + exit ;; + i*86:*DOS:*:*) + echo ${UNAME_MACHINE}-pc-msdosdjgpp + exit ;; + i*86:*:4.*:* | i*86:SYSTEM_V:4.*:*) + UNAME_REL=`echo ${UNAME_RELEASE} | sed 's/\/MP$//'` + if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then + echo ${UNAME_MACHINE}-univel-sysv${UNAME_REL} + else + echo ${UNAME_MACHINE}-pc-sysv${UNAME_REL} + fi + exit ;; + i*86:*:5:[678]*) + # UnixWare 7.x, OpenUNIX and OpenServer 6. + case `/bin/uname -X | grep "^Machine"` in + *486*) UNAME_MACHINE=i486 ;; + *Pentium) UNAME_MACHINE=i586 ;; + *Pent*|*Celeron) UNAME_MACHINE=i686 ;; + esac + echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION} + exit ;; + i*86:*:3.2:*) + if test -f /usr/options/cb.name; then + UNAME_REL=`sed -n 's/.*Version //p' /dev/null >/dev/null ; then + UNAME_REL=`(/bin/uname -X|grep Release|sed -e 's/.*= //')` + (/bin/uname -X|grep i80486 >/dev/null) && UNAME_MACHINE=i486 + (/bin/uname -X|grep '^Machine.*Pentium' >/dev/null) \ + && UNAME_MACHINE=i586 + (/bin/uname -X|grep '^Machine.*Pent *II' >/dev/null) \ + && UNAME_MACHINE=i686 + (/bin/uname -X|grep '^Machine.*Pentium Pro' >/dev/null) \ + && UNAME_MACHINE=i686 + echo ${UNAME_MACHINE}-pc-sco$UNAME_REL + else + echo ${UNAME_MACHINE}-pc-sysv32 + fi + exit ;; + pc:*:*:*) + # Left here for compatibility: + # uname -m prints for DJGPP always 'pc', but it prints nothing about + # the processor, so we play safe by assuming i386. + echo i386-pc-msdosdjgpp + exit ;; + Intel:Mach:3*:*) + echo i386-pc-mach3 + exit ;; + paragon:*:*:*) + echo i860-intel-osf1 + exit ;; + i860:*:4.*:*) # i860-SVR4 + if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then + echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4 + else # Add other i860-SVR4 vendors below as they are discovered. + echo i860-unknown-sysv${UNAME_RELEASE} # Unknown i860-SVR4 + fi + exit ;; + mini*:CTIX:SYS*5:*) + # "miniframe" + echo m68010-convergent-sysv + exit ;; + mc68k:UNIX:SYSTEM5:3.51m) + echo m68k-convergent-sysv + exit ;; + M680?0:D-NIX:5.3:*) + echo m68k-diab-dnix + exit ;; + M68*:*:R3V[5678]*:*) + test -r /sysV68 && { echo 'm68k-motorola-sysv'; exit; } ;; + 3[345]??:*:4.0:3.0 | 3[34]??A:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0 | 3[34]??/*:*:4.0:3.0 | 4400:*:4.0:3.0 | 4850:*:4.0:3.0 | SKA40:*:4.0:3.0 | SDS2:*:4.0:3.0 | SHG2:*:4.0:3.0 | S7501*:*:4.0:3.0) + OS_REL='' + test -r /etc/.relid \ + && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` + /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ + && { echo i486-ncr-sysv4.3${OS_REL}; exit; } + /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ + && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;; + 3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*) + /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ + && { echo i486-ncr-sysv4; exit; } ;; + m68*:LynxOS:2.*:* | m68*:LynxOS:3.0*:*) + echo m68k-unknown-lynxos${UNAME_RELEASE} + exit ;; + mc68030:UNIX_System_V:4.*:*) + echo m68k-atari-sysv4 + exit ;; + TSUNAMI:LynxOS:2.*:*) + echo sparc-unknown-lynxos${UNAME_RELEASE} + exit ;; + rs6000:LynxOS:2.*:*) + echo rs6000-unknown-lynxos${UNAME_RELEASE} + exit ;; + PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.0*:*) + echo powerpc-unknown-lynxos${UNAME_RELEASE} + exit ;; + SM[BE]S:UNIX_SV:*:*) + echo mips-dde-sysv${UNAME_RELEASE} + exit ;; + RM*:ReliantUNIX-*:*:*) + echo mips-sni-sysv4 + exit ;; + RM*:SINIX-*:*:*) + echo mips-sni-sysv4 + exit ;; + *:SINIX-*:*:*) + if uname -p 2>/dev/null >/dev/null ; then + UNAME_MACHINE=`(uname -p) 2>/dev/null` + echo ${UNAME_MACHINE}-sni-sysv4 + else + echo ns32k-sni-sysv + fi + exit ;; + PENTIUM:*:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort + # says + echo i586-unisys-sysv4 + exit ;; + *:UNIX_System_V:4*:FTX*) + # From Gerald Hewes . + # How about differentiating between stratus architectures? -djm + echo hppa1.1-stratus-sysv4 + exit ;; + *:*:*:FTX*) + # From seanf@swdc.stratus.com. + echo i860-stratus-sysv4 + exit ;; + i*86:VOS:*:*) + # From Paul.Green@stratus.com. + echo ${UNAME_MACHINE}-stratus-vos + exit ;; + *:VOS:*:*) + # From Paul.Green@stratus.com. + echo hppa1.1-stratus-vos + exit ;; + mc68*:A/UX:*:*) + echo m68k-apple-aux${UNAME_RELEASE} + exit ;; + news*:NEWS-OS:6*:*) + echo mips-sony-newsos6 + exit ;; + R[34]000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R*000:UNIX_SV:*:*) + if [ -d /usr/nec ]; then + echo mips-nec-sysv${UNAME_RELEASE} + else + echo mips-unknown-sysv${UNAME_RELEASE} + fi + exit ;; + BeBox:BeOS:*:*) # BeOS running on hardware made by Be, PPC only. + echo powerpc-be-beos + exit ;; + BeMac:BeOS:*:*) # BeOS running on Mac or Mac clone, PPC only. + echo powerpc-apple-beos + exit ;; + BePC:BeOS:*:*) # BeOS running on Intel PC compatible. + echo i586-pc-beos + exit ;; + SX-4:SUPER-UX:*:*) + echo sx4-nec-superux${UNAME_RELEASE} + exit ;; + SX-5:SUPER-UX:*:*) + echo sx5-nec-superux${UNAME_RELEASE} + exit ;; + SX-6:SUPER-UX:*:*) + echo sx6-nec-superux${UNAME_RELEASE} + exit ;; + Power*:Rhapsody:*:*) + echo powerpc-apple-rhapsody${UNAME_RELEASE} + exit ;; + *:Rhapsody:*:*) + echo ${UNAME_MACHINE}-apple-rhapsody${UNAME_RELEASE} + exit ;; + *:Darwin:*:*) + UNAME_PROCESSOR=`uname -p` || UNAME_PROCESSOR=unknown + case $UNAME_PROCESSOR in + unknown) UNAME_PROCESSOR=powerpc ;; + esac + echo ${UNAME_PROCESSOR}-apple-darwin${UNAME_RELEASE} + exit ;; + *:procnto*:*:* | *:QNX:[0123456789]*:*) + UNAME_PROCESSOR=`uname -p` + if test "$UNAME_PROCESSOR" = "x86"; then + UNAME_PROCESSOR=i386 + UNAME_MACHINE=pc + fi + echo ${UNAME_PROCESSOR}-${UNAME_MACHINE}-nto-qnx${UNAME_RELEASE} + exit ;; + *:QNX:*:4*) + echo i386-pc-qnx + exit ;; + NSE-?:NONSTOP_KERNEL:*:*) + echo nse-tandem-nsk${UNAME_RELEASE} + exit ;; + NSR-?:NONSTOP_KERNEL:*:*) + echo nsr-tandem-nsk${UNAME_RELEASE} + exit ;; + *:NonStop-UX:*:*) + echo mips-compaq-nonstopux + exit ;; + BS2000:POSIX*:*:*) + echo bs2000-siemens-sysv + exit ;; + DS/*:UNIX_System_V:*:*) + echo ${UNAME_MACHINE}-${UNAME_SYSTEM}-${UNAME_RELEASE} + exit ;; + *:Plan9:*:*) + # "uname -m" is not consistent, so use $cputype instead. 386 + # is converted to i386 for consistency with other x86 + # operating systems. + if test "$cputype" = "386"; then + UNAME_MACHINE=i386 + else + UNAME_MACHINE="$cputype" + fi + echo ${UNAME_MACHINE}-unknown-plan9 + exit ;; + *:TOPS-10:*:*) + echo pdp10-unknown-tops10 + exit ;; + *:TENEX:*:*) + echo pdp10-unknown-tenex + exit ;; + KS10:TOPS-20:*:* | KL10:TOPS-20:*:* | TYPE4:TOPS-20:*:*) + echo pdp10-dec-tops20 + exit ;; + XKL-1:TOPS-20:*:* | TYPE5:TOPS-20:*:*) + echo pdp10-xkl-tops20 + exit ;; + *:TOPS-20:*:*) + echo pdp10-unknown-tops20 + exit ;; + *:ITS:*:*) + echo pdp10-unknown-its + exit ;; + SEI:*:*:SEIUX) + echo mips-sei-seiux${UNAME_RELEASE} + exit ;; + *:DragonFly:*:*) + echo ${UNAME_MACHINE}-unknown-dragonfly`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` + exit ;; + *:*VMS:*:*) + UNAME_MACHINE=`(uname -p) 2>/dev/null` + case "${UNAME_MACHINE}" in + A*) echo alpha-dec-vms ; exit ;; + I*) echo ia64-dec-vms ; exit ;; + V*) echo vax-dec-vms ; exit ;; + esac ;; + *:XENIX:*:SysV) + echo i386-pc-xenix + exit ;; + i*86:skyos:*:*) + echo ${UNAME_MACHINE}-pc-skyos`echo ${UNAME_RELEASE}` | sed -e 's/ .*$//' + exit ;; + i*86:rdos:*:*) + echo ${UNAME_MACHINE}-pc-rdos + exit ;; +esac + +#echo '(No uname command or uname output not recognized.)' 1>&2 +#echo "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" 1>&2 + +eval $set_cc_for_build +cat >$dummy.c < +# include +#endif +main () +{ +#if defined (sony) +#if defined (MIPSEB) + /* BFD wants "bsd" instead of "newsos". Perhaps BFD should be changed, + I don't know.... */ + printf ("mips-sony-bsd\n"); exit (0); +#else +#include + printf ("m68k-sony-newsos%s\n", +#ifdef NEWSOS4 + "4" +#else + "" +#endif + ); exit (0); +#endif +#endif + +#if defined (__arm) && defined (__acorn) && defined (__unix) + printf ("arm-acorn-riscix\n"); exit (0); +#endif + +#if defined (hp300) && !defined (hpux) + printf ("m68k-hp-bsd\n"); exit (0); +#endif + +#if defined (NeXT) +#if !defined (__ARCHITECTURE__) +#define __ARCHITECTURE__ "m68k" +#endif + int version; + version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`; + if (version < 4) + printf ("%s-next-nextstep%d\n", __ARCHITECTURE__, version); + else + printf ("%s-next-openstep%d\n", __ARCHITECTURE__, version); + exit (0); +#endif + +#if defined (MULTIMAX) || defined (n16) +#if defined (UMAXV) + printf ("ns32k-encore-sysv\n"); exit (0); +#else +#if defined (CMU) + printf ("ns32k-encore-mach\n"); exit (0); +#else + printf ("ns32k-encore-bsd\n"); exit (0); +#endif +#endif +#endif + +#if defined (__386BSD__) + printf ("i386-pc-bsd\n"); exit (0); +#endif + +#if defined (sequent) +#if defined (i386) + printf ("i386-sequent-dynix\n"); exit (0); +#endif +#if defined (ns32000) + printf ("ns32k-sequent-dynix\n"); exit (0); +#endif +#endif + +#if defined (_SEQUENT_) + struct utsname un; + + uname(&un); + + if (strncmp(un.version, "V2", 2) == 0) { + printf ("i386-sequent-ptx2\n"); exit (0); + } + if (strncmp(un.version, "V1", 2) == 0) { /* XXX is V1 correct? */ + printf ("i386-sequent-ptx1\n"); exit (0); + } + printf ("i386-sequent-ptx\n"); exit (0); + +#endif + +#if defined (vax) +# if !defined (ultrix) +# include +# if defined (BSD) +# if BSD == 43 + printf ("vax-dec-bsd4.3\n"); exit (0); +# else +# if BSD == 199006 + printf ("vax-dec-bsd4.3reno\n"); exit (0); +# else + printf ("vax-dec-bsd\n"); exit (0); +# endif +# endif +# else + printf ("vax-dec-bsd\n"); exit (0); +# endif +# else + printf ("vax-dec-ultrix\n"); exit (0); +# endif +#endif + +#if defined (alliant) && defined (i860) + printf ("i860-alliant-bsd\n"); exit (0); +#endif + + exit (1); +} +EOF + +$CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null && SYSTEM_NAME=`$dummy` && + { echo "$SYSTEM_NAME"; exit; } + +# Apollos put the system type in the environment. + +test -d /usr/apollo && { echo ${ISP}-apollo-${SYSTYPE}; exit; } + +# Convex versions that predate uname can use getsysinfo(1) + +if [ -x /usr/convex/getsysinfo ] +then + case `getsysinfo -f cpu_type` in + c1*) + echo c1-convex-bsd + exit ;; + c2*) + if getsysinfo -f scalar_acc + then echo c32-convex-bsd + else echo c2-convex-bsd + fi + exit ;; + c34*) + echo c34-convex-bsd + exit ;; + c38*) + echo c38-convex-bsd + exit ;; + c4*) + echo c4-convex-bsd + exit ;; + esac +fi + +cat >&2 < in order to provide the needed +information to handle your system. + +config.guess timestamp = $timestamp + +uname -m = `(uname -m) 2>/dev/null || echo unknown` +uname -r = `(uname -r) 2>/dev/null || echo unknown` +uname -s = `(uname -s) 2>/dev/null || echo unknown` +uname -v = `(uname -v) 2>/dev/null || echo unknown` + +/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null` +/bin/uname -X = `(/bin/uname -X) 2>/dev/null` + +hostinfo = `(hostinfo) 2>/dev/null` +/bin/universe = `(/bin/universe) 2>/dev/null` +/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null` +/bin/arch = `(/bin/arch) 2>/dev/null` +/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null` +/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null` + +UNAME_MACHINE = ${UNAME_MACHINE} +UNAME_RELEASE = ${UNAME_RELEASE} +UNAME_SYSTEM = ${UNAME_SYSTEM} +UNAME_VERSION = ${UNAME_VERSION} +EOF + +exit 1 + +# Local variables: +# eval: (add-hook 'write-file-hooks 'time-stamp) +# time-stamp-start: "timestamp='" +# time-stamp-format: "%:y-%02m-%02d" +# time-stamp-end: "'" +# End: diff --git a/config.sub b/config.sub new file mode 100644 --- /dev/null +++ b/config.sub @@ -0,0 +1,1608 @@ +#! /bin/sh +# Configuration validation subroutine script. +# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, +# 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation, Inc. + +timestamp='2006-02-23' + +# This file is (in principle) common to ALL GNU software. +# The presence of a machine in this file suggests that SOME GNU software +# can handle that machine. It does not imply ALL GNU software can. +# +# This file is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 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 General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, MA +# 02110-1301, USA. +# +# As a special exception to the GNU General Public License, if you +# distribute this file as part of a program that contains a +# configuration script generated by Autoconf, you may include it under +# the same distribution terms that you use for the rest of that program. + + +# Please send patches to . Submit a context +# diff and a properly formatted ChangeLog entry. +# +# Configuration subroutine to validate and canonicalize a configuration type. +# Supply the specified configuration type as an argument. +# If it is invalid, we print an error message on stderr and exit with code 1. +# Otherwise, we print the canonical config type on stdout and succeed. + +# This file is supposed to be the same for all GNU packages +# and recognize all the CPU types, system types and aliases +# that are meaningful with *any* GNU software. +# Each package is responsible for reporting which valid configurations +# it does not support. The user should be able to distinguish +# a failure to support a valid configuration from a meaningless +# configuration. + +# The goal of this file is to map all the various variations of a given +# machine specification into a single specification in the form: +# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM +# or in some cases, the newer four-part form: +# CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM +# It is wrong to echo any other type of specification. + +me=`echo "$0" | sed -e 's,.*/,,'` + +usage="\ +Usage: $0 [OPTION] CPU-MFR-OPSYS + $0 [OPTION] ALIAS + +Canonicalize a configuration name. + +Operation modes: + -h, --help print this help, then exit + -t, --time-stamp print date of last modification, then exit + -v, --version print version number, then exit + +Report bugs and patches to ." + +version="\ +GNU config.sub ($timestamp) + +Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005 +Free Software Foundation, Inc. + +This is free software; see the source for copying conditions. There is NO +warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." + +help=" +Try \`$me --help' for more information." + +# Parse command line +while test $# -gt 0 ; do + case $1 in + --time-stamp | --time* | -t ) + echo "$timestamp" ; exit ;; + --version | -v ) + echo "$version" ; exit ;; + --help | --h* | -h ) + echo "$usage"; exit ;; + -- ) # Stop option processing + shift; break ;; + - ) # Use stdin as input. + break ;; + -* ) + echo "$me: invalid option $1$help" + exit 1 ;; + + *local*) + # First pass through any local machine types. + echo $1 + exit ;; + + * ) + break ;; + esac +done + +case $# in + 0) echo "$me: missing argument$help" >&2 + exit 1;; + 1) ;; + *) echo "$me: too many arguments$help" >&2 + exit 1;; +esac + +# Separate what the user gave into CPU-COMPANY and OS or KERNEL-OS (if any). +# Here we must recognize all the valid KERNEL-OS combinations. +maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'` +case $maybe_os in + nto-qnx* | linux-gnu* | linux-dietlibc | linux-newlib* | linux-uclibc* | \ + uclinux-uclibc* | uclinux-gnu* | kfreebsd*-gnu* | knetbsd*-gnu* | netbsd*-gnu* | \ + storm-chaos* | os2-emx* | rtmk-nova*) + os=-$maybe_os + basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'` + ;; + *) + basic_machine=`echo $1 | sed 's/-[^-]*$//'` + if [ $basic_machine != $1 ] + then os=`echo $1 | sed 's/.*-/-/'` + else os=; fi + ;; +esac + +### Let's recognize common machines as not being operating systems so +### that things like config.sub decstation-3100 work. We also +### recognize some manufacturers as not being operating systems, so we +### can provide default operating systems below. +case $os in + -sun*os*) + # Prevent following clause from handling this invalid input. + ;; + -dec* | -mips* | -sequent* | -encore* | -pc532* | -sgi* | -sony* | \ + -att* | -7300* | -3300* | -delta* | -motorola* | -sun[234]* | \ + -unicom* | -ibm* | -next | -hp | -isi* | -apollo | -altos* | \ + -convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\ + -c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \ + -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp | \ + -apple | -axis | -knuth | -cray) + os= + basic_machine=$1 + ;; + -sim | -cisco | -oki | -wec | -winbond) + os= + basic_machine=$1 + ;; + -scout) + ;; + -wrs) + os=-vxworks + basic_machine=$1 + ;; + -chorusos*) + os=-chorusos + basic_machine=$1 + ;; + -chorusrdb) + os=-chorusrdb + basic_machine=$1 + ;; + -hiux*) + os=-hiuxwe2 + ;; + -sco6) + os=-sco5v6 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco5) + os=-sco3.2v5 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco4) + os=-sco3.2v4 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco3.2.[4-9]*) + os=`echo $os | sed -e 's/sco3.2./sco3.2v/'` + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco3.2v[4-9]*) + # Don't forget version if it is 3.2v4 or newer. + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco5v6*) + # Don't forget version if it is 3.2v4 or newer. + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco*) + os=-sco3.2v2 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -udk*) + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -isc) + os=-isc2.2 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -clix*) + basic_machine=clipper-intergraph + ;; + -isc*) + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -lynx*) + os=-lynxos + ;; + -ptx*) + basic_machine=`echo $1 | sed -e 's/86-.*/86-sequent/'` + ;; + -windowsnt*) + os=`echo $os | sed -e 's/windowsnt/winnt/'` + ;; + -psos*) + os=-psos + ;; + -mint | -mint[0-9]*) + basic_machine=m68k-atari + os=-mint + ;; +esac + +# Decode aliases for certain CPU-COMPANY combinations. +case $basic_machine in + # Recognize the basic CPU types without company name. + # Some are omitted here because they have special meanings below. + 1750a | 580 \ + | a29k \ + | alpha | alphaev[4-8] | alphaev56 | alphaev6[78] | alphapca5[67] \ + | alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] | alpha64pca5[67] \ + | am33_2.0 \ + | arc | arm | arm[bl]e | arme[lb] | armv[2345] | armv[345][lb] | avr \ + | bfin \ + | c4x | clipper \ + | d10v | d30v | dlx | dsp16xx \ + | fr30 | frv \ + | h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \ + | i370 | i860 | i960 | ia64 \ + | ip2k | iq2000 \ + | m32r | m32rle | m68000 | m68k | m88k | maxq | mb | microblaze | mcore \ + | mips | mipsbe | mipseb | mipsel | mipsle \ + | mips16 \ + | mips64 | mips64el \ + | mips64vr | mips64vrel \ + | mips64orion | mips64orionel \ + | mips64vr4100 | mips64vr4100el \ + | mips64vr4300 | mips64vr4300el \ + | mips64vr5000 | mips64vr5000el \ + | mips64vr5900 | mips64vr5900el \ + | mipsisa32 | mipsisa32el \ + | mipsisa32r2 | mipsisa32r2el \ + | mipsisa64 | mipsisa64el \ + | mipsisa64r2 | mipsisa64r2el \ + | mipsisa64sb1 | mipsisa64sb1el \ + | mipsisa64sr71k | mipsisa64sr71kel \ + | mipstx39 | mipstx39el \ + | mn10200 | mn10300 \ + | mt \ + | msp430 \ + | nios | nios2 \ + | ns16k | ns32k \ + | or32 \ + | pdp10 | pdp11 | pj | pjl \ + | powerpc | powerpc64 | powerpc64le | powerpcle | ppcbe \ + | pyramid \ + | sh | sh[1234] | sh[24]a | sh[23]e | sh[34]eb | shbe | shle | sh[1234]le | sh3ele \ + | sh64 | sh64le \ + | sparc | sparc64 | sparc64b | sparc86x | sparclet | sparclite \ + | sparcv8 | sparcv9 | sparcv9b \ + | strongarm \ + | tahoe | thumb | tic4x | tic80 | tron \ + | v850 | v850e \ + | we32k \ + | x86 | xscale | xscalee[bl] | xstormy16 | xtensa \ + | z8k) + basic_machine=$basic_machine-unknown + ;; + m32c) + basic_machine=$basic_machine-unknown + ;; + m6811 | m68hc11 | m6812 | m68hc12) + # Motorola 68HC11/12. + basic_machine=$basic_machine-unknown + os=-none + ;; + m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | v70 | w65 | z8k) + ;; + ms1) + basic_machine=mt-unknown + ;; + + # We use `pc' rather than `unknown' + # because (1) that's what they normally are, and + # (2) the word "unknown" tends to confuse beginning users. + i*86 | x86_64) + basic_machine=$basic_machine-pc + ;; + # Object if more than one company name word. + *-*-*) + echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 + exit 1 + ;; + # Recognize the basic CPU types with company name. + 580-* \ + | a29k-* \ + | alpha-* | alphaev[4-8]-* | alphaev56-* | alphaev6[78]-* \ + | alpha64-* | alpha64ev[4-8]-* | alpha64ev56-* | alpha64ev6[78]-* \ + | alphapca5[67]-* | alpha64pca5[67]-* | arc-* \ + | arm-* | armbe-* | armle-* | armeb-* | armv*-* \ + | avr-* \ + | bfin-* | bs2000-* \ + | c[123]* | c30-* | [cjt]90-* | c4x-* | c54x-* | c55x-* | c6x-* \ + | clipper-* | craynv-* | cydra-* \ + | d10v-* | d30v-* | dlx-* \ + | elxsi-* \ + | f30[01]-* | f700-* | fr30-* | frv-* | fx80-* \ + | h8300-* | h8500-* \ + | hppa-* | hppa1.[01]-* | hppa2.0-* | hppa2.0[nw]-* | hppa64-* \ + | i*86-* | i860-* | i960-* | ia64-* \ + | ip2k-* | iq2000-* \ + | m32r-* | m32rle-* \ + | m68000-* | m680[012346]0-* | m68360-* | m683?2-* | m68k-* \ + | m88110-* | m88k-* | maxq-* | mcore-* \ + | mips-* | mipsbe-* | mipseb-* | mipsel-* | mipsle-* \ + | mips16-* \ + | mips64-* | mips64el-* \ + | mips64vr-* | mips64vrel-* \ + | mips64orion-* | mips64orionel-* \ + | mips64vr4100-* | mips64vr4100el-* \ + | mips64vr4300-* | mips64vr4300el-* \ + | mips64vr5000-* | mips64vr5000el-* \ + | mips64vr5900-* | mips64vr5900el-* \ + | mipsisa32-* | mipsisa32el-* \ + | mipsisa32r2-* | mipsisa32r2el-* \ + | mipsisa64-* | mipsisa64el-* \ + | mipsisa64r2-* | mipsisa64r2el-* \ + | mipsisa64sb1-* | mipsisa64sb1el-* \ + | mipsisa64sr71k-* | mipsisa64sr71kel-* \ + | mipstx39-* | mipstx39el-* \ + | mmix-* \ + | mt-* \ + | msp430-* \ + | nios-* | nios2-* \ + | none-* | np1-* | ns16k-* | ns32k-* \ + | orion-* \ + | pdp10-* | pdp11-* | pj-* | pjl-* | pn-* | power-* \ + | powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* | ppcbe-* \ + | pyramid-* \ + | romp-* | rs6000-* \ + | sh-* | sh[1234]-* | sh[24]a-* | sh[23]e-* | sh[34]eb-* | shbe-* \ + | shle-* | sh[1234]le-* | sh3ele-* | sh64-* | sh64le-* \ + | sparc-* | sparc64-* | sparc64b-* | sparc86x-* | sparclet-* \ + | sparclite-* \ + | sparcv8-* | sparcv9-* | sparcv9b-* | strongarm-* | sv1-* | sx?-* \ + | tahoe-* | thumb-* \ + | tic30-* | tic4x-* | tic54x-* | tic55x-* | tic6x-* | tic80-* \ + | tron-* \ + | v850-* | v850e-* | vax-* \ + | we32k-* \ + | x86-* | x86_64-* | xps100-* | xscale-* | xscalee[bl]-* \ + | xstormy16-* | xtensa-* \ + | ymp-* \ + | z8k-*) + ;; + m32c-*) + ;; + # Recognize the various machine names and aliases which stand + # for a CPU type and a company and sometimes even an OS. + 386bsd) + basic_machine=i386-unknown + os=-bsd + ;; + 3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc) + basic_machine=m68000-att + ;; + 3b*) + basic_machine=we32k-att + ;; + a29khif) + basic_machine=a29k-amd + os=-udi + ;; + abacus) + basic_machine=abacus-unknown + ;; + adobe68k) + basic_machine=m68010-adobe + os=-scout + ;; + alliant | fx80) + basic_machine=fx80-alliant + ;; + altos | altos3068) + basic_machine=m68k-altos + ;; + am29k) + basic_machine=a29k-none + os=-bsd + ;; + amd64) + basic_machine=x86_64-pc + ;; + amd64-*) + basic_machine=x86_64-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + amdahl) + basic_machine=580-amdahl + os=-sysv + ;; + amiga | amiga-*) + basic_machine=m68k-unknown + ;; + amigaos | amigados) + basic_machine=m68k-unknown + os=-amigaos + ;; + amigaunix | amix) + basic_machine=m68k-unknown + os=-sysv4 + ;; + apollo68) + basic_machine=m68k-apollo + os=-sysv + ;; + apollo68bsd) + basic_machine=m68k-apollo + os=-bsd + ;; + aux) + basic_machine=m68k-apple + os=-aux + ;; + balance) + basic_machine=ns32k-sequent + os=-dynix + ;; + c90) + basic_machine=c90-cray + os=-unicos + ;; + convex-c1) + basic_machine=c1-convex + os=-bsd + ;; + convex-c2) + basic_machine=c2-convex + os=-bsd + ;; + convex-c32) + basic_machine=c32-convex + os=-bsd + ;; + convex-c34) + basic_machine=c34-convex + os=-bsd + ;; + convex-c38) + basic_machine=c38-convex + os=-bsd + ;; + cray | j90) + basic_machine=j90-cray + os=-unicos + ;; + craynv) + basic_machine=craynv-cray + os=-unicosmp + ;; + cr16c) + basic_machine=cr16c-unknown + os=-elf + ;; + crds | unos) + basic_machine=m68k-crds + ;; + crisv32 | crisv32-* | etraxfs*) + basic_machine=crisv32-axis + ;; + cris | cris-* | etrax*) + basic_machine=cris-axis + ;; + crx) + basic_machine=crx-unknown + os=-elf + ;; + da30 | da30-*) + basic_machine=m68k-da30 + ;; + decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn) + basic_machine=mips-dec + ;; + decsystem10* | dec10*) + basic_machine=pdp10-dec + os=-tops10 + ;; + decsystem20* | dec20*) + basic_machine=pdp10-dec + os=-tops20 + ;; + delta | 3300 | motorola-3300 | motorola-delta \ + | 3300-motorola | delta-motorola) + basic_machine=m68k-motorola + ;; + delta88) + basic_machine=m88k-motorola + os=-sysv3 + ;; + djgpp) + basic_machine=i586-pc + os=-msdosdjgpp + ;; + dpx20 | dpx20-*) + basic_machine=rs6000-bull + os=-bosx + ;; + dpx2* | dpx2*-bull) + basic_machine=m68k-bull + os=-sysv3 + ;; + ebmon29k) + basic_machine=a29k-amd + os=-ebmon + ;; + elxsi) + basic_machine=elxsi-elxsi + os=-bsd + ;; + encore | umax | mmax) + basic_machine=ns32k-encore + ;; + es1800 | OSE68k | ose68k | ose | OSE) + basic_machine=m68k-ericsson + os=-ose + ;; + fx2800) + basic_machine=i860-alliant + ;; + genix) + basic_machine=ns32k-ns + ;; + gmicro) + basic_machine=tron-gmicro + os=-sysv + ;; + go32) + basic_machine=i386-pc + os=-go32 + ;; + h3050r* | hiux*) + basic_machine=hppa1.1-hitachi + os=-hiuxwe2 + ;; + h8300hms) + basic_machine=h8300-hitachi + os=-hms + ;; + h8300xray) + basic_machine=h8300-hitachi + os=-xray + ;; + h8500hms) + basic_machine=h8500-hitachi + os=-hms + ;; + harris) + basic_machine=m88k-harris + os=-sysv3 + ;; + hp300-*) + basic_machine=m68k-hp + ;; + hp300bsd) + basic_machine=m68k-hp + os=-bsd + ;; + hp300hpux) + basic_machine=m68k-hp + os=-hpux + ;; + hp3k9[0-9][0-9] | hp9[0-9][0-9]) + basic_machine=hppa1.0-hp + ;; + hp9k2[0-9][0-9] | hp9k31[0-9]) + basic_machine=m68000-hp + ;; + hp9k3[2-9][0-9]) + basic_machine=m68k-hp + ;; + hp9k6[0-9][0-9] | hp6[0-9][0-9]) + basic_machine=hppa1.0-hp + ;; + hp9k7[0-79][0-9] | hp7[0-79][0-9]) + basic_machine=hppa1.1-hp + ;; + hp9k78[0-9] | hp78[0-9]) + # FIXME: really hppa2.0-hp + basic_machine=hppa1.1-hp + ;; + hp9k8[67]1 | hp8[67]1 | hp9k80[24] | hp80[24] | hp9k8[78]9 | hp8[78]9 | hp9k893 | hp893) + # FIXME: really hppa2.0-hp + basic_machine=hppa1.1-hp + ;; + hp9k8[0-9][13679] | hp8[0-9][13679]) + basic_machine=hppa1.1-hp + ;; + hp9k8[0-9][0-9] | hp8[0-9][0-9]) + basic_machine=hppa1.0-hp + ;; + hppa-next) + os=-nextstep3 + ;; + hppaosf) + basic_machine=hppa1.1-hp + os=-osf + ;; + hppro) + basic_machine=hppa1.1-hp + os=-proelf + ;; + i370-ibm* | ibm*) + basic_machine=i370-ibm + ;; +# I'm not sure what "Sysv32" means. Should this be sysv3.2? + i*86v32) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-sysv32 + ;; + i*86v4*) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-sysv4 + ;; + i*86v) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-sysv + ;; + i*86sol2) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-solaris2 + ;; + i386mach) + basic_machine=i386-mach + os=-mach + ;; + i386-vsta | vsta) + basic_machine=i386-unknown + os=-vsta + ;; + iris | iris4d) + basic_machine=mips-sgi + case $os in + -irix*) + ;; + *) + os=-irix4 + ;; + esac + ;; + isi68 | isi) + basic_machine=m68k-isi + os=-sysv + ;; + m88k-omron*) + basic_machine=m88k-omron + ;; + magnum | m3230) + basic_machine=mips-mips + os=-sysv + ;; + merlin) + basic_machine=ns32k-utek + os=-sysv + ;; + mingw32) + basic_machine=i386-pc + os=-mingw32 + ;; + miniframe) + basic_machine=m68000-convergent + ;; + *mint | -mint[0-9]* | *MiNT | *MiNT[0-9]*) + basic_machine=m68k-atari + os=-mint + ;; + mips3*-*) + basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'` + ;; + mips3*) + basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown + ;; + monitor) + basic_machine=m68k-rom68k + os=-coff + ;; + morphos) + basic_machine=powerpc-unknown + os=-morphos + ;; + msdos) + basic_machine=i386-pc + os=-msdos + ;; + ms1-*) + basic_machine=`echo $basic_machine | sed -e 's/ms1-/mt-/'` + ;; + mvs) + basic_machine=i370-ibm + os=-mvs + ;; + ncr3000) + basic_machine=i486-ncr + os=-sysv4 + ;; + netbsd386) + basic_machine=i386-unknown + os=-netbsd + ;; + netwinder) + basic_machine=armv4l-rebel + os=-linux + ;; + news | news700 | news800 | news900) + basic_machine=m68k-sony + os=-newsos + ;; + news1000) + basic_machine=m68030-sony + os=-newsos + ;; + news-3600 | risc-news) + basic_machine=mips-sony + os=-newsos + ;; + necv70) + basic_machine=v70-nec + os=-sysv + ;; + next | m*-next ) + basic_machine=m68k-next + case $os in + -nextstep* ) + ;; + -ns2*) + os=-nextstep2 + ;; + *) + os=-nextstep3 + ;; + esac + ;; + nh3000) + basic_machine=m68k-harris + os=-cxux + ;; + nh[45]000) + basic_machine=m88k-harris + os=-cxux + ;; + nindy960) + basic_machine=i960-intel + os=-nindy + ;; + mon960) + basic_machine=i960-intel + os=-mon960 + ;; + nonstopux) + basic_machine=mips-compaq + os=-nonstopux + ;; + np1) + basic_machine=np1-gould + ;; + nsr-tandem) + basic_machine=nsr-tandem + ;; + op50n-* | op60c-*) + basic_machine=hppa1.1-oki + os=-proelf + ;; + openrisc | openrisc-*) + basic_machine=or32-unknown + ;; + os400) + basic_machine=powerpc-ibm + os=-os400 + ;; + OSE68000 | ose68000) + basic_machine=m68000-ericsson + os=-ose + ;; + os68k) + basic_machine=m68k-none + os=-os68k + ;; + pa-hitachi) + basic_machine=hppa1.1-hitachi + os=-hiuxwe2 + ;; + paragon) + basic_machine=i860-intel + os=-osf + ;; + pbd) + basic_machine=sparc-tti + ;; + pbb) + basic_machine=m68k-tti + ;; + pc532 | pc532-*) + basic_machine=ns32k-pc532 + ;; + pc98) + basic_machine=i386-pc + ;; + pc98-*) + basic_machine=i386-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pentium | p5 | k5 | k6 | nexgen | viac3) + basic_machine=i586-pc + ;; + pentiumpro | p6 | 6x86 | athlon | athlon_*) + basic_machine=i686-pc + ;; + pentiumii | pentium2 | pentiumiii | pentium3) + basic_machine=i686-pc + ;; + pentium4) + basic_machine=i786-pc + ;; + pentium-* | p5-* | k5-* | k6-* | nexgen-* | viac3-*) + basic_machine=i586-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pentiumpro-* | p6-* | 6x86-* | athlon-*) + basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pentiumii-* | pentium2-* | pentiumiii-* | pentium3-*) + basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pentium4-*) + basic_machine=i786-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pn) + basic_machine=pn-gould + ;; + power) basic_machine=power-ibm + ;; + ppc) basic_machine=powerpc-unknown + ;; + ppc-*) basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ppcle | powerpclittle | ppc-le | powerpc-little) + basic_machine=powerpcle-unknown + ;; + ppcle-* | powerpclittle-*) + basic_machine=powerpcle-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ppc64) basic_machine=powerpc64-unknown + ;; + ppc64-*) basic_machine=powerpc64-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ppc64le | powerpc64little | ppc64-le | powerpc64-little) + basic_machine=powerpc64le-unknown + ;; + ppc64le-* | powerpc64little-*) + basic_machine=powerpc64le-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ps2) + basic_machine=i386-ibm + ;; + pw32) + basic_machine=i586-unknown + os=-pw32 + ;; + rdos) + basic_machine=i386-pc + os=-rdos + ;; + rom68k) + basic_machine=m68k-rom68k + os=-coff + ;; + rm[46]00) + basic_machine=mips-siemens + ;; + rtpc | rtpc-*) + basic_machine=romp-ibm + ;; + s390 | s390-*) + basic_machine=s390-ibm + ;; + s390x | s390x-*) + basic_machine=s390x-ibm + ;; + sa29200) + basic_machine=a29k-amd + os=-udi + ;; + sb1) + basic_machine=mipsisa64sb1-unknown + ;; + sb1el) + basic_machine=mipsisa64sb1el-unknown + ;; + sei) + basic_machine=mips-sei + os=-seiux + ;; + sequent) + basic_machine=i386-sequent + ;; + sh) + basic_machine=sh-hitachi + os=-hms + ;; + sh64) + basic_machine=sh64-unknown + ;; + sparclite-wrs | simso-wrs) + basic_machine=sparclite-wrs + os=-vxworks + ;; + sps7) + basic_machine=m68k-bull + os=-sysv2 + ;; + spur) + basic_machine=spur-unknown + ;; + st2000) + basic_machine=m68k-tandem + ;; + stratus) + basic_machine=i860-stratus + os=-sysv4 + ;; + sun2) + basic_machine=m68000-sun + ;; + sun2os3) + basic_machine=m68000-sun + os=-sunos3 + ;; + sun2os4) + basic_machine=m68000-sun + os=-sunos4 + ;; + sun3os3) + basic_machine=m68k-sun + os=-sunos3 + ;; + sun3os4) + basic_machine=m68k-sun + os=-sunos4 + ;; + sun4os3) + basic_machine=sparc-sun + os=-sunos3 + ;; + sun4os4) + basic_machine=sparc-sun + os=-sunos4 + ;; + sun4sol2) + basic_machine=sparc-sun + os=-solaris2 + ;; + sun3 | sun3-*) + basic_machine=m68k-sun + ;; + sun4) + basic_machine=sparc-sun + ;; + sun386 | sun386i | roadrunner) + basic_machine=i386-sun + ;; + sv1) + basic_machine=sv1-cray + os=-unicos + ;; + symmetry) + basic_machine=i386-sequent + os=-dynix + ;; + t3e) + basic_machine=alphaev5-cray + os=-unicos + ;; + t90) + basic_machine=t90-cray + os=-unicos + ;; + tic54x | c54x*) + basic_machine=tic54x-unknown + os=-coff + ;; + tic55x | c55x*) + basic_machine=tic55x-unknown + os=-coff + ;; + tic6x | c6x*) + basic_machine=tic6x-unknown + os=-coff + ;; + tx39) + basic_machine=mipstx39-unknown + ;; + tx39el) + basic_machine=mipstx39el-unknown + ;; + toad1) + basic_machine=pdp10-xkl + os=-tops20 + ;; + tower | tower-32) + basic_machine=m68k-ncr + ;; + tpf) + basic_machine=s390x-ibm + os=-tpf + ;; + udi29k) + basic_machine=a29k-amd + os=-udi + ;; + ultra3) + basic_machine=a29k-nyu + os=-sym1 + ;; + v810 | necv810) + basic_machine=v810-nec + os=-none + ;; + vaxv) + basic_machine=vax-dec + os=-sysv + ;; + vms) + basic_machine=vax-dec + os=-vms + ;; + vpp*|vx|vx-*) + basic_machine=f301-fujitsu + ;; + vxworks960) + basic_machine=i960-wrs + os=-vxworks + ;; + vxworks68) + basic_machine=m68k-wrs + os=-vxworks + ;; + vxworks29k) + basic_machine=a29k-wrs + os=-vxworks + ;; + w65*) + basic_machine=w65-wdc + os=-none + ;; + w89k-*) + basic_machine=hppa1.1-winbond + os=-proelf + ;; + xbox) + basic_machine=i686-pc + os=-mingw32 + ;; + xps | xps100) + basic_machine=xps100-honeywell + ;; + ymp) + basic_machine=ymp-cray + os=-unicos + ;; + z8k-*-coff) + basic_machine=z8k-unknown + os=-sim + ;; + none) + basic_machine=none-none + os=-none + ;; + +# Here we handle the default manufacturer of certain CPU types. It is in +# some cases the only manufacturer, in others, it is the most popular. + w89k) + basic_machine=hppa1.1-winbond + ;; + op50n) + basic_machine=hppa1.1-oki + ;; + op60c) + basic_machine=hppa1.1-oki + ;; + romp) + basic_machine=romp-ibm + ;; + mmix) + basic_machine=mmix-knuth + ;; + rs6000) + basic_machine=rs6000-ibm + ;; + vax) + basic_machine=vax-dec + ;; + pdp10) + # there are many clones, so DEC is not a safe bet + basic_machine=pdp10-unknown + ;; + pdp11) + basic_machine=pdp11-dec + ;; + we32k) + basic_machine=we32k-att + ;; + sh[1234] | sh[24]a | sh[34]eb | sh[1234]le | sh[23]ele) + basic_machine=sh-unknown + ;; + sparc | sparcv8 | sparcv9 | sparcv9b) + basic_machine=sparc-sun + ;; + cydra) + basic_machine=cydra-cydrome + ;; + orion) + basic_machine=orion-highlevel + ;; + orion105) + basic_machine=clipper-highlevel + ;; + mac | mpw | mac-mpw) + basic_machine=m68k-apple + ;; + pmac | pmac-mpw) + basic_machine=powerpc-apple + ;; + *-unknown) + # Make sure to match an already-canonicalized machine name. + ;; + *) + echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 + exit 1 + ;; +esac + +# Here we canonicalize certain aliases for manufacturers. +case $basic_machine in + *-digital*) + basic_machine=`echo $basic_machine | sed 's/digital.*/dec/'` + ;; + *-commodore*) + basic_machine=`echo $basic_machine | sed 's/commodore.*/cbm/'` + ;; + *) + ;; +esac + +# Decode manufacturer-specific aliases for certain operating systems. + +if [ x"$os" != x"" ] +then +case $os in + # First match some system type aliases + # that might get confused with valid system types. + # -solaris* is a basic system type, with this one exception. + -solaris1 | -solaris1.*) + os=`echo $os | sed -e 's|solaris1|sunos4|'` + ;; + -solaris) + os=-solaris2 + ;; + -svr4*) + os=-sysv4 + ;; + -unixware*) + os=-sysv4.2uw + ;; + -gnu/linux*) + os=`echo $os | sed -e 's|gnu/linux|linux-gnu|'` + ;; + # First accept the basic system types. + # The portable systems comes first. + # Each alternative MUST END IN A *, to match a version number. + # -sysv* is not here because it comes later, after sysvr4. + -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \ + | -*vms* | -sco* | -esix* | -isc* | -aix* | -sunos | -sunos[34]*\ + | -hpux* | -unos* | -osf* | -luna* | -dgux* | -solaris* | -sym* \ + | -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \ + | -aos* \ + | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \ + | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \ + | -hiux* | -386bsd* | -knetbsd* | -mirbsd* | -netbsd* \ + | -openbsd* | -solidbsd* \ + | -ekkobsd* | -kfreebsd* | -freebsd* | -riscix* | -lynxos* \ + | -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \ + | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \ + | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \ + | -chorusos* | -chorusrdb* \ + | -cygwin* | -pe* | -psos* | -moss* | -proelf* | -rtems* \ + | -mingw32* | -linux-gnu* | -linux-newlib* | -linux-uclibc* \ + | -uxpv* | -beos* | -mpeix* | -udk* \ + | -interix* | -uwin* | -mks* | -rhapsody* | -darwin* | -opened* \ + | -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \ + | -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* \ + | -os2* | -vos* | -palmos* | -uclinux* | -nucleus* \ + | -morphos* | -superux* | -rtmk* | -rtmk-nova* | -windiss* \ + | -powermax* | -dnix* | -nx6 | -nx7 | -sei* | -dragonfly* \ + | -skyos* | -haiku* | -rdos*) + # Remember, each alternative MUST END IN *, to match a version number. + ;; + -qnx*) + case $basic_machine in + x86-* | i*86-*) + ;; + *) + os=-nto$os + ;; + esac + ;; + -nto-qnx*) + ;; + -nto*) + os=`echo $os | sed -e 's|nto|nto-qnx|'` + ;; + -sim | -es1800* | -hms* | -xray | -os68k* | -none* | -v88r* \ + | -windows* | -osx | -abug | -netware* | -os9* | -beos* | -haiku* \ + | -macos* | -mpw* | -magic* | -mmixware* | -mon960* | -lnews*) + ;; + -mac*) + os=`echo $os | sed -e 's|mac|macos|'` + ;; + -linux-dietlibc) + os=-linux-dietlibc + ;; + -linux*) + os=`echo $os | sed -e 's|linux|linux-gnu|'` + ;; + -sunos5*) + os=`echo $os | sed -e 's|sunos5|solaris2|'` + ;; + -sunos6*) + os=`echo $os | sed -e 's|sunos6|solaris3|'` + ;; + -opened*) + os=-openedition + ;; + -os400*) + os=-os400 + ;; + -wince*) + os=-wince + ;; + -osfrose*) + os=-osfrose + ;; + -osf*) + os=-osf + ;; + -utek*) + os=-bsd + ;; + -dynix*) + os=-bsd + ;; + -acis*) + os=-aos + ;; + -atheos*) + os=-atheos + ;; + -syllable*) + os=-syllable + ;; + -386bsd) + os=-bsd + ;; + -ctix* | -uts*) + os=-sysv + ;; + -nova*) + os=-rtmk-nova + ;; + -ns2 ) + os=-nextstep2 + ;; + -nsk*) + os=-nsk + ;; + # Preserve the version number of sinix5. + -sinix5.*) + os=`echo $os | sed -e 's|sinix|sysv|'` + ;; + -sinix*) + os=-sysv4 + ;; + -tpf*) + os=-tpf + ;; + -triton*) + os=-sysv3 + ;; + -oss*) + os=-sysv3 + ;; + -svr4) + os=-sysv4 + ;; + -svr3) + os=-sysv3 + ;; + -sysvr4) + os=-sysv4 + ;; + # This must come after -sysvr4. + -sysv*) + ;; + -ose*) + os=-ose + ;; + -es1800*) + os=-ose + ;; + -xenix) + os=-xenix + ;; + -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) + os=-mint + ;; + -aros*) + os=-aros + ;; + -kaos*) + os=-kaos + ;; + -zvmoe) + os=-zvmoe + ;; + -none) + ;; + *) + # Get rid of the `-' at the beginning of $os. + os=`echo $os | sed 's/[^-]*-//'` + echo Invalid configuration \`$1\': system \`$os\' not recognized 1>&2 + exit 1 + ;; +esac +else + +# Here we handle the default operating systems that come with various machines. +# The value should be what the vendor currently ships out the door with their +# machine or put another way, the most popular os provided with the machine. + +# Note that if you're going to try to match "-MANUFACTURER" here (say, +# "-sun"), then you have to tell the case statement up towards the top +# that MANUFACTURER isn't an operating system. Otherwise, code above +# will signal an error saying that MANUFACTURER isn't an operating +# system, and we'll never get to this point. + +case $basic_machine in + *-acorn) + os=-riscix1.2 + ;; + arm*-rebel) + os=-linux + ;; + arm*-semi) + os=-aout + ;; + c4x-* | tic4x-*) + os=-coff + ;; + # This must come before the *-dec entry. + pdp10-*) + os=-tops20 + ;; + pdp11-*) + os=-none + ;; + *-dec | vax-*) + os=-ultrix4.2 + ;; + m68*-apollo) + os=-domain + ;; + i386-sun) + os=-sunos4.0.2 + ;; + m68000-sun) + os=-sunos3 + # This also exists in the configure program, but was not the + # default. + # os=-sunos4 + ;; + m68*-cisco) + os=-aout + ;; + mips*-cisco) + os=-elf + ;; + mips*-*) + os=-elf + ;; + or32-*) + os=-coff + ;; + *-tti) # must be before sparc entry or we get the wrong os. + os=-sysv3 + ;; + sparc-* | *-sun) + os=-sunos4.1.1 + ;; + *-be) + os=-beos + ;; + *-haiku) + os=-haiku + ;; + *-ibm) + os=-aix + ;; + *-knuth) + os=-mmixware + ;; + *-wec) + os=-proelf + ;; + *-winbond) + os=-proelf + ;; + *-oki) + os=-proelf + ;; + *-hp) + os=-hpux + ;; + *-hitachi) + os=-hiux + ;; + i860-* | *-att | *-ncr | *-altos | *-motorola | *-convergent) + os=-sysv + ;; + *-cbm) + os=-amigaos + ;; + *-dg) + os=-dgux + ;; + *-dolphin) + os=-sysv3 + ;; + m68k-ccur) + os=-rtu + ;; + m88k-omron*) + os=-luna + ;; + *-next ) + os=-nextstep + ;; + *-sequent) + os=-ptx + ;; + *-crds) + os=-unos + ;; + *-ns) + os=-genix + ;; + i370-*) + os=-mvs + ;; + *-next) + os=-nextstep3 + ;; + *-gould) + os=-sysv + ;; + *-highlevel) + os=-bsd + ;; + *-encore) + os=-bsd + ;; + *-sgi) + os=-irix + ;; + *-siemens) + os=-sysv4 + ;; + *-masscomp) + os=-rtu + ;; + f30[01]-fujitsu | f700-fujitsu) + os=-uxpv + ;; + *-rom68k) + os=-coff + ;; + *-*bug) + os=-coff + ;; + *-apple) + os=-macos + ;; + *-atari*) + os=-mint + ;; + *) + os=-none + ;; +esac +fi + +# Here we handle the case where we know the os, and the CPU type, but not the +# manufacturer. We pick the logical manufacturer. +vendor=unknown +case $basic_machine in + *-unknown) + case $os in + -riscix*) + vendor=acorn + ;; + -sunos*) + vendor=sun + ;; + -aix*) + vendor=ibm + ;; + -beos*) + vendor=be + ;; + -hpux*) + vendor=hp + ;; + -mpeix*) + vendor=hp + ;; + -hiux*) + vendor=hitachi + ;; + -unos*) + vendor=crds + ;; + -dgux*) + vendor=dg + ;; + -luna*) + vendor=omron + ;; + -genix*) + vendor=ns + ;; + -mvs* | -opened*) + vendor=ibm + ;; + -os400*) + vendor=ibm + ;; + -ptx*) + vendor=sequent + ;; + -tpf*) + vendor=ibm + ;; + -vxsim* | -vxworks* | -windiss*) + vendor=wrs + ;; + -aux*) + vendor=apple + ;; + -hms*) + vendor=hitachi + ;; + -mpw* | -macos*) + vendor=apple + ;; + -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) + vendor=atari + ;; + -vos*) + vendor=stratus + ;; + esac + basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"` + ;; +esac + +echo $basic_machine$os +exit + +# Local variables: +# eval: (add-hook 'write-file-hooks 'time-stamp) +# time-stamp-start: "timestamp='" +# time-stamp-format: "%:y-%02m-%02d" +# time-stamp-end: "'" +# End: diff --git a/configure b/configure new file mode 100644 --- /dev/null +++ b/configure @@ -0,0 +1,6297 @@ +#! /bin/sh +# Guess values for system-dependent variables and create Makefiles. +# Generated by GNU Autoconf 2.61 for Haskell network package 2.3.0.11. +# +# Report bugs to . +# +# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, +# 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. +# This configure script is free software; the Free Software Foundation +# gives unlimited permission to copy, distribute and modify it. +## --------------------- ## +## M4sh Initialization. ## +## --------------------- ## + +# Be more Bourne compatible +DUALCASE=1; export DUALCASE # for MKS sh +if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then + emulate sh + NULLCMD=: + # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which + # is contrary to our usage. Disable this feature. + alias -g '${1+"$@"}'='"$@"' + setopt NO_GLOB_SUBST +else + case `(set -o) 2>/dev/null` in + *posix*) set -o posix ;; +esac + +fi + + + + +# PATH needs CR +# Avoid depending upon Character Ranges. +as_cr_letters='abcdefghijklmnopqrstuvwxyz' +as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' +as_cr_Letters=$as_cr_letters$as_cr_LETTERS +as_cr_digits='0123456789' +as_cr_alnum=$as_cr_Letters$as_cr_digits + +# The user is always right. +if test "${PATH_SEPARATOR+set}" != set; then + echo "#! /bin/sh" >conf$$.sh + echo "exit 0" >>conf$$.sh + chmod +x conf$$.sh + if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then + PATH_SEPARATOR=';' + else + PATH_SEPARATOR=: + fi + rm -f conf$$.sh +fi + +# Support unset when possible. +if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then + as_unset=unset +else + as_unset=false +fi + + +# IFS +# We need space, tab and new line, in precisely that order. Quoting is +# there to prevent editors from complaining about space-tab. +# (If _AS_PATH_WALK were called with IFS unset, it would disable word +# splitting by setting IFS to empty value.) +as_nl=' +' +IFS=" "" $as_nl" + +# Find who we are. Look in the path if we contain no directory separator. +case $0 in + *[\\/]* ) as_myself=$0 ;; + *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break +done +IFS=$as_save_IFS + + ;; +esac +# We did not find ourselves, most probably we were run as `sh COMMAND' +# in which case we are not to be found in the path. +if test "x$as_myself" = x; then + as_myself=$0 +fi +if test ! -f "$as_myself"; then + echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 + { (exit 1); exit 1; } +fi + +# Work around bugs in pre-3.0 UWIN ksh. +for as_var in ENV MAIL MAILPATH +do ($as_unset $as_var) >/dev/null 2>&1 && $as_unset $as_var +done +PS1='$ ' +PS2='> ' +PS4='+ ' + +# NLS nuisances. +for as_var in \ + LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \ + LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \ + LC_TELEPHONE LC_TIME +do + if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then + eval $as_var=C; export $as_var + else + ($as_unset $as_var) >/dev/null 2>&1 && $as_unset $as_var + fi +done + +# Required to use basename. +if expr a : '\(a\)' >/dev/null 2>&1 && + test "X`expr 00001 : '.*\(...\)'`" = X001; then + as_expr=expr +else + as_expr=false +fi + +if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then + as_basename=basename +else + as_basename=false +fi + + +# Name of the executable. +as_me=`$as_basename -- "$0" || +$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ + X"$0" : 'X\(//\)$' \| \ + X"$0" : 'X\(/\)' \| . 2>/dev/null || +echo X/"$0" | + sed '/^.*\/\([^/][^/]*\)\/*$/{ + s//\1/ + q + } + /^X\/\(\/\/\)$/{ + s//\1/ + q + } + /^X\/\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + +# CDPATH. +$as_unset CDPATH + + +if test "x$CONFIG_SHELL" = x; then + if (eval ":") 2>/dev/null; then + as_have_required=yes +else + as_have_required=no +fi + + if test $as_have_required = yes && (eval ": +(as_func_return () { + (exit \$1) +} +as_func_success () { + as_func_return 0 +} +as_func_failure () { + as_func_return 1 +} +as_func_ret_success () { + return 0 +} +as_func_ret_failure () { + return 1 +} + +exitcode=0 +if as_func_success; then + : +else + exitcode=1 + echo as_func_success failed. +fi + +if as_func_failure; then + exitcode=1 + echo as_func_failure succeeded. +fi + +if as_func_ret_success; then + : +else + exitcode=1 + echo as_func_ret_success failed. +fi + +if as_func_ret_failure; then + exitcode=1 + echo as_func_ret_failure succeeded. +fi + +if ( set x; as_func_ret_success y && test x = \"\$1\" ); then + : +else + exitcode=1 + echo positional parameters were not saved. +fi + +test \$exitcode = 0) || { (exit 1); exit 1; } + +( + as_lineno_1=\$LINENO + as_lineno_2=\$LINENO + test \"x\$as_lineno_1\" != \"x\$as_lineno_2\" && + test \"x\`expr \$as_lineno_1 + 1\`\" = \"x\$as_lineno_2\") || { (exit 1); exit 1; } +") 2> /dev/null; then + : +else + as_candidate_shells= + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + case $as_dir in + /*) + for as_base in sh bash ksh sh5; do + as_candidate_shells="$as_candidate_shells $as_dir/$as_base" + done;; + esac +done +IFS=$as_save_IFS + + + for as_shell in $as_candidate_shells $SHELL; do + # Try only shells that exist, to save several forks. + if { test -f "$as_shell" || test -f "$as_shell.exe"; } && + { ("$as_shell") 2> /dev/null <<\_ASEOF +if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then + emulate sh + NULLCMD=: + # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which + # is contrary to our usage. Disable this feature. + alias -g '${1+"$@"}'='"$@"' + setopt NO_GLOB_SUBST +else + case `(set -o) 2>/dev/null` in + *posix*) set -o posix ;; +esac + +fi + + +: +_ASEOF +}; then + CONFIG_SHELL=$as_shell + as_have_required=yes + if { "$as_shell" 2> /dev/null <<\_ASEOF +if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then + emulate sh + NULLCMD=: + # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which + # is contrary to our usage. Disable this feature. + alias -g '${1+"$@"}'='"$@"' + setopt NO_GLOB_SUBST +else + case `(set -o) 2>/dev/null` in + *posix*) set -o posix ;; +esac + +fi + + +: +(as_func_return () { + (exit $1) +} +as_func_success () { + as_func_return 0 +} +as_func_failure () { + as_func_return 1 +} +as_func_ret_success () { + return 0 +} +as_func_ret_failure () { + return 1 +} + +exitcode=0 +if as_func_success; then + : +else + exitcode=1 + echo as_func_success failed. +fi + +if as_func_failure; then + exitcode=1 + echo as_func_failure succeeded. +fi + +if as_func_ret_success; then + : +else + exitcode=1 + echo as_func_ret_success failed. +fi + +if as_func_ret_failure; then + exitcode=1 + echo as_func_ret_failure succeeded. +fi + +if ( set x; as_func_ret_success y && test x = "$1" ); then + : +else + exitcode=1 + echo positional parameters were not saved. +fi + +test $exitcode = 0) || { (exit 1); exit 1; } + +( + as_lineno_1=$LINENO + as_lineno_2=$LINENO + test "x$as_lineno_1" != "x$as_lineno_2" && + test "x`expr $as_lineno_1 + 1`" = "x$as_lineno_2") || { (exit 1); exit 1; } + +_ASEOF +}; then + break +fi + +fi + + done + + if test "x$CONFIG_SHELL" != x; then + for as_var in BASH_ENV ENV + do ($as_unset $as_var) >/dev/null 2>&1 && $as_unset $as_var + done + export CONFIG_SHELL + exec "$CONFIG_SHELL" "$as_myself" ${1+"$@"} +fi + + + if test $as_have_required = no; then + echo This script requires a shell more modern than all the + echo shells that I found on your system. Please install a + echo modern shell, or manually run the script under such a + echo shell if you do have one. + { (exit 1); exit 1; } +fi + + +fi + +fi + + + +(eval "as_func_return () { + (exit \$1) +} +as_func_success () { + as_func_return 0 +} +as_func_failure () { + as_func_return 1 +} +as_func_ret_success () { + return 0 +} +as_func_ret_failure () { + return 1 +} + +exitcode=0 +if as_func_success; then + : +else + exitcode=1 + echo as_func_success failed. +fi + +if as_func_failure; then + exitcode=1 + echo as_func_failure succeeded. +fi + +if as_func_ret_success; then + : +else + exitcode=1 + echo as_func_ret_success failed. +fi + +if as_func_ret_failure; then + exitcode=1 + echo as_func_ret_failure succeeded. +fi + +if ( set x; as_func_ret_success y && test x = \"\$1\" ); then + : +else + exitcode=1 + echo positional parameters were not saved. +fi + +test \$exitcode = 0") || { + echo No shell found that supports shell functions. + echo Please tell autoconf@gnu.org about your system, + echo including any error possibly output before this + echo message +} + + + + as_lineno_1=$LINENO + as_lineno_2=$LINENO + test "x$as_lineno_1" != "x$as_lineno_2" && + test "x`expr $as_lineno_1 + 1`" = "x$as_lineno_2" || { + + # Create $as_me.lineno as a copy of $as_myself, but with $LINENO + # uniformly replaced by the line number. The first 'sed' inserts a + # line-number line after each line using $LINENO; the second 'sed' + # does the real work. The second script uses 'N' to pair each + # line-number line with the line containing $LINENO, and appends + # trailing '-' during substitution so that $LINENO is not a special + # case at line end. + # (Raja R Harinath suggested sed '=', and Paul Eggert wrote the + # scripts with optimization help from Paolo Bonzini. Blame Lee + # E. McMahon (1931-1989) for sed's syntax. :-) + sed -n ' + p + /[$]LINENO/= + ' <$as_myself | + sed ' + s/[$]LINENO.*/&-/ + t lineno + b + :lineno + N + :loop + s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ + t loop + s/-\n.*// + ' >$as_me.lineno && + chmod +x "$as_me.lineno" || + { echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2 + { (exit 1); exit 1; }; } + + # Don't try to exec as it changes $[0], causing all sort of problems + # (the dirname of $[0] is not the place where we might find the + # original and so on. Autoconf is especially sensitive to this). + . "./$as_me.lineno" + # Exit status is that of the last command. + exit +} + + +if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then + as_dirname=dirname +else + as_dirname=false +fi + +ECHO_C= ECHO_N= ECHO_T= +case `echo -n x` in +-n*) + case `echo 'x\c'` in + *c*) ECHO_T=' ';; # ECHO_T is single tab character. + *) ECHO_C='\c';; + esac;; +*) + ECHO_N='-n';; +esac + +if expr a : '\(a\)' >/dev/null 2>&1 && + test "X`expr 00001 : '.*\(...\)'`" = X001; then + as_expr=expr +else + as_expr=false +fi + +rm -f conf$$ conf$$.exe conf$$.file +if test -d conf$$.dir; then + rm -f conf$$.dir/conf$$.file +else + rm -f conf$$.dir + mkdir conf$$.dir +fi +echo >conf$$.file +if ln -s conf$$.file conf$$ 2>/dev/null; then + as_ln_s='ln -s' + # ... but there are two gotchas: + # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. + # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. + # In both cases, we have to default to `cp -p'. + ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || + as_ln_s='cp -p' +elif ln conf$$.file conf$$ 2>/dev/null; then + as_ln_s=ln +else + as_ln_s='cp -p' +fi +rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file +rmdir conf$$.dir 2>/dev/null + +if mkdir -p . 2>/dev/null; then + as_mkdir_p=: +else + test -d ./-p && rmdir ./-p + as_mkdir_p=false +fi + +if test -x / >/dev/null 2>&1; then + as_test_x='test -x' +else + if ls -dL / >/dev/null 2>&1; then + as_ls_L_option=L + else + as_ls_L_option= + fi + as_test_x=' + eval sh -c '\'' + if test -d "$1"; then + test -d "$1/."; + else + case $1 in + -*)set "./$1";; + esac; + case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in + ???[sx]*):;;*)false;;esac;fi + '\'' sh + ' +fi +as_executable_p=$as_test_x + +# Sed expression to map a string onto a valid CPP name. +as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" + +# Sed expression to map a string onto a valid variable name. +as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" + + + +exec 7<&0 &1 + +# Name of the host. +# hostname on some systems (SVR3.2, Linux) returns a bogus exit status, +# so uname gets run too. +ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` + +# +# Initializations. +# +ac_default_prefix=/usr/local +ac_clean_files= +ac_config_libobj_dir=. +LIBOBJS= +cross_compiling=no +subdirs= +MFLAGS= +MAKEFLAGS= +SHELL=${CONFIG_SHELL-/bin/sh} + +# Identity of this package. +PACKAGE_NAME='Haskell network package' +PACKAGE_TARNAME='network' +PACKAGE_VERSION='2.3.0.11' +PACKAGE_STRING='Haskell network package 2.3.0.11' +PACKAGE_BUGREPORT='libraries@haskell.org' + +ac_unique_file="include/HsNet.h" +# Factoring default headers for most tests. +ac_includes_default="\ +#include +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#ifdef HAVE_SYS_STAT_H +# include +#endif +#ifdef STDC_HEADERS +# include +# include +#else +# ifdef HAVE_STDLIB_H +# include +# endif +#endif +#ifdef HAVE_STRING_H +# if !defined STDC_HEADERS && defined HAVE_MEMORY_H +# include +# endif +# include +#endif +#ifdef HAVE_STRINGS_H +# include +#endif +#ifdef HAVE_INTTYPES_H +# include +#endif +#ifdef HAVE_STDINT_H +# include +#endif +#ifdef HAVE_UNISTD_H +# include +#endif" + +ac_subst_vars='SHELL +PATH_SEPARATOR +PACKAGE_NAME +PACKAGE_TARNAME +PACKAGE_VERSION +PACKAGE_STRING +PACKAGE_BUGREPORT +exec_prefix +prefix +program_transform_name +bindir +sbindir +libexecdir +datarootdir +datadir +sysconfdir +sharedstatedir +localstatedir +includedir +oldincludedir +docdir +infodir +htmldir +dvidir +pdfdir +psdir +libdir +localedir +mandir +DEFS +ECHO_C +ECHO_N +ECHO_T +LIBS +build_alias +host_alias +target_alias +build +build_cpu +build_vendor +build_os +host +host_cpu +host_vendor +host_os +CC +CFLAGS +LDFLAGS +CPPFLAGS +ac_ct_CC +EXEEXT +OBJEXT +CPP +GREP +EGREP +CALLCONV +EXTRA_CPPFLAGS +EXTRA_LIBS +EXTRA_SRCS +LIBOBJS +LTLIBOBJS' +ac_subst_files='' + ac_precious_vars='build_alias +host_alias +target_alias +CC +CFLAGS +LDFLAGS +LIBS +CPPFLAGS +CPP' + + +# Initialize some variables set by options. +ac_init_help= +ac_init_version=false +# The variables have the same names as the options, with +# dashes changed to underlines. +cache_file=/dev/null +exec_prefix=NONE +no_create= +no_recursion= +prefix=NONE +program_prefix=NONE +program_suffix=NONE +program_transform_name=s,x,x, +silent= +site= +srcdir= +verbose= +x_includes=NONE +x_libraries=NONE + +# Installation directory options. +# These are left unexpanded so users can "make install exec_prefix=/foo" +# and all the variables that are supposed to be based on exec_prefix +# by default will actually change. +# Use braces instead of parens because sh, perl, etc. also accept them. +# (The list follows the same order as the GNU Coding Standards.) +bindir='${exec_prefix}/bin' +sbindir='${exec_prefix}/sbin' +libexecdir='${exec_prefix}/libexec' +datarootdir='${prefix}/share' +datadir='${datarootdir}' +sysconfdir='${prefix}/etc' +sharedstatedir='${prefix}/com' +localstatedir='${prefix}/var' +includedir='${prefix}/include' +oldincludedir='/usr/include' +docdir='${datarootdir}/doc/${PACKAGE_TARNAME}' +infodir='${datarootdir}/info' +htmldir='${docdir}' +dvidir='${docdir}' +pdfdir='${docdir}' +psdir='${docdir}' +libdir='${exec_prefix}/lib' +localedir='${datarootdir}/locale' +mandir='${datarootdir}/man' + +ac_prev= +ac_dashdash= +for ac_option +do + # If the previous option needs an argument, assign it. + if test -n "$ac_prev"; then + eval $ac_prev=\$ac_option + ac_prev= + continue + fi + + case $ac_option in + *=*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; + *) ac_optarg=yes ;; + esac + + # Accept the important Cygnus configure options, so we can diagnose typos. + + case $ac_dashdash$ac_option in + --) + ac_dashdash=yes ;; + + -bindir | --bindir | --bindi | --bind | --bin | --bi) + ac_prev=bindir ;; + -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) + bindir=$ac_optarg ;; + + -build | --build | --buil | --bui | --bu) + ac_prev=build_alias ;; + -build=* | --build=* | --buil=* | --bui=* | --bu=*) + build_alias=$ac_optarg ;; + + -cache-file | --cache-file | --cache-fil | --cache-fi \ + | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) + ac_prev=cache_file ;; + -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ + | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) + cache_file=$ac_optarg ;; + + --config-cache | -C) + cache_file=config.cache ;; + + -datadir | --datadir | --datadi | --datad) + ac_prev=datadir ;; + -datadir=* | --datadir=* | --datadi=* | --datad=*) + datadir=$ac_optarg ;; + + -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ + | --dataroo | --dataro | --datar) + ac_prev=datarootdir ;; + -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ + | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) + datarootdir=$ac_optarg ;; + + -disable-* | --disable-*) + ac_feature=`expr "x$ac_option" : 'x-*disable-\(.*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_feature" : ".*[^-._$as_cr_alnum]" >/dev/null && + { echo "$as_me: error: invalid feature name: $ac_feature" >&2 + { (exit 1); exit 1; }; } + ac_feature=`echo $ac_feature | sed 's/[-.]/_/g'` + eval enable_$ac_feature=no ;; + + -docdir | --docdir | --docdi | --doc | --do) + ac_prev=docdir ;; + -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) + docdir=$ac_optarg ;; + + -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) + ac_prev=dvidir ;; + -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) + dvidir=$ac_optarg ;; + + -enable-* | --enable-*) + ac_feature=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_feature" : ".*[^-._$as_cr_alnum]" >/dev/null && + { echo "$as_me: error: invalid feature name: $ac_feature" >&2 + { (exit 1); exit 1; }; } + ac_feature=`echo $ac_feature | sed 's/[-.]/_/g'` + eval enable_$ac_feature=\$ac_optarg ;; + + -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ + | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ + | --exec | --exe | --ex) + ac_prev=exec_prefix ;; + -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ + | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ + | --exec=* | --exe=* | --ex=*) + exec_prefix=$ac_optarg ;; + + -gas | --gas | --ga | --g) + # Obsolete; use --with-gas. + with_gas=yes ;; + + -help | --help | --hel | --he | -h) + ac_init_help=long ;; + -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) + ac_init_help=recursive ;; + -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) + ac_init_help=short ;; + + -host | --host | --hos | --ho) + ac_prev=host_alias ;; + -host=* | --host=* | --hos=* | --ho=*) + host_alias=$ac_optarg ;; + + -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) + ac_prev=htmldir ;; + -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ + | --ht=*) + htmldir=$ac_optarg ;; + + -includedir | --includedir | --includedi | --included | --include \ + | --includ | --inclu | --incl | --inc) + ac_prev=includedir ;; + -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ + | --includ=* | --inclu=* | --incl=* | --inc=*) + includedir=$ac_optarg ;; + + -infodir | --infodir | --infodi | --infod | --info | --inf) + ac_prev=infodir ;; + -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) + infodir=$ac_optarg ;; + + -libdir | --libdir | --libdi | --libd) + ac_prev=libdir ;; + -libdir=* | --libdir=* | --libdi=* | --libd=*) + libdir=$ac_optarg ;; + + -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ + | --libexe | --libex | --libe) + ac_prev=libexecdir ;; + -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ + | --libexe=* | --libex=* | --libe=*) + libexecdir=$ac_optarg ;; + + -localedir | --localedir | --localedi | --localed | --locale) + ac_prev=localedir ;; + -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) + localedir=$ac_optarg ;; + + -localstatedir | --localstatedir | --localstatedi | --localstated \ + | --localstate | --localstat | --localsta | --localst | --locals) + ac_prev=localstatedir ;; + -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ + | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) + localstatedir=$ac_optarg ;; + + -mandir | --mandir | --mandi | --mand | --man | --ma | --m) + ac_prev=mandir ;; + -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) + mandir=$ac_optarg ;; + + -nfp | --nfp | --nf) + # Obsolete; use --without-fp. + with_fp=no ;; + + -no-create | --no-create | --no-creat | --no-crea | --no-cre \ + | --no-cr | --no-c | -n) + no_create=yes ;; + + -no-recursion | --no-recursion | --no-recursio | --no-recursi \ + | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) + no_recursion=yes ;; + + -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ + | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ + | --oldin | --oldi | --old | --ol | --o) + ac_prev=oldincludedir ;; + -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ + | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ + | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) + oldincludedir=$ac_optarg ;; + + -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) + ac_prev=prefix ;; + -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) + prefix=$ac_optarg ;; + + -program-prefix | --program-prefix | --program-prefi | --program-pref \ + | --program-pre | --program-pr | --program-p) + ac_prev=program_prefix ;; + -program-prefix=* | --program-prefix=* | --program-prefi=* \ + | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) + program_prefix=$ac_optarg ;; + + -program-suffix | --program-suffix | --program-suffi | --program-suff \ + | --program-suf | --program-su | --program-s) + ac_prev=program_suffix ;; + -program-suffix=* | --program-suffix=* | --program-suffi=* \ + | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) + program_suffix=$ac_optarg ;; + + -program-transform-name | --program-transform-name \ + | --program-transform-nam | --program-transform-na \ + | --program-transform-n | --program-transform- \ + | --program-transform | --program-transfor \ + | --program-transfo | --program-transf \ + | --program-trans | --program-tran \ + | --progr-tra | --program-tr | --program-t) + ac_prev=program_transform_name ;; + -program-transform-name=* | --program-transform-name=* \ + | --program-transform-nam=* | --program-transform-na=* \ + | --program-transform-n=* | --program-transform-=* \ + | --program-transform=* | --program-transfor=* \ + | --program-transfo=* | --program-transf=* \ + | --program-trans=* | --program-tran=* \ + | --progr-tra=* | --program-tr=* | --program-t=*) + program_transform_name=$ac_optarg ;; + + -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) + ac_prev=pdfdir ;; + -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) + pdfdir=$ac_optarg ;; + + -psdir | --psdir | --psdi | --psd | --ps) + ac_prev=psdir ;; + -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) + psdir=$ac_optarg ;; + + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil) + silent=yes ;; + + -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) + ac_prev=sbindir ;; + -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ + | --sbi=* | --sb=*) + sbindir=$ac_optarg ;; + + -sharedstatedir | --sharedstatedir | --sharedstatedi \ + | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ + | --sharedst | --shareds | --shared | --share | --shar \ + | --sha | --sh) + ac_prev=sharedstatedir ;; + -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ + | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ + | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ + | --sha=* | --sh=*) + sharedstatedir=$ac_optarg ;; + + -site | --site | --sit) + ac_prev=site ;; + -site=* | --site=* | --sit=*) + site=$ac_optarg ;; + + -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) + ac_prev=srcdir ;; + -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) + srcdir=$ac_optarg ;; + + -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ + | --syscon | --sysco | --sysc | --sys | --sy) + ac_prev=sysconfdir ;; + -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ + | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) + sysconfdir=$ac_optarg ;; + + -target | --target | --targe | --targ | --tar | --ta | --t) + ac_prev=target_alias ;; + -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) + target_alias=$ac_optarg ;; + + -v | -verbose | --verbose | --verbos | --verbo | --verb) + verbose=yes ;; + + -version | --version | --versio | --versi | --vers | -V) + ac_init_version=: ;; + + -with-* | --with-*) + ac_package=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_package" : ".*[^-._$as_cr_alnum]" >/dev/null && + { echo "$as_me: error: invalid package name: $ac_package" >&2 + { (exit 1); exit 1; }; } + ac_package=`echo $ac_package | sed 's/[-.]/_/g'` + eval with_$ac_package=\$ac_optarg ;; + + -without-* | --without-*) + ac_package=`expr "x$ac_option" : 'x-*without-\(.*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_package" : ".*[^-._$as_cr_alnum]" >/dev/null && + { echo "$as_me: error: invalid package name: $ac_package" >&2 + { (exit 1); exit 1; }; } + ac_package=`echo $ac_package | sed 's/[-.]/_/g'` + eval with_$ac_package=no ;; + + --x) + # Obsolete; use --with-x. + with_x=yes ;; + + -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ + | --x-incl | --x-inc | --x-in | --x-i) + ac_prev=x_includes ;; + -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ + | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) + x_includes=$ac_optarg ;; + + -x-libraries | --x-libraries | --x-librarie | --x-librari \ + | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) + ac_prev=x_libraries ;; + -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ + | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) + x_libraries=$ac_optarg ;; + + -*) { echo "$as_me: error: unrecognized option: $ac_option +Try \`$0 --help' for more information." >&2 + { (exit 1); exit 1; }; } + ;; + + *=*) + ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` + # Reject names that are not valid shell variable names. + expr "x$ac_envvar" : ".*[^_$as_cr_alnum]" >/dev/null && + { echo "$as_me: error: invalid variable name: $ac_envvar" >&2 + { (exit 1); exit 1; }; } + eval $ac_envvar=\$ac_optarg + export $ac_envvar ;; + + *) + # FIXME: should be removed in autoconf 3.0. + echo "$as_me: WARNING: you should use --build, --host, --target" >&2 + expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && + echo "$as_me: WARNING: invalid host type: $ac_option" >&2 + : ${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option} + ;; + + esac +done + +if test -n "$ac_prev"; then + ac_option=--`echo $ac_prev | sed 's/_/-/g'` + { echo "$as_me: error: missing argument to $ac_option" >&2 + { (exit 1); exit 1; }; } +fi + +# Be sure to have absolute directory names. +for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ + datadir sysconfdir sharedstatedir localstatedir includedir \ + oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ + libdir localedir mandir +do + eval ac_val=\$$ac_var + case $ac_val in + [\\/$]* | ?:[\\/]* ) continue;; + NONE | '' ) case $ac_var in *prefix ) continue;; esac;; + esac + { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2 + { (exit 1); exit 1; }; } +done + +# There might be people who depend on the old broken behavior: `$host' +# used to hold the argument of --host etc. +# FIXME: To remove some day. +build=$build_alias +host=$host_alias +target=$target_alias + +# FIXME: To remove some day. +if test "x$host_alias" != x; then + if test "x$build_alias" = x; then + cross_compiling=maybe + echo "$as_me: WARNING: If you wanted to set the --build type, don't use --host. + If a cross compiler is detected then cross compile mode will be used." >&2 + elif test "x$build_alias" != "x$host_alias"; then + cross_compiling=yes + fi +fi + +ac_tool_prefix= +test -n "$host_alias" && ac_tool_prefix=$host_alias- + +test "$silent" = yes && exec 6>/dev/null + + +ac_pwd=`pwd` && test -n "$ac_pwd" && +ac_ls_di=`ls -di .` && +ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || + { echo "$as_me: error: Working directory cannot be determined" >&2 + { (exit 1); exit 1; }; } +test "X$ac_ls_di" = "X$ac_pwd_ls_di" || + { echo "$as_me: error: pwd does not report name of working directory" >&2 + { (exit 1); exit 1; }; } + + +# Find the source files, if location was not specified. +if test -z "$srcdir"; then + ac_srcdir_defaulted=yes + # Try the directory containing this script, then the parent directory. + ac_confdir=`$as_dirname -- "$0" || +$as_expr X"$0" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$0" : 'X\(//\)[^/]' \| \ + X"$0" : 'X\(//\)$' \| \ + X"$0" : 'X\(/\)' \| . 2>/dev/null || +echo X"$0" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + srcdir=$ac_confdir + if test ! -r "$srcdir/$ac_unique_file"; then + srcdir=.. + fi +else + ac_srcdir_defaulted=no +fi +if test ! -r "$srcdir/$ac_unique_file"; then + test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." + { echo "$as_me: error: cannot find sources ($ac_unique_file) in $srcdir" >&2 + { (exit 1); exit 1; }; } +fi +ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" +ac_abs_confdir=`( + cd "$srcdir" && test -r "./$ac_unique_file" || { echo "$as_me: error: $ac_msg" >&2 + { (exit 1); exit 1; }; } + pwd)` +# When building in place, set srcdir=. +if test "$ac_abs_confdir" = "$ac_pwd"; then + srcdir=. +fi +# Remove unnecessary trailing slashes from srcdir. +# Double slashes in file names in object file debugging info +# mess up M-x gdb in Emacs. +case $srcdir in +*/) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; +esac +for ac_var in $ac_precious_vars; do + eval ac_env_${ac_var}_set=\${${ac_var}+set} + eval ac_env_${ac_var}_value=\$${ac_var} + eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} + eval ac_cv_env_${ac_var}_value=\$${ac_var} +done + +# +# Report the --help message. +# +if test "$ac_init_help" = "long"; then + # Omit some internal or obsolete options to make the list less imposing. + # This message is too long to be a string in the A/UX 3.1 sh. + cat <<_ACEOF +\`configure' configures Haskell network package 2.3.0.11 to adapt to many kinds of systems. + +Usage: $0 [OPTION]... [VAR=VALUE]... + +To assign environment variables (e.g., CC, CFLAGS...), specify them as +VAR=VALUE. See below for descriptions of some of the useful variables. + +Defaults for the options are specified in brackets. + +Configuration: + -h, --help display this help and exit + --help=short display options specific to this package + --help=recursive display the short help of all the included packages + -V, --version display version information and exit + -q, --quiet, --silent do not print \`checking...' messages + --cache-file=FILE cache test results in FILE [disabled] + -C, --config-cache alias for \`--cache-file=config.cache' + -n, --no-create do not create output files + --srcdir=DIR find the sources in DIR [configure dir or \`..'] + +Installation directories: + --prefix=PREFIX install architecture-independent files in PREFIX + [$ac_default_prefix] + --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX + [PREFIX] + +By default, \`make install' will install all the files in +\`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify +an installation prefix other than \`$ac_default_prefix' using \`--prefix', +for instance \`--prefix=\$HOME'. + +For better control, use the options below. + +Fine tuning of the installation directories: + --bindir=DIR user executables [EPREFIX/bin] + --sbindir=DIR system admin executables [EPREFIX/sbin] + --libexecdir=DIR program executables [EPREFIX/libexec] + --sysconfdir=DIR read-only single-machine data [PREFIX/etc] + --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] + --localstatedir=DIR modifiable single-machine data [PREFIX/var] + --libdir=DIR object code libraries [EPREFIX/lib] + --includedir=DIR C header files [PREFIX/include] + --oldincludedir=DIR C header files for non-gcc [/usr/include] + --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] + --datadir=DIR read-only architecture-independent data [DATAROOTDIR] + --infodir=DIR info documentation [DATAROOTDIR/info] + --localedir=DIR locale-dependent data [DATAROOTDIR/locale] + --mandir=DIR man documentation [DATAROOTDIR/man] + --docdir=DIR documentation root [DATAROOTDIR/doc/network] + --htmldir=DIR html documentation [DOCDIR] + --dvidir=DIR dvi documentation [DOCDIR] + --pdfdir=DIR pdf documentation [DOCDIR] + --psdir=DIR ps documentation [DOCDIR] +_ACEOF + + cat <<\_ACEOF + +System types: + --build=BUILD configure for building on BUILD [guessed] + --host=HOST cross-compile to build programs to run on HOST [BUILD] +_ACEOF +fi + +if test -n "$ac_init_help"; then + case $ac_init_help in + short | recursive ) echo "Configuration of Haskell network package 2.3.0.11:";; + esac + cat <<\_ACEOF + +Optional Packages: + --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] + --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) +C compiler + +Some influential environment variables: + CC C compiler command + CFLAGS C compiler flags + LDFLAGS linker flags, e.g. -L if you have libraries in a + nonstandard directory + LIBS libraries to pass to the linker, e.g. -l + CPPFLAGS C/C++/Objective C preprocessor flags, e.g. -I if + you have headers in a nonstandard directory + CPP C preprocessor + +Use these variables to override the choices made by `configure' or to help +it to find libraries and programs with nonstandard names/locations. + +Report bugs to . +_ACEOF +ac_status=$? +fi + +if test "$ac_init_help" = "recursive"; then + # If there are subdirs, report their specific --help. + for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue + test -d "$ac_dir" || continue + ac_builddir=. + +case "$ac_dir" in +.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; +*) + ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'` + # A ".." for each directory in $ac_dir_suffix. + ac_top_builddir_sub=`echo "$ac_dir_suffix" | sed 's,/[^\\/]*,/..,g;s,/,,'` + case $ac_top_builddir_sub in + "") ac_top_builddir_sub=. ac_top_build_prefix= ;; + *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; + esac ;; +esac +ac_abs_top_builddir=$ac_pwd +ac_abs_builddir=$ac_pwd$ac_dir_suffix +# for backward compatibility: +ac_top_builddir=$ac_top_build_prefix + +case $srcdir in + .) # We are building in place. + ac_srcdir=. + ac_top_srcdir=$ac_top_builddir_sub + ac_abs_top_srcdir=$ac_pwd ;; + [\\/]* | ?:[\\/]* ) # Absolute name. + ac_srcdir=$srcdir$ac_dir_suffix; + ac_top_srcdir=$srcdir + ac_abs_top_srcdir=$srcdir ;; + *) # Relative name. + ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix + ac_top_srcdir=$ac_top_build_prefix$srcdir + ac_abs_top_srcdir=$ac_pwd/$srcdir ;; +esac +ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix + + cd "$ac_dir" || { ac_status=$?; continue; } + # Check for guested configure. + if test -f "$ac_srcdir/configure.gnu"; then + echo && + $SHELL "$ac_srcdir/configure.gnu" --help=recursive + elif test -f "$ac_srcdir/configure"; then + echo && + $SHELL "$ac_srcdir/configure" --help=recursive + else + echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 + fi || ac_status=$? + cd "$ac_pwd" || { ac_status=$?; break; } + done +fi + +test -n "$ac_init_help" && exit $ac_status +if $ac_init_version; then + cat <<\_ACEOF +Haskell network package configure 2.3.0.11 +generated by GNU Autoconf 2.61 + +Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, +2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. +This configure script is free software; the Free Software Foundation +gives unlimited permission to copy, distribute and modify it. +_ACEOF + exit +fi +cat >config.log <<_ACEOF +This file contains any messages produced by compilers while +running configure, to aid debugging if configure makes a mistake. + +It was created by Haskell network package $as_me 2.3.0.11, which was +generated by GNU Autoconf 2.61. Invocation command line was + + $ $0 $@ + +_ACEOF +exec 5>>config.log +{ +cat <<_ASUNAME +## --------- ## +## Platform. ## +## --------- ## + +hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` +uname -m = `(uname -m) 2>/dev/null || echo unknown` +uname -r = `(uname -r) 2>/dev/null || echo unknown` +uname -s = `(uname -s) 2>/dev/null || echo unknown` +uname -v = `(uname -v) 2>/dev/null || echo unknown` + +/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` +/bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` + +/bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` +/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` +/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` +/usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` +/bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` +/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` +/bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` + +_ASUNAME + +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + echo "PATH: $as_dir" +done +IFS=$as_save_IFS + +} >&5 + +cat >&5 <<_ACEOF + + +## ----------- ## +## Core tests. ## +## ----------- ## + +_ACEOF + + +# Keep a trace of the command line. +# Strip out --no-create and --no-recursion so they do not pile up. +# Strip out --silent because we don't want to record it for future runs. +# Also quote any args containing shell meta-characters. +# Make two passes to allow for proper duplicate-argument suppression. +ac_configure_args= +ac_configure_args0= +ac_configure_args1= +ac_must_keep_next=false +for ac_pass in 1 2 +do + for ac_arg + do + case $ac_arg in + -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil) + continue ;; + *\'*) + ac_arg=`echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; + esac + case $ac_pass in + 1) ac_configure_args0="$ac_configure_args0 '$ac_arg'" ;; + 2) + ac_configure_args1="$ac_configure_args1 '$ac_arg'" + if test $ac_must_keep_next = true; then + ac_must_keep_next=false # Got value, back to normal. + else + case $ac_arg in + *=* | --config-cache | -C | -disable-* | --disable-* \ + | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ + | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ + | -with-* | --with-* | -without-* | --without-* | --x) + case "$ac_configure_args0 " in + "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; + esac + ;; + -* ) ac_must_keep_next=true ;; + esac + fi + ac_configure_args="$ac_configure_args '$ac_arg'" + ;; + esac + done +done +$as_unset ac_configure_args0 || test "${ac_configure_args0+set}" != set || { ac_configure_args0=; export ac_configure_args0; } +$as_unset ac_configure_args1 || test "${ac_configure_args1+set}" != set || { ac_configure_args1=; export ac_configure_args1; } + +# When interrupted or exit'd, cleanup temporary files, and complete +# config.log. We remove comments because anyway the quotes in there +# would cause problems or look ugly. +# WARNING: Use '\'' to represent an apostrophe within the trap. +# WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. +trap 'exit_status=$? + # Save into config.log some information that might help in debugging. + { + echo + + cat <<\_ASBOX +## ---------------- ## +## Cache variables. ## +## ---------------- ## +_ASBOX + echo + # The following way of writing the cache mishandles newlines in values, +( + for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do + eval ac_val=\$$ac_var + case $ac_val in #( + *${as_nl}*) + case $ac_var in #( + *_cv_*) { echo "$as_me:$LINENO: WARNING: Cache variable $ac_var contains a newline." >&5 +echo "$as_me: WARNING: Cache variable $ac_var contains a newline." >&2;} ;; + esac + case $ac_var in #( + _ | IFS | as_nl) ;; #( + *) $as_unset $ac_var ;; + esac ;; + esac + done + (set) 2>&1 | + case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( + *${as_nl}ac_space=\ *) + sed -n \ + "s/'\''/'\''\\\\'\'''\''/g; + s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" + ;; #( + *) + sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" + ;; + esac | + sort +) + echo + + cat <<\_ASBOX +## ----------------- ## +## Output variables. ## +## ----------------- ## +_ASBOX + echo + for ac_var in $ac_subst_vars + do + eval ac_val=\$$ac_var + case $ac_val in + *\'\''*) ac_val=`echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; + esac + echo "$ac_var='\''$ac_val'\''" + done | sort + echo + + if test -n "$ac_subst_files"; then + cat <<\_ASBOX +## ------------------- ## +## File substitutions. ## +## ------------------- ## +_ASBOX + echo + for ac_var in $ac_subst_files + do + eval ac_val=\$$ac_var + case $ac_val in + *\'\''*) ac_val=`echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; + esac + echo "$ac_var='\''$ac_val'\''" + done | sort + echo + fi + + if test -s confdefs.h; then + cat <<\_ASBOX +## ----------- ## +## confdefs.h. ## +## ----------- ## +_ASBOX + echo + cat confdefs.h + echo + fi + test "$ac_signal" != 0 && + echo "$as_me: caught signal $ac_signal" + echo "$as_me: exit $exit_status" + } >&5 + rm -f core *.core core.conftest.* && + rm -f -r conftest* confdefs* conf$$* $ac_clean_files && + exit $exit_status +' 0 +for ac_signal in 1 2 13 15; do + trap 'ac_signal='$ac_signal'; { (exit 1); exit 1; }' $ac_signal +done +ac_signal=0 + +# confdefs.h avoids OS command line length limits that DEFS can exceed. +rm -f -r conftest* confdefs.h + +# Predefined preprocessor variables. + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_NAME "$PACKAGE_NAME" +_ACEOF + + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_TARNAME "$PACKAGE_TARNAME" +_ACEOF + + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_VERSION "$PACKAGE_VERSION" +_ACEOF + + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_STRING "$PACKAGE_STRING" +_ACEOF + + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" +_ACEOF + + +# Let the site file select an alternate cache file if it wants to. +# Prefer explicitly selected file to automatically selected ones. +if test -n "$CONFIG_SITE"; then + set x "$CONFIG_SITE" +elif test "x$prefix" != xNONE; then + set x "$prefix/share/config.site" "$prefix/etc/config.site" +else + set x "$ac_default_prefix/share/config.site" \ + "$ac_default_prefix/etc/config.site" +fi +shift +for ac_site_file +do + if test -r "$ac_site_file"; then + { echo "$as_me:$LINENO: loading site script $ac_site_file" >&5 +echo "$as_me: loading site script $ac_site_file" >&6;} + sed 's/^/| /' "$ac_site_file" >&5 + . "$ac_site_file" + fi +done + +if test -r "$cache_file"; then + # Some versions of bash will fail to source /dev/null (special + # files actually), so we avoid doing that. + if test -f "$cache_file"; then + { echo "$as_me:$LINENO: loading cache $cache_file" >&5 +echo "$as_me: loading cache $cache_file" >&6;} + case $cache_file in + [\\/]* | ?:[\\/]* ) . "$cache_file";; + *) . "./$cache_file";; + esac + fi +else + { echo "$as_me:$LINENO: creating cache $cache_file" >&5 +echo "$as_me: creating cache $cache_file" >&6;} + >$cache_file +fi + +# Check that the precious variables saved in the cache have kept the same +# value. +ac_cache_corrupted=false +for ac_var in $ac_precious_vars; do + eval ac_old_set=\$ac_cv_env_${ac_var}_set + eval ac_new_set=\$ac_env_${ac_var}_set + eval ac_old_val=\$ac_cv_env_${ac_var}_value + eval ac_new_val=\$ac_env_${ac_var}_value + case $ac_old_set,$ac_new_set in + set,) + { echo "$as_me:$LINENO: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 +echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} + ac_cache_corrupted=: ;; + ,set) + { echo "$as_me:$LINENO: error: \`$ac_var' was not set in the previous run" >&5 +echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} + ac_cache_corrupted=: ;; + ,);; + *) + if test "x$ac_old_val" != "x$ac_new_val"; then + { echo "$as_me:$LINENO: error: \`$ac_var' has changed since the previous run:" >&5 +echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} + { echo "$as_me:$LINENO: former value: $ac_old_val" >&5 +echo "$as_me: former value: $ac_old_val" >&2;} + { echo "$as_me:$LINENO: current value: $ac_new_val" >&5 +echo "$as_me: current value: $ac_new_val" >&2;} + ac_cache_corrupted=: + fi;; + esac + # Pass precious variables to config.status. + if test "$ac_new_set" = set; then + case $ac_new_val in + *\'*) ac_arg=$ac_var=`echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; + *) ac_arg=$ac_var=$ac_new_val ;; + esac + case " $ac_configure_args " in + *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. + *) ac_configure_args="$ac_configure_args '$ac_arg'" ;; + esac + fi +done +if $ac_cache_corrupted; then + { echo "$as_me:$LINENO: error: changes in the environment can compromise the build" >&5 +echo "$as_me: error: changes in the environment can compromise the build" >&2;} + { { echo "$as_me:$LINENO: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&5 +echo "$as_me: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&2;} + { (exit 1); exit 1; }; } +fi + + + + + + + + + + + + + + + + + + + + + + + + + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + + +ac_includes_default="$ac_includes_default +#ifdef HAVE_NETDB_H +# include +#endif +#ifdef HAVE_WINSOCK2_H +# include +#endif +#ifdef HAVE_WS2TCPIP_H +# include +// fix for MingW not defining IPV6_V6ONLY +# define IPV6_V6ONLY 27 +#endif +#ifdef HAVE_WSPIAPI_H +# include +#endif" + +# Safety check: Ensure that we are in the correct source directory. + + +ac_config_headers="$ac_config_headers include/HsNetworkConfig.h" + + +ac_aux_dir= +for ac_dir in "$srcdir" "$srcdir/.." "$srcdir/../.."; do + if test -f "$ac_dir/install-sh"; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/install-sh -c" + break + elif test -f "$ac_dir/install.sh"; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/install.sh -c" + break + elif test -f "$ac_dir/shtool"; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/shtool install -c" + break + fi +done +if test -z "$ac_aux_dir"; then + { { echo "$as_me:$LINENO: error: cannot find install-sh or install.sh in \"$srcdir\" \"$srcdir/..\" \"$srcdir/../..\"" >&5 +echo "$as_me: error: cannot find install-sh or install.sh in \"$srcdir\" \"$srcdir/..\" \"$srcdir/../..\"" >&2;} + { (exit 1); exit 1; }; } +fi + +# These three variables are undocumented and unsupported, +# and are intended to be withdrawn in a future Autoconf release. +# They can cause serious problems if a builder's source tree is in a directory +# whose full name contains unusual characters. +ac_config_guess="$SHELL $ac_aux_dir/config.guess" # Please don't use this var. +ac_config_sub="$SHELL $ac_aux_dir/config.sub" # Please don't use this var. +ac_configure="$SHELL $ac_aux_dir/configure" # Please don't use this var. + + +# Make sure we can run config.sub. +$SHELL "$ac_aux_dir/config.sub" sun4 >/dev/null 2>&1 || + { { echo "$as_me:$LINENO: error: cannot run $SHELL $ac_aux_dir/config.sub" >&5 +echo "$as_me: error: cannot run $SHELL $ac_aux_dir/config.sub" >&2;} + { (exit 1); exit 1; }; } + +{ echo "$as_me:$LINENO: checking build system type" >&5 +echo $ECHO_N "checking build system type... $ECHO_C" >&6; } +if test "${ac_cv_build+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + ac_build_alias=$build_alias +test "x$ac_build_alias" = x && + ac_build_alias=`$SHELL "$ac_aux_dir/config.guess"` +test "x$ac_build_alias" = x && + { { echo "$as_me:$LINENO: error: cannot guess build type; you must specify one" >&5 +echo "$as_me: error: cannot guess build type; you must specify one" >&2;} + { (exit 1); exit 1; }; } +ac_cv_build=`$SHELL "$ac_aux_dir/config.sub" $ac_build_alias` || + { { echo "$as_me:$LINENO: error: $SHELL $ac_aux_dir/config.sub $ac_build_alias failed" >&5 +echo "$as_me: error: $SHELL $ac_aux_dir/config.sub $ac_build_alias failed" >&2;} + { (exit 1); exit 1; }; } + +fi +{ echo "$as_me:$LINENO: result: $ac_cv_build" >&5 +echo "${ECHO_T}$ac_cv_build" >&6; } +case $ac_cv_build in +*-*-*) ;; +*) { { echo "$as_me:$LINENO: error: invalid value of canonical build" >&5 +echo "$as_me: error: invalid value of canonical build" >&2;} + { (exit 1); exit 1; }; };; +esac +build=$ac_cv_build +ac_save_IFS=$IFS; IFS='-' +set x $ac_cv_build +shift +build_cpu=$1 +build_vendor=$2 +shift; shift +# Remember, the first character of IFS is used to create $*, +# except with old shells: +build_os=$* +IFS=$ac_save_IFS +case $build_os in *\ *) build_os=`echo "$build_os" | sed 's/ /-/g'`;; esac + + +{ echo "$as_me:$LINENO: checking host system type" >&5 +echo $ECHO_N "checking host system type... $ECHO_C" >&6; } +if test "${ac_cv_host+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + if test "x$host_alias" = x; then + ac_cv_host=$ac_cv_build +else + ac_cv_host=`$SHELL "$ac_aux_dir/config.sub" $host_alias` || + { { echo "$as_me:$LINENO: error: $SHELL $ac_aux_dir/config.sub $host_alias failed" >&5 +echo "$as_me: error: $SHELL $ac_aux_dir/config.sub $host_alias failed" >&2;} + { (exit 1); exit 1; }; } +fi + +fi +{ echo "$as_me:$LINENO: result: $ac_cv_host" >&5 +echo "${ECHO_T}$ac_cv_host" >&6; } +case $ac_cv_host in +*-*-*) ;; +*) { { echo "$as_me:$LINENO: error: invalid value of canonical host" >&5 +echo "$as_me: error: invalid value of canonical host" >&2;} + { (exit 1); exit 1; }; };; +esac +host=$ac_cv_host +ac_save_IFS=$IFS; IFS='-' +set x $ac_cv_host +shift +host_cpu=$1 +host_vendor=$2 +shift; shift +# Remember, the first character of IFS is used to create $*, +# except with old shells: +host_os=$* +IFS=$ac_save_IFS +case $host_os in *\ *) host_os=`echo "$host_os" | sed 's/ /-/g'`;; esac + + + + +# Check whether --with-cc was given. +if test "${with_cc+set}" = set; then + withval=$with_cc; CC=$withval +fi + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu +if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args. +set dummy ${ac_tool_prefix}gcc; ac_word=$2 +{ echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6; } +if test "${ac_cv_prog_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + ac_cv_prog_CC="${ac_tool_prefix}gcc" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done +done +IFS=$as_save_IFS + +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + { echo "$as_me:$LINENO: result: $CC" >&5 +echo "${ECHO_T}$CC" >&6; } +else + { echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6; } +fi + + +fi +if test -z "$ac_cv_prog_CC"; then + ac_ct_CC=$CC + # Extract the first word of "gcc", so it can be a program name with args. +set dummy gcc; ac_word=$2 +{ echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6; } +if test "${ac_cv_prog_ac_ct_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + if test -n "$ac_ct_CC"; then + ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + ac_cv_prog_ac_ct_CC="gcc" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done +done +IFS=$as_save_IFS + +fi +fi +ac_ct_CC=$ac_cv_prog_ac_ct_CC +if test -n "$ac_ct_CC"; then + { echo "$as_me:$LINENO: result: $ac_ct_CC" >&5 +echo "${ECHO_T}$ac_ct_CC" >&6; } +else + { echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6; } +fi + + if test "x$ac_ct_CC" = x; then + CC="" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ echo "$as_me:$LINENO: WARNING: In the future, Autoconf will not detect cross-tools +whose name does not start with the host triplet. If you think this +configuration is useful to you, please write to autoconf@gnu.org." >&5 +echo "$as_me: WARNING: In the future, Autoconf will not detect cross-tools +whose name does not start with the host triplet. If you think this +configuration is useful to you, please write to autoconf@gnu.org." >&2;} +ac_tool_warned=yes ;; +esac + CC=$ac_ct_CC + fi +else + CC="$ac_cv_prog_CC" +fi + +if test -z "$CC"; then + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args. +set dummy ${ac_tool_prefix}cc; ac_word=$2 +{ echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6; } +if test "${ac_cv_prog_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + ac_cv_prog_CC="${ac_tool_prefix}cc" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done +done +IFS=$as_save_IFS + +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + { echo "$as_me:$LINENO: result: $CC" >&5 +echo "${ECHO_T}$CC" >&6; } +else + { echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6; } +fi + + + fi +fi +if test -z "$CC"; then + # Extract the first word of "cc", so it can be a program name with args. +set dummy cc; ac_word=$2 +{ echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6; } +if test "${ac_cv_prog_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else + ac_prog_rejected=no +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + if test "$as_dir/$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then + ac_prog_rejected=yes + continue + fi + ac_cv_prog_CC="cc" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done +done +IFS=$as_save_IFS + +if test $ac_prog_rejected = yes; then + # We found a bogon in the path, so make sure we never use it. + set dummy $ac_cv_prog_CC + shift + if test $# != 0; then + # We chose a different compiler from the bogus one. + # However, it has the same basename, so the bogon will be chosen + # first if we set CC to just the basename; use the full file name. + shift + ac_cv_prog_CC="$as_dir/$ac_word${1+' '}$@" + fi +fi +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + { echo "$as_me:$LINENO: result: $CC" >&5 +echo "${ECHO_T}$CC" >&6; } +else + { echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6; } +fi + + +fi +if test -z "$CC"; then + if test -n "$ac_tool_prefix"; then + for ac_prog in cl.exe + do + # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. +set dummy $ac_tool_prefix$ac_prog; ac_word=$2 +{ echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6; } +if test "${ac_cv_prog_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + ac_cv_prog_CC="$ac_tool_prefix$ac_prog" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done +done +IFS=$as_save_IFS + +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + { echo "$as_me:$LINENO: result: $CC" >&5 +echo "${ECHO_T}$CC" >&6; } +else + { echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6; } +fi + + + test -n "$CC" && break + done +fi +if test -z "$CC"; then + ac_ct_CC=$CC + for ac_prog in cl.exe +do + # Extract the first word of "$ac_prog", so it can be a program name with args. +set dummy $ac_prog; ac_word=$2 +{ echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6; } +if test "${ac_cv_prog_ac_ct_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + if test -n "$ac_ct_CC"; then + ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + ac_cv_prog_ac_ct_CC="$ac_prog" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done +done +IFS=$as_save_IFS + +fi +fi +ac_ct_CC=$ac_cv_prog_ac_ct_CC +if test -n "$ac_ct_CC"; then + { echo "$as_me:$LINENO: result: $ac_ct_CC" >&5 +echo "${ECHO_T}$ac_ct_CC" >&6; } +else + { echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6; } +fi + + + test -n "$ac_ct_CC" && break +done + + if test "x$ac_ct_CC" = x; then + CC="" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ echo "$as_me:$LINENO: WARNING: In the future, Autoconf will not detect cross-tools +whose name does not start with the host triplet. If you think this +configuration is useful to you, please write to autoconf@gnu.org." >&5 +echo "$as_me: WARNING: In the future, Autoconf will not detect cross-tools +whose name does not start with the host triplet. If you think this +configuration is useful to you, please write to autoconf@gnu.org." >&2;} +ac_tool_warned=yes ;; +esac + CC=$ac_ct_CC + fi +fi + +fi + + +test -z "$CC" && { { echo "$as_me:$LINENO: error: no acceptable C compiler found in \$PATH +See \`config.log' for more details." >&5 +echo "$as_me: error: no acceptable C compiler found in \$PATH +See \`config.log' for more details." >&2;} + { (exit 1); exit 1; }; } + +# Provide some information about the compiler. +echo "$as_me:$LINENO: checking for C compiler version" >&5 +ac_compiler=`set X $ac_compile; echo $2` +{ (ac_try="$ac_compiler --version >&5" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_compiler --version >&5") 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } +{ (ac_try="$ac_compiler -v >&5" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_compiler -v >&5") 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } +{ (ac_try="$ac_compiler -V >&5" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_compiler -V >&5") 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } + +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +ac_clean_files_save=$ac_clean_files +ac_clean_files="$ac_clean_files a.out a.exe b.out" +# Try to create an executable without -o first, disregard a.out. +# It will help us diagnose broken compilers, and finding out an intuition +# of exeext. +{ echo "$as_me:$LINENO: checking for C compiler default output file name" >&5 +echo $ECHO_N "checking for C compiler default output file name... $ECHO_C" >&6; } +ac_link_default=`echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'` +# +# List of possible output files, starting from the most likely. +# The algorithm is not robust to junk in `.', hence go to wildcards (a.*) +# only as a last resort. b.out is created by i960 compilers. +ac_files='a_out.exe a.exe conftest.exe a.out conftest a.* conftest.* b.out' +# +# The IRIX 6 linker writes into existing files which may not be +# executable, retaining their permissions. Remove them first so a +# subsequent execution test works. +ac_rmfiles= +for ac_file in $ac_files +do + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.o | *.obj ) ;; + * ) ac_rmfiles="$ac_rmfiles $ac_file";; + esac +done +rm -f $ac_rmfiles + +if { (ac_try="$ac_link_default" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_link_default") 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; then + # Autoconf-2.13 could set the ac_cv_exeext variable to `no'. +# So ignore a value of `no', otherwise this would lead to `EXEEXT = no' +# in a Makefile. We should not override ac_cv_exeext if it was cached, +# so that the user can short-circuit this test for compilers unknown to +# Autoconf. +for ac_file in $ac_files '' +do + test -f "$ac_file" || continue + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.o | *.obj ) + ;; + [ab].out ) + # We found the default executable, but exeext='' is most + # certainly right. + break;; + *.* ) + if test "${ac_cv_exeext+set}" = set && test "$ac_cv_exeext" != no; + then :; else + ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` + fi + # We set ac_cv_exeext here because the later test for it is not + # safe: cross compilers may not add the suffix if given an `-o' + # argument, so we may need to know it at that point already. + # Even if this section looks crufty: it has the advantage of + # actually working. + break;; + * ) + break;; + esac +done +test "$ac_cv_exeext" = no && ac_cv_exeext= + +else + ac_file='' +fi + +{ echo "$as_me:$LINENO: result: $ac_file" >&5 +echo "${ECHO_T}$ac_file" >&6; } +if test -z "$ac_file"; then + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +{ { echo "$as_me:$LINENO: error: C compiler cannot create executables +See \`config.log' for more details." >&5 +echo "$as_me: error: C compiler cannot create executables +See \`config.log' for more details." >&2;} + { (exit 77); exit 77; }; } +fi + +ac_exeext=$ac_cv_exeext + +# Check that the compiler produces executables we can run. If not, either +# the compiler is broken, or we cross compile. +{ echo "$as_me:$LINENO: checking whether the C compiler works" >&5 +echo $ECHO_N "checking whether the C compiler works... $ECHO_C" >&6; } +# FIXME: These cross compiler hacks should be removed for Autoconf 3.0 +# If not cross compiling, check that we can run a simple program. +if test "$cross_compiling" != yes; then + if { ac_try='./$ac_file' + { (case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_try") 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + cross_compiling=no + else + if test "$cross_compiling" = maybe; then + cross_compiling=yes + else + { { echo "$as_me:$LINENO: error: cannot run C compiled programs. +If you meant to cross compile, use \`--host'. +See \`config.log' for more details." >&5 +echo "$as_me: error: cannot run C compiled programs. +If you meant to cross compile, use \`--host'. +See \`config.log' for more details." >&2;} + { (exit 1); exit 1; }; } + fi + fi +fi +{ echo "$as_me:$LINENO: result: yes" >&5 +echo "${ECHO_T}yes" >&6; } + +rm -f a.out a.exe conftest$ac_cv_exeext b.out +ac_clean_files=$ac_clean_files_save +# Check that the compiler produces executables we can run. If not, either +# the compiler is broken, or we cross compile. +{ echo "$as_me:$LINENO: checking whether we are cross compiling" >&5 +echo $ECHO_N "checking whether we are cross compiling... $ECHO_C" >&6; } +{ echo "$as_me:$LINENO: result: $cross_compiling" >&5 +echo "${ECHO_T}$cross_compiling" >&6; } + +{ echo "$as_me:$LINENO: checking for suffix of executables" >&5 +echo $ECHO_N "checking for suffix of executables... $ECHO_C" >&6; } +if { (ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_link") 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; then + # If both `conftest.exe' and `conftest' are `present' (well, observable) +# catch `conftest.exe'. For instance with Cygwin, `ls conftest' will +# work properly (i.e., refer to `conftest.exe'), while it won't with +# `rm'. +for ac_file in conftest.exe conftest conftest.*; do + test -f "$ac_file" || continue + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.o | *.obj ) ;; + *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` + break;; + * ) break;; + esac +done +else + { { echo "$as_me:$LINENO: error: cannot compute suffix of executables: cannot compile and link +See \`config.log' for more details." >&5 +echo "$as_me: error: cannot compute suffix of executables: cannot compile and link +See \`config.log' for more details." >&2;} + { (exit 1); exit 1; }; } +fi + +rm -f conftest$ac_cv_exeext +{ echo "$as_me:$LINENO: result: $ac_cv_exeext" >&5 +echo "${ECHO_T}$ac_cv_exeext" >&6; } + +rm -f conftest.$ac_ext +EXEEXT=$ac_cv_exeext +ac_exeext=$EXEEXT +{ echo "$as_me:$LINENO: checking for suffix of object files" >&5 +echo $ECHO_N "checking for suffix of object files... $ECHO_C" >&6; } +if test "${ac_cv_objext+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +rm -f conftest.o conftest.obj +if { (ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_compile") 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; then + for ac_file in conftest.o conftest.obj conftest.*; do + test -f "$ac_file" || continue; + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf ) ;; + *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'` + break;; + esac +done +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +{ { echo "$as_me:$LINENO: error: cannot compute suffix of object files: cannot compile +See \`config.log' for more details." >&5 +echo "$as_me: error: cannot compute suffix of object files: cannot compile +See \`config.log' for more details." >&2;} + { (exit 1); exit 1; }; } +fi + +rm -f conftest.$ac_cv_objext conftest.$ac_ext +fi +{ echo "$as_me:$LINENO: result: $ac_cv_objext" >&5 +echo "${ECHO_T}$ac_cv_objext" >&6; } +OBJEXT=$ac_cv_objext +ac_objext=$OBJEXT +{ echo "$as_me:$LINENO: checking whether we are using the GNU C compiler" >&5 +echo $ECHO_N "checking whether we are using the GNU C compiler... $ECHO_C" >&6; } +if test "${ac_cv_c_compiler_gnu+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +int +main () +{ +#ifndef __GNUC__ + choke me +#endif + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_compile") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest.$ac_objext; then + ac_compiler_gnu=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_compiler_gnu=no +fi + +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +ac_cv_c_compiler_gnu=$ac_compiler_gnu + +fi +{ echo "$as_me:$LINENO: result: $ac_cv_c_compiler_gnu" >&5 +echo "${ECHO_T}$ac_cv_c_compiler_gnu" >&6; } +GCC=`test $ac_compiler_gnu = yes && echo yes` +ac_test_CFLAGS=${CFLAGS+set} +ac_save_CFLAGS=$CFLAGS +{ echo "$as_me:$LINENO: checking whether $CC accepts -g" >&5 +echo $ECHO_N "checking whether $CC accepts -g... $ECHO_C" >&6; } +if test "${ac_cv_prog_cc_g+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + ac_save_c_werror_flag=$ac_c_werror_flag + ac_c_werror_flag=yes + ac_cv_prog_cc_g=no + CFLAGS="-g" + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_compile") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest.$ac_objext; then + ac_cv_prog_cc_g=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + CFLAGS="" + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_compile") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest.$ac_objext; then + : +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_c_werror_flag=$ac_save_c_werror_flag + CFLAGS="-g" + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_compile") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest.$ac_objext; then + ac_cv_prog_cc_g=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + +fi + +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi + +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi + +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + ac_c_werror_flag=$ac_save_c_werror_flag +fi +{ echo "$as_me:$LINENO: result: $ac_cv_prog_cc_g" >&5 +echo "${ECHO_T}$ac_cv_prog_cc_g" >&6; } +if test "$ac_test_CFLAGS" = set; then + CFLAGS=$ac_save_CFLAGS +elif test $ac_cv_prog_cc_g = yes; then + if test "$GCC" = yes; then + CFLAGS="-g -O2" + else + CFLAGS="-g" + fi +else + if test "$GCC" = yes; then + CFLAGS="-O2" + else + CFLAGS= + fi +fi +{ echo "$as_me:$LINENO: checking for $CC option to accept ISO C89" >&5 +echo $ECHO_N "checking for $CC option to accept ISO C89... $ECHO_C" >&6; } +if test "${ac_cv_prog_cc_c89+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + ac_cv_prog_cc_c89=no +ac_save_CC=$CC +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include +#include +#include +#include +/* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */ +struct buf { int x; }; +FILE * (*rcsopen) (struct buf *, struct stat *, int); +static char *e (p, i) + char **p; + int i; +{ + return p[i]; +} +static char *f (char * (*g) (char **, int), char **p, ...) +{ + char *s; + va_list v; + va_start (v,p); + s = g (p, va_arg (v,int)); + va_end (v); + return s; +} + +/* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has + function prototypes and stuff, but not '\xHH' hex character constants. + These don't provoke an error unfortunately, instead are silently treated + as 'x'. The following induces an error, until -std is added to get + proper ANSI mode. Curiously '\x00'!='x' always comes out true, for an + array size at least. It's necessary to write '\x00'==0 to get something + that's true only with -std. */ +int osf4_cc_array ['\x00' == 0 ? 1 : -1]; + +/* IBM C 6 for AIX is almost-ANSI by default, but it replaces macro parameters + inside strings and character constants. */ +#define FOO(x) 'x' +int xlc6_cc_array[FOO(a) == 'x' ? 1 : -1]; + +int test (int i, double x); +struct s1 {int (*f) (int a);}; +struct s2 {int (*f) (double a);}; +int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int); +int argc; +char **argv; +int +main () +{ +return f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]; + ; + return 0; +} +_ACEOF +for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std \ + -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" +do + CC="$ac_save_CC $ac_arg" + rm -f conftest.$ac_objext +if { (ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_compile") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest.$ac_objext; then + ac_cv_prog_cc_c89=$ac_arg +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + +fi + +rm -f core conftest.err conftest.$ac_objext + test "x$ac_cv_prog_cc_c89" != "xno" && break +done +rm -f conftest.$ac_ext +CC=$ac_save_CC + +fi +# AC_CACHE_VAL +case "x$ac_cv_prog_cc_c89" in + x) + { echo "$as_me:$LINENO: result: none needed" >&5 +echo "${ECHO_T}none needed" >&6; } ;; + xno) + { echo "$as_me:$LINENO: result: unsupported" >&5 +echo "${ECHO_T}unsupported" >&6; } ;; + *) + CC="$CC $ac_cv_prog_cc_c89" + { echo "$as_me:$LINENO: result: $ac_cv_prog_cc_c89" >&5 +echo "${ECHO_T}$ac_cv_prog_cc_c89" >&6; } ;; +esac + + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + + +{ echo "$as_me:$LINENO: checking for an ANSI C-conforming const" >&5 +echo $ECHO_N "checking for an ANSI C-conforming const... $ECHO_C" >&6; } +if test "${ac_cv_c_const+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +int +main () +{ +/* FIXME: Include the comments suggested by Paul. */ +#ifndef __cplusplus + /* Ultrix mips cc rejects this. */ + typedef int charset[2]; + const charset cs; + /* SunOS 4.1.1 cc rejects this. */ + char const *const *pcpcc; + char **ppc; + /* NEC SVR4.0.2 mips cc rejects this. */ + struct point {int x, y;}; + static struct point const zero = {0,0}; + /* AIX XL C 1.02.0.0 rejects this. + It does not let you subtract one const X* pointer from another in + an arm of an if-expression whose if-part is not a constant + expression */ + const char *g = "string"; + pcpcc = &g + (g ? g-g : 0); + /* HPUX 7.0 cc rejects these. */ + ++pcpcc; + ppc = (char**) pcpcc; + pcpcc = (char const *const *) ppc; + { /* SCO 3.2v4 cc rejects this. */ + char *t; + char const *s = 0 ? (char *) 0 : (char const *) 0; + + *t++ = 0; + if (s) return 0; + } + { /* Someone thinks the Sun supposedly-ANSI compiler will reject this. */ + int x[] = {25, 17}; + const int *foo = &x[0]; + ++foo; + } + { /* Sun SC1.0 ANSI compiler rejects this -- but not the above. */ + typedef const int *iptr; + iptr p = 0; + ++p; + } + { /* AIX XL C 1.02.0.0 rejects this saying + "k.c", line 2.27: 1506-025 (S) Operand must be a modifiable lvalue. */ + struct s { int j; const int *ap[3]; }; + struct s *b; b->j = 5; + } + { /* ULTRIX-32 V3.1 (Rev 9) vcc rejects this */ + const int foo = 10; + if (!foo) return 0; + } + return !cs[0] && !zero.x; +#endif + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_compile") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest.$ac_objext; then + ac_cv_c_const=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_cv_c_const=no +fi + +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +{ echo "$as_me:$LINENO: result: $ac_cv_c_const" >&5 +echo "${ECHO_T}$ac_cv_c_const" >&6; } +if test $ac_cv_c_const = no; then + +cat >>confdefs.h <<\_ACEOF +#define const +_ACEOF + +fi + + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu +{ echo "$as_me:$LINENO: checking how to run the C preprocessor" >&5 +echo $ECHO_N "checking how to run the C preprocessor... $ECHO_C" >&6; } +# On Suns, sometimes $CPP names a directory. +if test -n "$CPP" && test -d "$CPP"; then + CPP= +fi +if test -z "$CPP"; then + if test "${ac_cv_prog_CPP+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + # Double quotes because CPP needs to be expanded + for CPP in "$CC -E" "$CC -E -traditional-cpp" "/lib/cpp" + do + ac_preproc_ok=false +for ac_c_preproc_warn_flag in '' yes +do + # Use a header file that comes with gcc, so configuring glibc + # with a fresh cross-compiler works. + # Prefer to if __STDC__ is defined, since + # exists even on freestanding compilers. + # On the NeXT, cc -E runs the code through the compiler's parser, + # not just through cpp. "Syntax error" is here to catch this case. + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#ifdef __STDC__ +# include +#else +# include +#endif + Syntax error +_ACEOF +if { (ac_try="$ac_cpp conftest.$ac_ext" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } >/dev/null && { + test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || + test ! -s conftest.err + }; then + : +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + # Broken: fails on valid input. +continue +fi + +rm -f conftest.err conftest.$ac_ext + + # OK, works on sane cases. Now check whether nonexistent headers + # can be detected and how. + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include +_ACEOF +if { (ac_try="$ac_cpp conftest.$ac_ext" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } >/dev/null && { + test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || + test ! -s conftest.err + }; then + # Broken: success on invalid input. +continue +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + # Passes both tests. +ac_preproc_ok=: +break +fi + +rm -f conftest.err conftest.$ac_ext + +done +# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. +rm -f conftest.err conftest.$ac_ext +if $ac_preproc_ok; then + break +fi + + done + ac_cv_prog_CPP=$CPP + +fi + CPP=$ac_cv_prog_CPP +else + ac_cv_prog_CPP=$CPP +fi +{ echo "$as_me:$LINENO: result: $CPP" >&5 +echo "${ECHO_T}$CPP" >&6; } +ac_preproc_ok=false +for ac_c_preproc_warn_flag in '' yes +do + # Use a header file that comes with gcc, so configuring glibc + # with a fresh cross-compiler works. + # Prefer to if __STDC__ is defined, since + # exists even on freestanding compilers. + # On the NeXT, cc -E runs the code through the compiler's parser, + # not just through cpp. "Syntax error" is here to catch this case. + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#ifdef __STDC__ +# include +#else +# include +#endif + Syntax error +_ACEOF +if { (ac_try="$ac_cpp conftest.$ac_ext" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } >/dev/null && { + test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || + test ! -s conftest.err + }; then + : +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + # Broken: fails on valid input. +continue +fi + +rm -f conftest.err conftest.$ac_ext + + # OK, works on sane cases. Now check whether nonexistent headers + # can be detected and how. + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include +_ACEOF +if { (ac_try="$ac_cpp conftest.$ac_ext" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } >/dev/null && { + test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || + test ! -s conftest.err + }; then + # Broken: success on invalid input. +continue +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + # Passes both tests. +ac_preproc_ok=: +break +fi + +rm -f conftest.err conftest.$ac_ext + +done +# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. +rm -f conftest.err conftest.$ac_ext +if $ac_preproc_ok; then + : +else + { { echo "$as_me:$LINENO: error: C preprocessor \"$CPP\" fails sanity check +See \`config.log' for more details." >&5 +echo "$as_me: error: C preprocessor \"$CPP\" fails sanity check +See \`config.log' for more details." >&2;} + { (exit 1); exit 1; }; } +fi + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + +{ echo "$as_me:$LINENO: checking for grep that handles long lines and -e" >&5 +echo $ECHO_N "checking for grep that handles long lines and -e... $ECHO_C" >&6; } +if test "${ac_cv_path_GREP+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + # Extract the first word of "grep ggrep" to use in msg output +if test -z "$GREP"; then +set dummy grep ggrep; ac_prog_name=$2 +if test "${ac_cv_path_GREP+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + ac_path_GREP_found=false +# Loop through the user's path and test for each of PROGNAME-LIST +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_prog in grep ggrep; do + for ac_exec_ext in '' $ac_executable_extensions; do + ac_path_GREP="$as_dir/$ac_prog$ac_exec_ext" + { test -f "$ac_path_GREP" && $as_test_x "$ac_path_GREP"; } || continue + # Check for GNU ac_path_GREP and select it if it is found. + # Check for GNU $ac_path_GREP +case `"$ac_path_GREP" --version 2>&1` in +*GNU*) + ac_cv_path_GREP="$ac_path_GREP" ac_path_GREP_found=:;; +*) + ac_count=0 + echo $ECHO_N "0123456789$ECHO_C" >"conftest.in" + while : + do + cat "conftest.in" "conftest.in" >"conftest.tmp" + mv "conftest.tmp" "conftest.in" + cp "conftest.in" "conftest.nl" + echo 'GREP' >> "conftest.nl" + "$ac_path_GREP" -e 'GREP$' -e '-(cannot match)-' < "conftest.nl" >"conftest.out" 2>/dev/null || break + diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break + ac_count=`expr $ac_count + 1` + if test $ac_count -gt ${ac_path_GREP_max-0}; then + # Best one so far, save it but keep looking for a better one + ac_cv_path_GREP="$ac_path_GREP" + ac_path_GREP_max=$ac_count + fi + # 10*(2^10) chars as input seems more than enough + test $ac_count -gt 10 && break + done + rm -f conftest.in conftest.tmp conftest.nl conftest.out;; +esac + + + $ac_path_GREP_found && break 3 + done +done + +done +IFS=$as_save_IFS + + +fi + +GREP="$ac_cv_path_GREP" +if test -z "$GREP"; then + { { echo "$as_me:$LINENO: error: no acceptable $ac_prog_name could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" >&5 +echo "$as_me: error: no acceptable $ac_prog_name could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" >&2;} + { (exit 1); exit 1; }; } +fi + +else + ac_cv_path_GREP=$GREP +fi + + +fi +{ echo "$as_me:$LINENO: result: $ac_cv_path_GREP" >&5 +echo "${ECHO_T}$ac_cv_path_GREP" >&6; } + GREP="$ac_cv_path_GREP" + + +{ echo "$as_me:$LINENO: checking for egrep" >&5 +echo $ECHO_N "checking for egrep... $ECHO_C" >&6; } +if test "${ac_cv_path_EGREP+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + if echo a | $GREP -E '(a|b)' >/dev/null 2>&1 + then ac_cv_path_EGREP="$GREP -E" + else + # Extract the first word of "egrep" to use in msg output +if test -z "$EGREP"; then +set dummy egrep; ac_prog_name=$2 +if test "${ac_cv_path_EGREP+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + ac_path_EGREP_found=false +# Loop through the user's path and test for each of PROGNAME-LIST +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_prog in egrep; do + for ac_exec_ext in '' $ac_executable_extensions; do + ac_path_EGREP="$as_dir/$ac_prog$ac_exec_ext" + { test -f "$ac_path_EGREP" && $as_test_x "$ac_path_EGREP"; } || continue + # Check for GNU ac_path_EGREP and select it if it is found. + # Check for GNU $ac_path_EGREP +case `"$ac_path_EGREP" --version 2>&1` in +*GNU*) + ac_cv_path_EGREP="$ac_path_EGREP" ac_path_EGREP_found=:;; +*) + ac_count=0 + echo $ECHO_N "0123456789$ECHO_C" >"conftest.in" + while : + do + cat "conftest.in" "conftest.in" >"conftest.tmp" + mv "conftest.tmp" "conftest.in" + cp "conftest.in" "conftest.nl" + echo 'EGREP' >> "conftest.nl" + "$ac_path_EGREP" 'EGREP$' < "conftest.nl" >"conftest.out" 2>/dev/null || break + diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break + ac_count=`expr $ac_count + 1` + if test $ac_count -gt ${ac_path_EGREP_max-0}; then + # Best one so far, save it but keep looking for a better one + ac_cv_path_EGREP="$ac_path_EGREP" + ac_path_EGREP_max=$ac_count + fi + # 10*(2^10) chars as input seems more than enough + test $ac_count -gt 10 && break + done + rm -f conftest.in conftest.tmp conftest.nl conftest.out;; +esac + + + $ac_path_EGREP_found && break 3 + done +done + +done +IFS=$as_save_IFS + + +fi + +EGREP="$ac_cv_path_EGREP" +if test -z "$EGREP"; then + { { echo "$as_me:$LINENO: error: no acceptable $ac_prog_name could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" >&5 +echo "$as_me: error: no acceptable $ac_prog_name could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" >&2;} + { (exit 1); exit 1; }; } +fi + +else + ac_cv_path_EGREP=$EGREP +fi + + + fi +fi +{ echo "$as_me:$LINENO: result: $ac_cv_path_EGREP" >&5 +echo "${ECHO_T}$ac_cv_path_EGREP" >&6; } + EGREP="$ac_cv_path_EGREP" + + +{ echo "$as_me:$LINENO: checking for ANSI C header files" >&5 +echo $ECHO_N "checking for ANSI C header files... $ECHO_C" >&6; } +if test "${ac_cv_header_stdc+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include +#include +#include +#include + +int +main () +{ + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_compile") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest.$ac_objext; then + ac_cv_header_stdc=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_cv_header_stdc=no +fi + +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + +if test $ac_cv_header_stdc = yes; then + # SunOS 4.x string.h does not declare mem*, contrary to ANSI. + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "memchr" >/dev/null 2>&1; then + : +else + ac_cv_header_stdc=no +fi +rm -f -r conftest* + +fi + +if test $ac_cv_header_stdc = yes; then + # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "free" >/dev/null 2>&1; then + : +else + ac_cv_header_stdc=no +fi +rm -f -r conftest* + +fi + +if test $ac_cv_header_stdc = yes; then + # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. + if test "$cross_compiling" = yes; then + : +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include +#include +#if ((' ' & 0x0FF) == 0x020) +# define ISLOWER(c) ('a' <= (c) && (c) <= 'z') +# define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) +#else +# define ISLOWER(c) \ + (('a' <= (c) && (c) <= 'i') \ + || ('j' <= (c) && (c) <= 'r') \ + || ('s' <= (c) && (c) <= 'z')) +# define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c)) +#endif + +#define XOR(e, f) (((e) && !(f)) || (!(e) && (f))) +int +main () +{ + int i; + for (i = 0; i < 256; i++) + if (XOR (islower (i), ISLOWER (i)) + || toupper (i) != TOUPPER (i)) + return 2; + return 0; +} +_ACEOF +rm -f conftest$ac_exeext +if { (ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_link") 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { ac_try='./conftest$ac_exeext' + { (case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_try") 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + : +else + echo "$as_me: program exited with status $ac_status" >&5 +echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +( exit $ac_status ) +ac_cv_header_stdc=no +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext +fi + + +fi +fi +{ echo "$as_me:$LINENO: result: $ac_cv_header_stdc" >&5 +echo "${ECHO_T}$ac_cv_header_stdc" >&6; } +if test $ac_cv_header_stdc = yes; then + +cat >>confdefs.h <<\_ACEOF +#define STDC_HEADERS 1 +_ACEOF + +fi + +# On IRIX 5.3, sys/types and inttypes.h are conflicting. + + + + + + + + + +for ac_header in sys/types.h sys/stat.h stdlib.h string.h memory.h strings.h \ + inttypes.h stdint.h unistd.h +do +as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh` +{ echo "$as_me:$LINENO: checking for $ac_header" >&5 +echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6; } +if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default + +#include <$ac_header> +_ACEOF +rm -f conftest.$ac_objext +if { (ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_compile") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest.$ac_objext; then + eval "$as_ac_Header=yes" +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + eval "$as_ac_Header=no" +fi + +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +ac_res=`eval echo '${'$as_ac_Header'}'` + { echo "$as_me:$LINENO: result: $ac_res" >&5 +echo "${ECHO_T}$ac_res" >&6; } +if test `eval echo '${'$as_ac_Header'}'` = yes; then + cat >>confdefs.h <<_ACEOF +#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1 +_ACEOF + +fi + +done + + + + + + + + + + +for ac_header in fcntl.h limits.h stdlib.h sys/types.h unistd.h winsock2.h ws2tcpip.h wspiapi.h +do +as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh` +if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then + { echo "$as_me:$LINENO: checking for $ac_header" >&5 +echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6; } +if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +fi +ac_res=`eval echo '${'$as_ac_Header'}'` + { echo "$as_me:$LINENO: result: $ac_res" >&5 +echo "${ECHO_T}$ac_res" >&6; } +else + # Is the header compilable? +{ echo "$as_me:$LINENO: checking $ac_header usability" >&5 +echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6; } +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +#include <$ac_header> +_ACEOF +rm -f conftest.$ac_objext +if { (ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_compile") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest.$ac_objext; then + ac_header_compiler=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_header_compiler=no +fi + +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +{ echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 +echo "${ECHO_T}$ac_header_compiler" >&6; } + +# Is the header present? +{ echo "$as_me:$LINENO: checking $ac_header presence" >&5 +echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6; } +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include <$ac_header> +_ACEOF +if { (ac_try="$ac_cpp conftest.$ac_ext" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } >/dev/null && { + test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || + test ! -s conftest.err + }; then + ac_header_preproc=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_header_preproc=no +fi + +rm -f conftest.err conftest.$ac_ext +{ echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 +echo "${ECHO_T}$ac_header_preproc" >&6; } + +# So? What about this header? +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) + { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 +echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes + ;; + no:yes:* ) + { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 +echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 +echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} + ( cat <<\_ASBOX +## ------------------------------------ ## +## Report this to libraries@haskell.org ## +## ------------------------------------ ## +_ASBOX + ) | sed "s/^/$as_me: WARNING: /" >&2 + ;; +esac +{ echo "$as_me:$LINENO: checking for $ac_header" >&5 +echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6; } +if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + eval "$as_ac_Header=\$ac_header_preproc" +fi +ac_res=`eval echo '${'$as_ac_Header'}'` + { echo "$as_me:$LINENO: result: $ac_res" >&5 +echo "${ECHO_T}$ac_res" >&6; } + +fi +if test `eval echo '${'$as_ac_Header'}'` = yes; then + cat >>confdefs.h <<_ACEOF +#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1 +_ACEOF + +fi + +done + + + + + + + + +for ac_header in arpa/inet.h netdb.h netinet/in.h netinet/tcp.h sys/socket.h sys/uio.h sys/un.h +do +as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh` +if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then + { echo "$as_me:$LINENO: checking for $ac_header" >&5 +echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6; } +if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +fi +ac_res=`eval echo '${'$as_ac_Header'}'` + { echo "$as_me:$LINENO: result: $ac_res" >&5 +echo "${ECHO_T}$ac_res" >&6; } +else + # Is the header compilable? +{ echo "$as_me:$LINENO: checking $ac_header usability" >&5 +echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6; } +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +#include <$ac_header> +_ACEOF +rm -f conftest.$ac_objext +if { (ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_compile") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest.$ac_objext; then + ac_header_compiler=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_header_compiler=no +fi + +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +{ echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 +echo "${ECHO_T}$ac_header_compiler" >&6; } + +# Is the header present? +{ echo "$as_me:$LINENO: checking $ac_header presence" >&5 +echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6; } +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include <$ac_header> +_ACEOF +if { (ac_try="$ac_cpp conftest.$ac_ext" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } >/dev/null && { + test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || + test ! -s conftest.err + }; then + ac_header_preproc=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_header_preproc=no +fi + +rm -f conftest.err conftest.$ac_ext +{ echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 +echo "${ECHO_T}$ac_header_preproc" >&6; } + +# So? What about this header? +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) + { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 +echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes + ;; + no:yes:* ) + { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 +echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 +echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} + ( cat <<\_ASBOX +## ------------------------------------ ## +## Report this to libraries@haskell.org ## +## ------------------------------------ ## +_ASBOX + ) | sed "s/^/$as_me: WARNING: /" >&2 + ;; +esac +{ echo "$as_me:$LINENO: checking for $ac_header" >&5 +echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6; } +if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + eval "$as_ac_Header=\$ac_header_preproc" +fi +ac_res=`eval echo '${'$as_ac_Header'}'` + { echo "$as_me:$LINENO: result: $ac_res" >&5 +echo "${ECHO_T}$ac_res" >&6; } + +fi +if test `eval echo '${'$as_ac_Header'}'` = yes; then + cat >>confdefs.h <<_ACEOF +#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1 +_ACEOF + +fi + +done + + + + +for ac_func in readlink symlink +do +as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` +{ echo "$as_me:$LINENO: checking for $ac_func" >&5 +echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6; } +if { as_var=$as_ac_var; eval "test \"\${$as_var+set}\" = set"; }; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define $ac_func to an innocuous variant, in case declares $ac_func. + For example, HP-UX 11i declares gettimeofday. */ +#define $ac_func innocuous_$ac_func + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char $ac_func (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef $ac_func + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char $ac_func (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined __stub_$ac_func || defined __stub___$ac_func +choke me +#endif + +int +main () +{ +return $ac_func (); + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_link") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest$ac_exeext && + $as_test_x conftest$ac_exeext; then + eval "$as_ac_var=yes" +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + eval "$as_ac_var=no" +fi + +rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ + conftest$ac_exeext conftest.$ac_ext +fi +ac_res=`eval echo '${'$as_ac_var'}'` + { echo "$as_me:$LINENO: result: $ac_res" >&5 +echo "${ECHO_T}$ac_res" >&6; } +if test `eval echo '${'$as_ac_var'}'` = yes; then + cat >>confdefs.h <<_ACEOF +#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 +_ACEOF + +fi +done + + +{ echo "$as_me:$LINENO: checking for struct msghdr.msg_control" >&5 +echo $ECHO_N "checking for struct msghdr.msg_control... $ECHO_C" >&6; } +if test "${ac_cv_member_struct_msghdr_msg_control+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#if HAVE_SYS_TYPES_H +# include +#endif +#if HAVE_SYS_SOCKET_H +# include +#endif +#if HAVE_SYS_UIO_H +# include +#endif + +int +main () +{ +static struct msghdr ac_aggr; +if (ac_aggr.msg_control) +return 0; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_compile") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest.$ac_objext; then + ac_cv_member_struct_msghdr_msg_control=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#if HAVE_SYS_TYPES_H +# include +#endif +#if HAVE_SYS_SOCKET_H +# include +#endif +#if HAVE_SYS_UIO_H +# include +#endif + +int +main () +{ +static struct msghdr ac_aggr; +if (sizeof ac_aggr.msg_control) +return 0; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_compile") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest.$ac_objext; then + ac_cv_member_struct_msghdr_msg_control=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_cv_member_struct_msghdr_msg_control=no +fi + +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi + +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +{ echo "$as_me:$LINENO: result: $ac_cv_member_struct_msghdr_msg_control" >&5 +echo "${ECHO_T}$ac_cv_member_struct_msghdr_msg_control" >&6; } +if test $ac_cv_member_struct_msghdr_msg_control = yes; then + +cat >>confdefs.h <<_ACEOF +#define HAVE_STRUCT_MSGHDR_MSG_CONTROL 1 +_ACEOF + + +fi +{ echo "$as_me:$LINENO: checking for struct msghdr.msg_accrights" >&5 +echo $ECHO_N "checking for struct msghdr.msg_accrights... $ECHO_C" >&6; } +if test "${ac_cv_member_struct_msghdr_msg_accrights+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#if HAVE_SYS_TYPES_H +# include +#endif +#if HAVE_SYS_SOCKET_H +# include +#endif +#if HAVE_SYS_UIO_H +# include +#endif + +int +main () +{ +static struct msghdr ac_aggr; +if (ac_aggr.msg_accrights) +return 0; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_compile") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest.$ac_objext; then + ac_cv_member_struct_msghdr_msg_accrights=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#if HAVE_SYS_TYPES_H +# include +#endif +#if HAVE_SYS_SOCKET_H +# include +#endif +#if HAVE_SYS_UIO_H +# include +#endif + +int +main () +{ +static struct msghdr ac_aggr; +if (sizeof ac_aggr.msg_accrights) +return 0; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_compile") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest.$ac_objext; then + ac_cv_member_struct_msghdr_msg_accrights=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_cv_member_struct_msghdr_msg_accrights=no +fi + +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi + +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +{ echo "$as_me:$LINENO: result: $ac_cv_member_struct_msghdr_msg_accrights" >&5 +echo "${ECHO_T}$ac_cv_member_struct_msghdr_msg_accrights" >&6; } +if test $ac_cv_member_struct_msghdr_msg_accrights = yes; then + +cat >>confdefs.h <<_ACEOF +#define HAVE_STRUCT_MSGHDR_MSG_ACCRIGHTS 1 +_ACEOF + + +fi + + +{ echo "$as_me:$LINENO: checking for struct sockaddr.sa_len" >&5 +echo $ECHO_N "checking for struct sockaddr.sa_len... $ECHO_C" >&6; } +if test "${ac_cv_member_struct_sockaddr_sa_len+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#if HAVE_SYS_TYPES_H +# include +#endif +#if HAVE_SYS_SOCKET_H +# include +#endif + +int +main () +{ +static struct sockaddr ac_aggr; +if (ac_aggr.sa_len) +return 0; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_compile") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest.$ac_objext; then + ac_cv_member_struct_sockaddr_sa_len=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#if HAVE_SYS_TYPES_H +# include +#endif +#if HAVE_SYS_SOCKET_H +# include +#endif + +int +main () +{ +static struct sockaddr ac_aggr; +if (sizeof ac_aggr.sa_len) +return 0; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_compile") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest.$ac_objext; then + ac_cv_member_struct_sockaddr_sa_len=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_cv_member_struct_sockaddr_sa_len=no +fi + +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi + +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +{ echo "$as_me:$LINENO: result: $ac_cv_member_struct_sockaddr_sa_len" >&5 +echo "${ECHO_T}$ac_cv_member_struct_sockaddr_sa_len" >&6; } +if test $ac_cv_member_struct_sockaddr_sa_len = yes; then + +cat >>confdefs.h <<_ACEOF +#define HAVE_STRUCT_SOCKADDR_SA_LEN 1 +_ACEOF + + +fi + + +{ echo "$as_me:$LINENO: checking for in_addr_t in netinet/in.h" >&5 +echo $ECHO_N "checking for in_addr_t in netinet/in.h... $ECHO_C" >&6; } +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "in_addr_t" >/dev/null 2>&1; then + +cat >>confdefs.h <<\_ACEOF +#define HAVE_IN_ADDR_T 1 +_ACEOF + { echo "$as_me:$LINENO: result: yes" >&5 +echo "${ECHO_T}yes" >&6; } +else + { echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6; } +fi +rm -f -r conftest* + + +{ echo "$as_me:$LINENO: checking for SO_PEERCRED and struct ucred in sys/socket.h" >&5 +echo $ECHO_N "checking for SO_PEERCRED and struct ucred in sys/socket.h... $ECHO_C" >&6; } +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include +#include +#ifndef SO_PEERCRED +# error no SO_PEERCRED +#endif +struct ucred u; +int +main () +{ + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_compile") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest.$ac_objext; then + ac_cv_ucred=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_cv_ucred=no +fi + +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +if test "x$ac_cv_ucred" = xno; then + old_CFLAGS="$CFLAGS" + CFLAGS="-D_GNU_SOURCE $CFLAGS" + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include +#include +#ifndef SO_PEERCRED +# error no SO_PEERCRED +#endif +struct ucred u; +int +main () +{ + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_compile") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest.$ac_objext; then + ac_cv_ucred=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_cv_ucred=no +fi + +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + if test "x$ac_cv_ucred" = xyes; then + EXTRA_CPPFLAGS=-D_GNU_SOURCE + fi +else + old_CFLAGS="$CFLAGS" +fi +if test "x$ac_cv_ucred" = xno; then + CFLAGS="$old_CFLAGS" + { echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6; } +else + +cat >>confdefs.h <<\_ACEOF +#define HAVE_STRUCT_UCRED 1 +_ACEOF + + { echo "$as_me:$LINENO: result: yes" >&5 +echo "${ECHO_T}yes" >&6; } +fi + + +{ echo "$as_me:$LINENO: checking for _head_libws2_32_a in -lws2_32" >&5 +echo $ECHO_N "checking for _head_libws2_32_a in -lws2_32... $ECHO_C" >&6; } +if test "${ac_cv_lib_ws2_32__head_libws2_32_a+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lws2_32 $LIBS" +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char _head_libws2_32_a (); +int +main () +{ +return _head_libws2_32_a (); + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_link") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest$ac_exeext && + $as_test_x conftest$ac_exeext; then + ac_cv_lib_ws2_32__head_libws2_32_a=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_cv_lib_ws2_32__head_libws2_32_a=no +fi + +rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ echo "$as_me:$LINENO: result: $ac_cv_lib_ws2_32__head_libws2_32_a" >&5 +echo "${ECHO_T}$ac_cv_lib_ws2_32__head_libws2_32_a" >&6; } +if test $ac_cv_lib_ws2_32__head_libws2_32_a = yes; then + cat >>confdefs.h <<_ACEOF +#define HAVE_LIBWS2_32 1 +_ACEOF + + LIBS="-lws2_32 $LIBS" + +fi + + +{ echo "$as_me:$LINENO: checking for getaddrinfo" >&5 +echo $ECHO_N "checking for getaddrinfo... $ECHO_C" >&6; } +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +int testme(){ getaddrinfo; } +int +main () +{ + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_compile") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest.$ac_objext; then + +cat >>confdefs.h <<\_ACEOF +#define HAVE_GETADDRINFO 1 +_ACEOF + ac_have_getaddrinfo=yes; { echo "$as_me:$LINENO: result: yes" >&5 +echo "${ECHO_T}yes" >&6; } +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + { echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6; } +fi + +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + +if test "x$ac_have_getaddrinfo" = x; then + old_CFLAGS="$CFLAGS" + if test "z$ac_cv_lib_ws2_32__head_libws2_32_a" = zyes; then + CFLAGS="-DWINVER=0x0501 $CFLAGS" + { echo "$as_me:$LINENO: checking for getaddrinfo if WINVER is 0x0501" >&5 +echo $ECHO_N "checking for getaddrinfo if WINVER is 0x0501... $ECHO_C" >&6; } + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default + int testme(){ getaddrinfo; } +int +main () +{ + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_compile") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest.$ac_objext; then + +cat >>confdefs.h <<\_ACEOF +#define HAVE_GETADDRINFO 1 +_ACEOF + +cat >>confdefs.h <<\_ACEOF +#define NEED_WINVER_XP 1 +_ACEOF + EXTRA_CPPFLAGS="-DWINVER=0x0501 $EXTRA_CPPFLAGS"; { echo "$as_me:$LINENO: result: yes" >&5 +echo "${ECHO_T}yes" >&6; } +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + CFLAGS="$old_CFLAGS"; { echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6; } +fi + +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + fi +fi + + +for ac_func in gai_strerror +do +as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` +{ echo "$as_me:$LINENO: checking for $ac_func" >&5 +echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6; } +if { as_var=$as_ac_var; eval "test \"\${$as_var+set}\" = set"; }; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define $ac_func to an innocuous variant, in case declares $ac_func. + For example, HP-UX 11i declares gettimeofday. */ +#define $ac_func innocuous_$ac_func + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char $ac_func (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef $ac_func + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char $ac_func (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined __stub_$ac_func || defined __stub___$ac_func +choke me +#endif + +int +main () +{ +return $ac_func (); + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_link") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest$ac_exeext && + $as_test_x conftest$ac_exeext; then + eval "$as_ac_var=yes" +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + eval "$as_ac_var=no" +fi + +rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ + conftest$ac_exeext conftest.$ac_ext +fi +ac_res=`eval echo '${'$as_ac_var'}'` + { echo "$as_me:$LINENO: result: $ac_res" >&5 +echo "${ECHO_T}$ac_res" >&6; } +if test `eval echo '${'$as_ac_var'}'` = yes; then + cat >>confdefs.h <<_ACEOF +#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 +_ACEOF + +fi +done + + +{ echo "$as_me:$LINENO: checking whether AI_ADDRCONFIG is declared" >&5 +echo $ECHO_N "checking whether AI_ADDRCONFIG is declared... $ECHO_C" >&6; } +if test "${ac_cv_have_decl_AI_ADDRCONFIG+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +int +main () +{ +#ifndef AI_ADDRCONFIG + (void) AI_ADDRCONFIG; +#endif + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_compile") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest.$ac_objext; then + ac_cv_have_decl_AI_ADDRCONFIG=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_cv_have_decl_AI_ADDRCONFIG=no +fi + +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +{ echo "$as_me:$LINENO: result: $ac_cv_have_decl_AI_ADDRCONFIG" >&5 +echo "${ECHO_T}$ac_cv_have_decl_AI_ADDRCONFIG" >&6; } +if test $ac_cv_have_decl_AI_ADDRCONFIG = yes; then + +cat >>confdefs.h <<_ACEOF +#define HAVE_DECL_AI_ADDRCONFIG 1 +_ACEOF + + +else + cat >>confdefs.h <<_ACEOF +#define HAVE_DECL_AI_ADDRCONFIG 0 +_ACEOF + + +fi +{ echo "$as_me:$LINENO: checking whether AI_ALL is declared" >&5 +echo $ECHO_N "checking whether AI_ALL is declared... $ECHO_C" >&6; } +if test "${ac_cv_have_decl_AI_ALL+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +int +main () +{ +#ifndef AI_ALL + (void) AI_ALL; +#endif + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_compile") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest.$ac_objext; then + ac_cv_have_decl_AI_ALL=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_cv_have_decl_AI_ALL=no +fi + +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +{ echo "$as_me:$LINENO: result: $ac_cv_have_decl_AI_ALL" >&5 +echo "${ECHO_T}$ac_cv_have_decl_AI_ALL" >&6; } +if test $ac_cv_have_decl_AI_ALL = yes; then + +cat >>confdefs.h <<_ACEOF +#define HAVE_DECL_AI_ALL 1 +_ACEOF + + +else + cat >>confdefs.h <<_ACEOF +#define HAVE_DECL_AI_ALL 0 +_ACEOF + + +fi +{ echo "$as_me:$LINENO: checking whether AI_NUMERICSERV is declared" >&5 +echo $ECHO_N "checking whether AI_NUMERICSERV is declared... $ECHO_C" >&6; } +if test "${ac_cv_have_decl_AI_NUMERICSERV+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +int +main () +{ +#ifndef AI_NUMERICSERV + (void) AI_NUMERICSERV; +#endif + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_compile") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest.$ac_objext; then + ac_cv_have_decl_AI_NUMERICSERV=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_cv_have_decl_AI_NUMERICSERV=no +fi + +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +{ echo "$as_me:$LINENO: result: $ac_cv_have_decl_AI_NUMERICSERV" >&5 +echo "${ECHO_T}$ac_cv_have_decl_AI_NUMERICSERV" >&6; } +if test $ac_cv_have_decl_AI_NUMERICSERV = yes; then + +cat >>confdefs.h <<_ACEOF +#define HAVE_DECL_AI_NUMERICSERV 1 +_ACEOF + + +else + cat >>confdefs.h <<_ACEOF +#define HAVE_DECL_AI_NUMERICSERV 0 +_ACEOF + + +fi +{ echo "$as_me:$LINENO: checking whether AI_V4MAPPED is declared" >&5 +echo $ECHO_N "checking whether AI_V4MAPPED is declared... $ECHO_C" >&6; } +if test "${ac_cv_have_decl_AI_V4MAPPED+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +int +main () +{ +#ifndef AI_V4MAPPED + (void) AI_V4MAPPED; +#endif + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_compile") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest.$ac_objext; then + ac_cv_have_decl_AI_V4MAPPED=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_cv_have_decl_AI_V4MAPPED=no +fi + +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +{ echo "$as_me:$LINENO: result: $ac_cv_have_decl_AI_V4MAPPED" >&5 +echo "${ECHO_T}$ac_cv_have_decl_AI_V4MAPPED" >&6; } +if test $ac_cv_have_decl_AI_V4MAPPED = yes; then + +cat >>confdefs.h <<_ACEOF +#define HAVE_DECL_AI_V4MAPPED 1 +_ACEOF + + +else + cat >>confdefs.h <<_ACEOF +#define HAVE_DECL_AI_V4MAPPED 0 +_ACEOF + + +fi + + + +{ echo "$as_me:$LINENO: checking whether IPV6_V6ONLY is declared" >&5 +echo $ECHO_N "checking whether IPV6_V6ONLY is declared... $ECHO_C" >&6; } +if test "${ac_cv_have_decl_IPV6_V6ONLY+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +int +main () +{ +#ifndef IPV6_V6ONLY + (void) IPV6_V6ONLY; +#endif + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_compile") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest.$ac_objext; then + ac_cv_have_decl_IPV6_V6ONLY=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_cv_have_decl_IPV6_V6ONLY=no +fi + +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +{ echo "$as_me:$LINENO: result: $ac_cv_have_decl_IPV6_V6ONLY" >&5 +echo "${ECHO_T}$ac_cv_have_decl_IPV6_V6ONLY" >&6; } +if test $ac_cv_have_decl_IPV6_V6ONLY = yes; then + +cat >>confdefs.h <<_ACEOF +#define HAVE_DECL_IPV6_V6ONLY 1 +_ACEOF + + +else + cat >>confdefs.h <<_ACEOF +#define HAVE_DECL_IPV6_V6ONLY 0 +_ACEOF + + +fi + + + +{ echo "$as_me:$LINENO: checking for sendfile in sys/sendfile.h" >&5 +echo $ECHO_N "checking for sendfile in sys/sendfile.h... $ECHO_C" >&6; } +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "sendfile" >/dev/null 2>&1; then + +cat >>confdefs.h <<\_ACEOF +#define HAVE_LINUX_SENDFILE 1 +_ACEOF + { echo "$as_me:$LINENO: result: yes" >&5 +echo "${ECHO_T}yes" >&6; } +else + { echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6; } +fi +rm -f -r conftest* + + +{ echo "$as_me:$LINENO: checking for sendfile in sys/socket.h" >&5 +echo $ECHO_N "checking for sendfile in sys/socket.h... $ECHO_C" >&6; } +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "sendfile" >/dev/null 2>&1; then + +cat >>confdefs.h <<\_ACEOF +#define HAVE_BSD_SENDFILE 1 +_ACEOF + { echo "$as_me:$LINENO: result: yes" >&5 +echo "${ECHO_T}yes" >&6; } +else + { echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6; } +fi +rm -f -r conftest* + + + +for ac_func in gethostent +do +as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` +{ echo "$as_me:$LINENO: checking for $ac_func" >&5 +echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6; } +if { as_var=$as_ac_var; eval "test \"\${$as_var+set}\" = set"; }; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define $ac_func to an innocuous variant, in case declares $ac_func. + For example, HP-UX 11i declares gettimeofday. */ +#define $ac_func innocuous_$ac_func + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char $ac_func (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef $ac_func + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char $ac_func (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined __stub_$ac_func || defined __stub___$ac_func +choke me +#endif + +int +main () +{ +return $ac_func (); + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_link") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest$ac_exeext && + $as_test_x conftest$ac_exeext; then + eval "$as_ac_var=yes" +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + eval "$as_ac_var=no" +fi + +rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ + conftest$ac_exeext conftest.$ac_ext +fi +ac_res=`eval echo '${'$as_ac_var'}'` + { echo "$as_me:$LINENO: result: $ac_res" >&5 +echo "${ECHO_T}$ac_res" >&6; } +if test `eval echo '${'$as_ac_var'}'` = yes; then + cat >>confdefs.h <<_ACEOF +#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 +_ACEOF + +fi +done + + +case "$host" in +*-mingw32) + EXTRA_SRCS="cbits/initWinSock.c, cbits/winSockErr.c, cbits/asyncAccept.c" + EXTRA_LIBS=ws2_32 + CALLCONV=stdcall ;; +*-solaris2*) + EXTRA_SRCS="cbits/ancilData.c" + EXTRA_LIBS="nsl, socket" + CALLCONV=ccall ;; +*) + EXTRA_SRCS="cbits/ancilData.c" + EXTRA_LIBS= + CALLCONV=ccall ;; +esac + + + + + +ac_config_files="$ac_config_files network.buildinfo" + + +cat >confcache <<\_ACEOF +# This file is a shell script that caches the results of configure +# tests run on this system so they can be shared between configure +# scripts and configure runs, see configure's option --config-cache. +# It is not useful on other systems. If it contains results you don't +# want to keep, you may remove or edit it. +# +# config.status only pays attention to the cache file if you give it +# the --recheck option to rerun configure. +# +# `ac_cv_env_foo' variables (set or unset) will be overridden when +# loading this file, other *unset* `ac_cv_foo' will be assigned the +# following values. + +_ACEOF + +# The following way of writing the cache mishandles newlines in values, +# but we know of no workaround that is simple, portable, and efficient. +# So, we kill variables containing newlines. +# Ultrix sh set writes to stderr and can't be redirected directly, +# and sets the high bit in the cache file unless we assign to the vars. +( + for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do + eval ac_val=\$$ac_var + case $ac_val in #( + *${as_nl}*) + case $ac_var in #( + *_cv_*) { echo "$as_me:$LINENO: WARNING: Cache variable $ac_var contains a newline." >&5 +echo "$as_me: WARNING: Cache variable $ac_var contains a newline." >&2;} ;; + esac + case $ac_var in #( + _ | IFS | as_nl) ;; #( + *) $as_unset $ac_var ;; + esac ;; + esac + done + + (set) 2>&1 | + case $as_nl`(ac_space=' '; set) 2>&1` in #( + *${as_nl}ac_space=\ *) + # `set' does not quote correctly, so add quotes (double-quote + # substitution turns \\\\ into \\, and sed turns \\ into \). + sed -n \ + "s/'/'\\\\''/g; + s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" + ;; #( + *) + # `set' quotes correctly as required by POSIX, so do not add quotes. + sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" + ;; + esac | + sort +) | + sed ' + /^ac_cv_env_/b end + t clear + :clear + s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/ + t end + s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ + :end' >>confcache +if diff "$cache_file" confcache >/dev/null 2>&1; then :; else + if test -w "$cache_file"; then + test "x$cache_file" != "x/dev/null" && + { echo "$as_me:$LINENO: updating cache $cache_file" >&5 +echo "$as_me: updating cache $cache_file" >&6;} + cat confcache >$cache_file + else + { echo "$as_me:$LINENO: not updating unwritable cache $cache_file" >&5 +echo "$as_me: not updating unwritable cache $cache_file" >&6;} + fi +fi +rm -f confcache + +test "x$prefix" = xNONE && prefix=$ac_default_prefix +# Let make expand exec_prefix. +test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' + +DEFS=-DHAVE_CONFIG_H + +ac_libobjs= +ac_ltlibobjs= +for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue + # 1. Remove the extension, and $U if already installed. + ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' + ac_i=`echo "$ac_i" | sed "$ac_script"` + # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR + # will be set to the directory where LIBOBJS objects are built. + ac_libobjs="$ac_libobjs \${LIBOBJDIR}$ac_i\$U.$ac_objext" + ac_ltlibobjs="$ac_ltlibobjs \${LIBOBJDIR}$ac_i"'$U.lo' +done +LIBOBJS=$ac_libobjs + +LTLIBOBJS=$ac_ltlibobjs + + + +: ${CONFIG_STATUS=./config.status} +ac_clean_files_save=$ac_clean_files +ac_clean_files="$ac_clean_files $CONFIG_STATUS" +{ echo "$as_me:$LINENO: creating $CONFIG_STATUS" >&5 +echo "$as_me: creating $CONFIG_STATUS" >&6;} +cat >$CONFIG_STATUS <<_ACEOF +#! $SHELL +# Generated by $as_me. +# Run this file to recreate the current configuration. +# Compiler output produced by configure, useful for debugging +# configure, is in config.log if it exists. + +debug=false +ac_cs_recheck=false +ac_cs_silent=false +SHELL=\${CONFIG_SHELL-$SHELL} +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF +## --------------------- ## +## M4sh Initialization. ## +## --------------------- ## + +# Be more Bourne compatible +DUALCASE=1; export DUALCASE # for MKS sh +if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then + emulate sh + NULLCMD=: + # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which + # is contrary to our usage. Disable this feature. + alias -g '${1+"$@"}'='"$@"' + setopt NO_GLOB_SUBST +else + case `(set -o) 2>/dev/null` in + *posix*) set -o posix ;; +esac + +fi + + + + +# PATH needs CR +# Avoid depending upon Character Ranges. +as_cr_letters='abcdefghijklmnopqrstuvwxyz' +as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' +as_cr_Letters=$as_cr_letters$as_cr_LETTERS +as_cr_digits='0123456789' +as_cr_alnum=$as_cr_Letters$as_cr_digits + +# The user is always right. +if test "${PATH_SEPARATOR+set}" != set; then + echo "#! /bin/sh" >conf$$.sh + echo "exit 0" >>conf$$.sh + chmod +x conf$$.sh + if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then + PATH_SEPARATOR=';' + else + PATH_SEPARATOR=: + fi + rm -f conf$$.sh +fi + +# Support unset when possible. +if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then + as_unset=unset +else + as_unset=false +fi + + +# IFS +# We need space, tab and new line, in precisely that order. Quoting is +# there to prevent editors from complaining about space-tab. +# (If _AS_PATH_WALK were called with IFS unset, it would disable word +# splitting by setting IFS to empty value.) +as_nl=' +' +IFS=" "" $as_nl" + +# Find who we are. Look in the path if we contain no directory separator. +case $0 in + *[\\/]* ) as_myself=$0 ;; + *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break +done +IFS=$as_save_IFS + + ;; +esac +# We did not find ourselves, most probably we were run as `sh COMMAND' +# in which case we are not to be found in the path. +if test "x$as_myself" = x; then + as_myself=$0 +fi +if test ! -f "$as_myself"; then + echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 + { (exit 1); exit 1; } +fi + +# Work around bugs in pre-3.0 UWIN ksh. +for as_var in ENV MAIL MAILPATH +do ($as_unset $as_var) >/dev/null 2>&1 && $as_unset $as_var +done +PS1='$ ' +PS2='> ' +PS4='+ ' + +# NLS nuisances. +for as_var in \ + LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \ + LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \ + LC_TELEPHONE LC_TIME +do + if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then + eval $as_var=C; export $as_var + else + ($as_unset $as_var) >/dev/null 2>&1 && $as_unset $as_var + fi +done + +# Required to use basename. +if expr a : '\(a\)' >/dev/null 2>&1 && + test "X`expr 00001 : '.*\(...\)'`" = X001; then + as_expr=expr +else + as_expr=false +fi + +if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then + as_basename=basename +else + as_basename=false +fi + + +# Name of the executable. +as_me=`$as_basename -- "$0" || +$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ + X"$0" : 'X\(//\)$' \| \ + X"$0" : 'X\(/\)' \| . 2>/dev/null || +echo X/"$0" | + sed '/^.*\/\([^/][^/]*\)\/*$/{ + s//\1/ + q + } + /^X\/\(\/\/\)$/{ + s//\1/ + q + } + /^X\/\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + +# CDPATH. +$as_unset CDPATH + + + + as_lineno_1=$LINENO + as_lineno_2=$LINENO + test "x$as_lineno_1" != "x$as_lineno_2" && + test "x`expr $as_lineno_1 + 1`" = "x$as_lineno_2" || { + + # Create $as_me.lineno as a copy of $as_myself, but with $LINENO + # uniformly replaced by the line number. The first 'sed' inserts a + # line-number line after each line using $LINENO; the second 'sed' + # does the real work. The second script uses 'N' to pair each + # line-number line with the line containing $LINENO, and appends + # trailing '-' during substitution so that $LINENO is not a special + # case at line end. + # (Raja R Harinath suggested sed '=', and Paul Eggert wrote the + # scripts with optimization help from Paolo Bonzini. Blame Lee + # E. McMahon (1931-1989) for sed's syntax. :-) + sed -n ' + p + /[$]LINENO/= + ' <$as_myself | + sed ' + s/[$]LINENO.*/&-/ + t lineno + b + :lineno + N + :loop + s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ + t loop + s/-\n.*// + ' >$as_me.lineno && + chmod +x "$as_me.lineno" || + { echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2 + { (exit 1); exit 1; }; } + + # Don't try to exec as it changes $[0], causing all sort of problems + # (the dirname of $[0] is not the place where we might find the + # original and so on. Autoconf is especially sensitive to this). + . "./$as_me.lineno" + # Exit status is that of the last command. + exit +} + + +if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then + as_dirname=dirname +else + as_dirname=false +fi + +ECHO_C= ECHO_N= ECHO_T= +case `echo -n x` in +-n*) + case `echo 'x\c'` in + *c*) ECHO_T=' ';; # ECHO_T is single tab character. + *) ECHO_C='\c';; + esac;; +*) + ECHO_N='-n';; +esac + +if expr a : '\(a\)' >/dev/null 2>&1 && + test "X`expr 00001 : '.*\(...\)'`" = X001; then + as_expr=expr +else + as_expr=false +fi + +rm -f conf$$ conf$$.exe conf$$.file +if test -d conf$$.dir; then + rm -f conf$$.dir/conf$$.file +else + rm -f conf$$.dir + mkdir conf$$.dir +fi +echo >conf$$.file +if ln -s conf$$.file conf$$ 2>/dev/null; then + as_ln_s='ln -s' + # ... but there are two gotchas: + # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. + # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. + # In both cases, we have to default to `cp -p'. + ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || + as_ln_s='cp -p' +elif ln conf$$.file conf$$ 2>/dev/null; then + as_ln_s=ln +else + as_ln_s='cp -p' +fi +rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file +rmdir conf$$.dir 2>/dev/null + +if mkdir -p . 2>/dev/null; then + as_mkdir_p=: +else + test -d ./-p && rmdir ./-p + as_mkdir_p=false +fi + +if test -x / >/dev/null 2>&1; then + as_test_x='test -x' +else + if ls -dL / >/dev/null 2>&1; then + as_ls_L_option=L + else + as_ls_L_option= + fi + as_test_x=' + eval sh -c '\'' + if test -d "$1"; then + test -d "$1/."; + else + case $1 in + -*)set "./$1";; + esac; + case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in + ???[sx]*):;;*)false;;esac;fi + '\'' sh + ' +fi +as_executable_p=$as_test_x + +# Sed expression to map a string onto a valid CPP name. +as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" + +# Sed expression to map a string onto a valid variable name. +as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" + + +exec 6>&1 + +# Save the log message, to keep $[0] and so on meaningful, and to +# report actual input values of CONFIG_FILES etc. instead of their +# values after options handling. +ac_log=" +This file was extended by Haskell network package $as_me 2.3.0.11, which was +generated by GNU Autoconf 2.61. Invocation command line was + + CONFIG_FILES = $CONFIG_FILES + CONFIG_HEADERS = $CONFIG_HEADERS + CONFIG_LINKS = $CONFIG_LINKS + CONFIG_COMMANDS = $CONFIG_COMMANDS + $ $0 $@ + +on `(hostname || uname -n) 2>/dev/null | sed 1q` +" + +_ACEOF + +cat >>$CONFIG_STATUS <<_ACEOF +# Files that config.status was made for. +config_files="$ac_config_files" +config_headers="$ac_config_headers" + +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF +ac_cs_usage="\ +\`$as_me' instantiates files from templates according to the +current configuration. + +Usage: $0 [OPTIONS] [FILE]... + + -h, --help print this help, then exit + -V, --version print version number and configuration settings, then exit + -q, --quiet do not print progress messages + -d, --debug don't remove temporary files + --recheck update $as_me by reconfiguring in the same conditions + --file=FILE[:TEMPLATE] + instantiate the configuration file FILE + --header=FILE[:TEMPLATE] + instantiate the configuration header FILE + +Configuration files: +$config_files + +Configuration headers: +$config_headers + +Report bugs to ." + +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF +ac_cs_version="\\ +Haskell network package config.status 2.3.0.11 +configured by $0, generated by GNU Autoconf 2.61, + with options \\"`echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`\\" + +Copyright (C) 2006 Free Software Foundation, Inc. +This config.status script is free software; the Free Software Foundation +gives unlimited permission to copy, distribute and modify it." + +ac_pwd='$ac_pwd' +srcdir='$srcdir' +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF +# If no file are specified by the user, then we need to provide default +# value. By we need to know if files were specified by the user. +ac_need_defaults=: +while test $# != 0 +do + case $1 in + --*=*) + ac_option=`expr "X$1" : 'X\([^=]*\)='` + ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` + ac_shift=: + ;; + *) + ac_option=$1 + ac_optarg=$2 + ac_shift=shift + ;; + esac + + case $ac_option in + # Handling of the options. + -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) + ac_cs_recheck=: ;; + --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) + echo "$ac_cs_version"; exit ;; + --debug | --debu | --deb | --de | --d | -d ) + debug=: ;; + --file | --fil | --fi | --f ) + $ac_shift + CONFIG_FILES="$CONFIG_FILES $ac_optarg" + ac_need_defaults=false;; + --header | --heade | --head | --hea ) + $ac_shift + CONFIG_HEADERS="$CONFIG_HEADERS $ac_optarg" + ac_need_defaults=false;; + --he | --h) + # Conflict between --help and --header + { echo "$as_me: error: ambiguous option: $1 +Try \`$0 --help' for more information." >&2 + { (exit 1); exit 1; }; };; + --help | --hel | -h ) + echo "$ac_cs_usage"; exit ;; + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil | --si | --s) + ac_cs_silent=: ;; + + # This is an error. + -*) { echo "$as_me: error: unrecognized option: $1 +Try \`$0 --help' for more information." >&2 + { (exit 1); exit 1; }; } ;; + + *) ac_config_targets="$ac_config_targets $1" + ac_need_defaults=false ;; + + esac + shift +done + +ac_configure_extra_args= + +if $ac_cs_silent; then + exec 6>/dev/null + ac_configure_extra_args="$ac_configure_extra_args --silent" +fi + +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF +if \$ac_cs_recheck; then + echo "running CONFIG_SHELL=$SHELL $SHELL $0 "$ac_configure_args \$ac_configure_extra_args " --no-create --no-recursion" >&6 + CONFIG_SHELL=$SHELL + export CONFIG_SHELL + exec $SHELL "$0"$ac_configure_args \$ac_configure_extra_args --no-create --no-recursion +fi + +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF +exec 5>>config.log +{ + echo + sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX +## Running $as_me. ## +_ASBOX + echo "$ac_log" +} >&5 + +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF + +# Handling of arguments. +for ac_config_target in $ac_config_targets +do + case $ac_config_target in + "include/HsNetworkConfig.h") CONFIG_HEADERS="$CONFIG_HEADERS include/HsNetworkConfig.h" ;; + "network.buildinfo") CONFIG_FILES="$CONFIG_FILES network.buildinfo" ;; + + *) { { echo "$as_me:$LINENO: error: invalid argument: $ac_config_target" >&5 +echo "$as_me: error: invalid argument: $ac_config_target" >&2;} + { (exit 1); exit 1; }; };; + esac +done + + +# If the user did not use the arguments to specify the items to instantiate, +# then the envvar interface is used. Set only those that are not. +# We use the long form for the default assignment because of an extremely +# bizarre bug on SunOS 4.1.3. +if $ac_need_defaults; then + test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files + test "${CONFIG_HEADERS+set}" = set || CONFIG_HEADERS=$config_headers +fi + +# Have a temporary directory for convenience. Make it in the build tree +# simply because there is no reason against having it here, and in addition, +# creating and moving files from /tmp can sometimes cause problems. +# Hook for its removal unless debugging. +# Note that there is a small window in which the directory will not be cleaned: +# after its creation but before its name has been assigned to `$tmp'. +$debug || +{ + tmp= + trap 'exit_status=$? + { test -z "$tmp" || test ! -d "$tmp" || rm -fr "$tmp"; } && exit $exit_status +' 0 + trap '{ (exit 1); exit 1; }' 1 2 13 15 +} +# Create a (secure) tmp directory for tmp files. + +{ + tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && + test -n "$tmp" && test -d "$tmp" +} || +{ + tmp=./conf$$-$RANDOM + (umask 077 && mkdir "$tmp") +} || +{ + echo "$me: cannot create a temporary directory in ." >&2 + { (exit 1); exit 1; } +} + +# +# Set up the sed scripts for CONFIG_FILES section. +# + +# No need to generate the scripts if there are no CONFIG_FILES. +# This happens for instance when ./config.status config.h +if test -n "$CONFIG_FILES"; then + +_ACEOF + + + +ac_delim='%!_!# ' +for ac_last_try in false false false false false :; do + cat >conf$$subs.sed <<_ACEOF +SHELL!$SHELL$ac_delim +PATH_SEPARATOR!$PATH_SEPARATOR$ac_delim +PACKAGE_NAME!$PACKAGE_NAME$ac_delim +PACKAGE_TARNAME!$PACKAGE_TARNAME$ac_delim +PACKAGE_VERSION!$PACKAGE_VERSION$ac_delim +PACKAGE_STRING!$PACKAGE_STRING$ac_delim +PACKAGE_BUGREPORT!$PACKAGE_BUGREPORT$ac_delim +exec_prefix!$exec_prefix$ac_delim +prefix!$prefix$ac_delim +program_transform_name!$program_transform_name$ac_delim +bindir!$bindir$ac_delim +sbindir!$sbindir$ac_delim +libexecdir!$libexecdir$ac_delim +datarootdir!$datarootdir$ac_delim +datadir!$datadir$ac_delim +sysconfdir!$sysconfdir$ac_delim +sharedstatedir!$sharedstatedir$ac_delim +localstatedir!$localstatedir$ac_delim +includedir!$includedir$ac_delim +oldincludedir!$oldincludedir$ac_delim +docdir!$docdir$ac_delim +infodir!$infodir$ac_delim +htmldir!$htmldir$ac_delim +dvidir!$dvidir$ac_delim +pdfdir!$pdfdir$ac_delim +psdir!$psdir$ac_delim +libdir!$libdir$ac_delim +localedir!$localedir$ac_delim +mandir!$mandir$ac_delim +DEFS!$DEFS$ac_delim +ECHO_C!$ECHO_C$ac_delim +ECHO_N!$ECHO_N$ac_delim +ECHO_T!$ECHO_T$ac_delim +LIBS!$LIBS$ac_delim +build_alias!$build_alias$ac_delim +host_alias!$host_alias$ac_delim +target_alias!$target_alias$ac_delim +build!$build$ac_delim +build_cpu!$build_cpu$ac_delim +build_vendor!$build_vendor$ac_delim +build_os!$build_os$ac_delim +host!$host$ac_delim +host_cpu!$host_cpu$ac_delim +host_vendor!$host_vendor$ac_delim +host_os!$host_os$ac_delim +CC!$CC$ac_delim +CFLAGS!$CFLAGS$ac_delim +LDFLAGS!$LDFLAGS$ac_delim +CPPFLAGS!$CPPFLAGS$ac_delim +ac_ct_CC!$ac_ct_CC$ac_delim +EXEEXT!$EXEEXT$ac_delim +OBJEXT!$OBJEXT$ac_delim +CPP!$CPP$ac_delim +GREP!$GREP$ac_delim +EGREP!$EGREP$ac_delim +CALLCONV!$CALLCONV$ac_delim +EXTRA_CPPFLAGS!$EXTRA_CPPFLAGS$ac_delim +EXTRA_LIBS!$EXTRA_LIBS$ac_delim +EXTRA_SRCS!$EXTRA_SRCS$ac_delim +LIBOBJS!$LIBOBJS$ac_delim +LTLIBOBJS!$LTLIBOBJS$ac_delim +_ACEOF + + if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 61; then + break + elif $ac_last_try; then + { { echo "$as_me:$LINENO: error: could not make $CONFIG_STATUS" >&5 +echo "$as_me: error: could not make $CONFIG_STATUS" >&2;} + { (exit 1); exit 1; }; } + else + ac_delim="$ac_delim!$ac_delim _$ac_delim!! " + fi +done + +ac_eof=`sed -n '/^CEOF[0-9]*$/s/CEOF/0/p' conf$$subs.sed` +if test -n "$ac_eof"; then + ac_eof=`echo "$ac_eof" | sort -nru | sed 1q` + ac_eof=`expr $ac_eof + 1` +fi + +cat >>$CONFIG_STATUS <<_ACEOF +cat >"\$tmp/subs-1.sed" <<\CEOF$ac_eof +/@[a-zA-Z_][a-zA-Z_0-9]*@/!b end +_ACEOF +sed ' +s/[,\\&]/\\&/g; s/@/@|#_!!_#|/g +s/^/s,@/; s/!/@,|#_!!_#|/ +:n +t n +s/'"$ac_delim"'$/,g/; t +s/$/\\/; p +N; s/^.*\n//; s/[,\\&]/\\&/g; s/@/@|#_!!_#|/g; b n +' >>$CONFIG_STATUS >$CONFIG_STATUS <<_ACEOF +:end +s/|#_!!_#|//g +CEOF$ac_eof +_ACEOF + + +# VPATH may cause trouble with some makes, so we remove $(srcdir), +# ${srcdir} and @srcdir@ from VPATH if srcdir is ".", strip leading and +# trailing colons and then remove the whole line if VPATH becomes empty +# (actually we leave an empty line to preserve line numbers). +if test "x$srcdir" = x.; then + ac_vpsub='/^[ ]*VPATH[ ]*=/{ +s/:*\$(srcdir):*/:/ +s/:*\${srcdir}:*/:/ +s/:*@srcdir@:*/:/ +s/^\([^=]*=[ ]*\):*/\1/ +s/:*$// +s/^[^=]*=[ ]*$// +}' +fi + +cat >>$CONFIG_STATUS <<\_ACEOF +fi # test -n "$CONFIG_FILES" + + +for ac_tag in :F $CONFIG_FILES :H $CONFIG_HEADERS +do + case $ac_tag in + :[FHLC]) ac_mode=$ac_tag; continue;; + esac + case $ac_mode$ac_tag in + :[FHL]*:*);; + :L* | :C*:*) { { echo "$as_me:$LINENO: error: Invalid tag $ac_tag." >&5 +echo "$as_me: error: Invalid tag $ac_tag." >&2;} + { (exit 1); exit 1; }; };; + :[FH]-) ac_tag=-:-;; + :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; + esac + ac_save_IFS=$IFS + IFS=: + set x $ac_tag + IFS=$ac_save_IFS + shift + ac_file=$1 + shift + + case $ac_mode in + :L) ac_source=$1;; + :[FH]) + ac_file_inputs= + for ac_f + do + case $ac_f in + -) ac_f="$tmp/stdin";; + *) # Look for the file first in the build tree, then in the source tree + # (if the path is not absolute). The absolute path cannot be DOS-style, + # because $ac_f cannot contain `:'. + test -f "$ac_f" || + case $ac_f in + [\\/$]*) false;; + *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; + esac || + { { echo "$as_me:$LINENO: error: cannot find input file: $ac_f" >&5 +echo "$as_me: error: cannot find input file: $ac_f" >&2;} + { (exit 1); exit 1; }; };; + esac + ac_file_inputs="$ac_file_inputs $ac_f" + done + + # Let's still pretend it is `configure' which instantiates (i.e., don't + # use $as_me), people would be surprised to read: + # /* config.h. Generated by config.status. */ + configure_input="Generated from "`IFS=: + echo $* | sed 's|^[^:]*/||;s|:[^:]*/|, |g'`" by configure." + if test x"$ac_file" != x-; then + configure_input="$ac_file. $configure_input" + { echo "$as_me:$LINENO: creating $ac_file" >&5 +echo "$as_me: creating $ac_file" >&6;} + fi + + case $ac_tag in + *:-:* | *:-) cat >"$tmp/stdin";; + esac + ;; + esac + + ac_dir=`$as_dirname -- "$ac_file" || +$as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$ac_file" : 'X\(//\)[^/]' \| \ + X"$ac_file" : 'X\(//\)$' \| \ + X"$ac_file" : 'X\(/\)' \| . 2>/dev/null || +echo X"$ac_file" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + { as_dir="$ac_dir" + case $as_dir in #( + -*) as_dir=./$as_dir;; + esac + test -d "$as_dir" || { $as_mkdir_p && mkdir -p "$as_dir"; } || { + as_dirs= + while :; do + case $as_dir in #( + *\'*) as_qdir=`echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #( + *) as_qdir=$as_dir;; + esac + as_dirs="'$as_qdir' $as_dirs" + as_dir=`$as_dirname -- "$as_dir" || +$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_dir" : 'X\(//\)[^/]' \| \ + X"$as_dir" : 'X\(//\)$' \| \ + X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || +echo X"$as_dir" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + test -d "$as_dir" && break + done + test -z "$as_dirs" || eval "mkdir $as_dirs" + } || test -d "$as_dir" || { { echo "$as_me:$LINENO: error: cannot create directory $as_dir" >&5 +echo "$as_me: error: cannot create directory $as_dir" >&2;} + { (exit 1); exit 1; }; }; } + ac_builddir=. + +case "$ac_dir" in +.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; +*) + ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'` + # A ".." for each directory in $ac_dir_suffix. + ac_top_builddir_sub=`echo "$ac_dir_suffix" | sed 's,/[^\\/]*,/..,g;s,/,,'` + case $ac_top_builddir_sub in + "") ac_top_builddir_sub=. ac_top_build_prefix= ;; + *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; + esac ;; +esac +ac_abs_top_builddir=$ac_pwd +ac_abs_builddir=$ac_pwd$ac_dir_suffix +# for backward compatibility: +ac_top_builddir=$ac_top_build_prefix + +case $srcdir in + .) # We are building in place. + ac_srcdir=. + ac_top_srcdir=$ac_top_builddir_sub + ac_abs_top_srcdir=$ac_pwd ;; + [\\/]* | ?:[\\/]* ) # Absolute name. + ac_srcdir=$srcdir$ac_dir_suffix; + ac_top_srcdir=$srcdir + ac_abs_top_srcdir=$srcdir ;; + *) # Relative name. + ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix + ac_top_srcdir=$ac_top_build_prefix$srcdir + ac_abs_top_srcdir=$ac_pwd/$srcdir ;; +esac +ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix + + + case $ac_mode in + :F) + # + # CONFIG_FILE + # + +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF +# If the template does not know about datarootdir, expand it. +# FIXME: This hack should be removed a few years after 2.60. +ac_datarootdir_hack=; ac_datarootdir_seen= + +case `sed -n '/datarootdir/ { + p + q +} +/@datadir@/p +/@docdir@/p +/@infodir@/p +/@localedir@/p +/@mandir@/p +' $ac_file_inputs` in +*datarootdir*) ac_datarootdir_seen=yes;; +*@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) + { echo "$as_me:$LINENO: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 +echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF + ac_datarootdir_hack=' + s&@datadir@&$datadir&g + s&@docdir@&$docdir&g + s&@infodir@&$infodir&g + s&@localedir@&$localedir&g + s&@mandir@&$mandir&g + s&\\\${datarootdir}&$datarootdir&g' ;; +esac +_ACEOF + +# Neutralize VPATH when `$srcdir' = `.'. +# Shell code in configure.ac might set extrasub. +# FIXME: do we really want to maintain this feature? +cat >>$CONFIG_STATUS <<_ACEOF + sed "$ac_vpsub +$extrasub +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF +:t +/@[a-zA-Z_][a-zA-Z_0-9]*@/!b +s&@configure_input@&$configure_input&;t t +s&@top_builddir@&$ac_top_builddir_sub&;t t +s&@srcdir@&$ac_srcdir&;t t +s&@abs_srcdir@&$ac_abs_srcdir&;t t +s&@top_srcdir@&$ac_top_srcdir&;t t +s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t +s&@builddir@&$ac_builddir&;t t +s&@abs_builddir@&$ac_abs_builddir&;t t +s&@abs_top_builddir@&$ac_abs_top_builddir&;t t +$ac_datarootdir_hack +" $ac_file_inputs | sed -f "$tmp/subs-1.sed" >$tmp/out + +test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && + { ac_out=`sed -n '/\${datarootdir}/p' "$tmp/out"`; test -n "$ac_out"; } && + { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' "$tmp/out"`; test -z "$ac_out"; } && + { echo "$as_me:$LINENO: WARNING: $ac_file contains a reference to the variable \`datarootdir' +which seems to be undefined. Please make sure it is defined." >&5 +echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' +which seems to be undefined. Please make sure it is defined." >&2;} + + rm -f "$tmp/stdin" + case $ac_file in + -) cat "$tmp/out"; rm -f "$tmp/out";; + *) rm -f "$ac_file"; mv "$tmp/out" $ac_file;; + esac + ;; + :H) + # + # CONFIG_HEADER + # +_ACEOF + +# Transform confdefs.h into a sed script `conftest.defines', that +# substitutes the proper values into config.h.in to produce config.h. +rm -f conftest.defines conftest.tail +# First, append a space to every undef/define line, to ease matching. +echo 's/$/ /' >conftest.defines +# Then, protect against being on the right side of a sed subst, or in +# an unquoted here document, in config.status. If some macros were +# called several times there might be several #defines for the same +# symbol, which is useless. But do not sort them, since the last +# AC_DEFINE must be honored. +ac_word_re=[_$as_cr_Letters][_$as_cr_alnum]* +# These sed commands are passed to sed as "A NAME B PARAMS C VALUE D", where +# NAME is the cpp macro being defined, VALUE is the value it is being given. +# PARAMS is the parameter list in the macro definition--in most cases, it's +# just an empty string. +ac_dA='s,^\\([ #]*\\)[^ ]*\\([ ]*' +ac_dB='\\)[ (].*,\\1define\\2' +ac_dC=' ' +ac_dD=' ,' + +uniq confdefs.h | + sed -n ' + t rset + :rset + s/^[ ]*#[ ]*define[ ][ ]*// + t ok + d + :ok + s/[\\&,]/\\&/g + s/^\('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/ '"$ac_dA"'\1'"$ac_dB"'\2'"${ac_dC}"'\3'"$ac_dD"'/p + s/^\('"$ac_word_re"'\)[ ]*\(.*\)/'"$ac_dA"'\1'"$ac_dB$ac_dC"'\2'"$ac_dD"'/p + ' >>conftest.defines + +# Remove the space that was appended to ease matching. +# Then replace #undef with comments. This is necessary, for +# example, in the case of _POSIX_SOURCE, which is predefined and required +# on some systems where configure will not decide to define it. +# (The regexp can be short, since the line contains either #define or #undef.) +echo 's/ $// +s,^[ #]*u.*,/* & */,' >>conftest.defines + +# Break up conftest.defines: +ac_max_sed_lines=50 + +# First sed command is: sed -f defines.sed $ac_file_inputs >"$tmp/out1" +# Second one is: sed -f defines.sed "$tmp/out1" >"$tmp/out2" +# Third one will be: sed -f defines.sed "$tmp/out2" >"$tmp/out1" +# et cetera. +ac_in='$ac_file_inputs' +ac_out='"$tmp/out1"' +ac_nxt='"$tmp/out2"' + +while : +do + # Write a here document: + cat >>$CONFIG_STATUS <<_ACEOF + # First, check the format of the line: + cat >"\$tmp/defines.sed" <<\\CEOF +/^[ ]*#[ ]*undef[ ][ ]*$ac_word_re[ ]*/b def +/^[ ]*#[ ]*define[ ][ ]*$ac_word_re[( ]/b def +b +:def +_ACEOF + sed ${ac_max_sed_lines}q conftest.defines >>$CONFIG_STATUS + echo 'CEOF + sed -f "$tmp/defines.sed"' "$ac_in >$ac_out" >>$CONFIG_STATUS + ac_in=$ac_out; ac_out=$ac_nxt; ac_nxt=$ac_in + sed 1,${ac_max_sed_lines}d conftest.defines >conftest.tail + grep . conftest.tail >/dev/null || break + rm -f conftest.defines + mv conftest.tail conftest.defines +done +rm -f conftest.defines conftest.tail + +echo "ac_result=$ac_in" >>$CONFIG_STATUS +cat >>$CONFIG_STATUS <<\_ACEOF + if test x"$ac_file" != x-; then + echo "/* $configure_input */" >"$tmp/config.h" + cat "$ac_result" >>"$tmp/config.h" + if diff $ac_file "$tmp/config.h" >/dev/null 2>&1; then + { echo "$as_me:$LINENO: $ac_file is unchanged" >&5 +echo "$as_me: $ac_file is unchanged" >&6;} + else + rm -f $ac_file + mv "$tmp/config.h" $ac_file + fi + else + echo "/* $configure_input */" + cat "$ac_result" + fi + rm -f "$tmp/out12" + ;; + + + esac + +done # for ac_tag + + +{ (exit 0); exit 0; } +_ACEOF +chmod +x $CONFIG_STATUS +ac_clean_files=$ac_clean_files_save + + +# configure is writing to config.log, and then calls config.status. +# config.status does its own redirection, appending to config.log. +# Unfortunately, on DOS this fails, as config.log is still kept open +# by configure, so config.status won't be able to write to it; its +# output is simply discarded. So we exec the FD to /dev/null, +# effectively closing config.log, so it can be properly (re)opened and +# appended to by config.status. When coming back to configure, we +# need to make the FD available again. +if test "$no_create" != yes; then + ac_cs_success=: + ac_config_status_args= + test "$silent" = yes && + ac_config_status_args="$ac_config_status_args --quiet" + exec 5>/dev/null + $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false + exec 5>>config.log + # Use ||, not &&, to avoid exiting from the if with $? = 1, which + # would make configure fail if this is the last instruction. + $ac_cs_success || { (exit 1); exit 1; } +fi + diff --git a/configure.ac b/configure.ac new file mode 100644 --- /dev/null +++ b/configure.ac @@ -0,0 +1,176 @@ +AC_INIT([Haskell network package], [2.3.0.11], [libraries@haskell.org], [network]) + +ac_includes_default="$ac_includes_default +#ifdef HAVE_NETDB_H +# include +#endif +#ifdef HAVE_WINSOCK2_H +# include +#endif +#ifdef HAVE_WS2TCPIP_H +# include +// fix for MingW not defining IPV6_V6ONLY +# define IPV6_V6ONLY 27 +#endif +#ifdef HAVE_WSPIAPI_H +# include +#endif" + +# Safety check: Ensure that we are in the correct source directory. +AC_CONFIG_SRCDIR([include/HsNet.h]) + +AC_CONFIG_HEADERS([include/HsNetworkConfig.h]) + +AC_CANONICAL_HOST + +AC_ARG_WITH([cc], + [C compiler], + [CC=$withval]) +AC_PROG_CC() + +AC_C_CONST + +dnl ** check for specific header (.h) files that we are interested in +AC_CHECK_HEADERS([fcntl.h limits.h stdlib.h sys/types.h unistd.h winsock2.h ws2tcpip.h wspiapi.h]) +AC_CHECK_HEADERS([arpa/inet.h netdb.h netinet/in.h netinet/tcp.h sys/socket.h sys/uio.h sys/un.h]) + +AC_CHECK_FUNCS([readlink symlink]) + +dnl ** check what fields struct msghdr contains +AC_CHECK_MEMBERS([struct msghdr.msg_control, struct msghdr.msg_accrights], [], [], [#if HAVE_SYS_TYPES_H +# include +#endif +#if HAVE_SYS_SOCKET_H +# include +#endif +#if HAVE_SYS_UIO_H +# include +#endif]) + +dnl ** check if struct sockaddr contains sa_len +AC_CHECK_MEMBERS([struct sockaddr.sa_len], [], [], [#if HAVE_SYS_TYPES_H +# include +#endif +#if HAVE_SYS_SOCKET_H +# include +#endif]) + +dnl -------------------------------------------------- +dnl * test for in_addr_t +dnl -------------------------------------------------- +AC_MSG_CHECKING(for in_addr_t in netinet/in.h) +AC_EGREP_HEADER(in_addr_t, netinet/in.h, + [ AC_DEFINE([HAVE_IN_ADDR_T], [1], [Define to 1 if in_addr_t is available.]) AC_MSG_RESULT(yes) ], + AC_MSG_RESULT(no)) + +dnl -------------------------------------------------- +dnl * test for SO_PEERCRED and struct ucred +dnl -------------------------------------------------- +AC_MSG_CHECKING(for SO_PEERCRED and struct ucred in sys/socket.h) +AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include +#include +#ifndef SO_PEERCRED +# error no SO_PEERCRED +#endif +struct ucred u;]])],ac_cv_ucred=yes,ac_cv_ucred=no) +if test "x$ac_cv_ucred" = xno; then + old_CFLAGS="$CFLAGS" + CFLAGS="-D_GNU_SOURCE $CFLAGS" + AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include +#include +#ifndef SO_PEERCRED +# error no SO_PEERCRED +#endif +struct ucred u;]])],ac_cv_ucred=yes,ac_cv_ucred=no) + if test "x$ac_cv_ucred" = xyes; then + EXTRA_CPPFLAGS=-D_GNU_SOURCE + fi +else + old_CFLAGS="$CFLAGS" +fi +if test "x$ac_cv_ucred" = xno; then + CFLAGS="$old_CFLAGS" + AC_MSG_RESULT(no) +else + AC_DEFINE([HAVE_STRUCT_UCRED], [1], [Define to 1 if you have both SO_PEERCRED and struct ucred.]) + AC_MSG_RESULT(yes) +fi + +dnl -------------------------------------------------- +dnl * check for Windows networking libraries +dnl -------------------------------------------------- +AC_CHECK_LIB(ws2_32, _head_libws2_32_a) + +dnl -------------------------------------------------- +dnl * test for getaddrinfo as proxy for IPv6 support +dnl -------------------------------------------------- +AC_MSG_CHECKING(for getaddrinfo) +dnl Can't use AC_CHECK_FUNC here, because it doesn't do the right +dnl thing on Windows. +AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[$ac_includes_default +int testme(){ getaddrinfo; }]])],[AC_DEFINE([HAVE_GETADDRINFO], [1], [Define to 1 if you have the `getaddrinfo' function.]) ac_have_getaddrinfo=yes; AC_MSG_RESULT(yes)],[AC_MSG_RESULT(no)]) + +dnl Under mingw, we may need to set WINVER to 0x0501 to expose getaddrinfo. +if test "x$ac_have_getaddrinfo" = x; then + old_CFLAGS="$CFLAGS" + if test "z$ac_cv_lib_ws2_32__head_libws2_32_a" = zyes; then + CFLAGS="-DWINVER=0x0501 $CFLAGS" + AC_MSG_CHECKING(for getaddrinfo if WINVER is 0x0501) + AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[$ac_includes_default + int testme(){ getaddrinfo; }]])],[AC_DEFINE([HAVE_GETADDRINFO], [1], [Define to 1 if you have the `getaddrinfo' function.]) AC_DEFINE([NEED_WINVER_XP], [1], [Define to 1 if the `getaddrinfo' function needs WINVER set.]) EXTRA_CPPFLAGS="-DWINVER=0x0501 $EXTRA_CPPFLAGS"; AC_MSG_RESULT(yes)],[CFLAGS="$old_CFLAGS"; AC_MSG_RESULT(no)]) + fi +fi + +dnl Missing under mingw, sigh. +AC_CHECK_FUNCS(gai_strerror) + +dnl ------------------------------------------------------- +dnl * test for AI_* flags that not all implementations have +dnl ------------------------------------------------------- +AC_CHECK_DECLS([AI_ADDRCONFIG, AI_ALL, AI_NUMERICSERV, AI_V4MAPPED]) + +dnl ------------------------------------------------------- +dnl * test for IPV6_V6ONLY flags that not all implementations have +dnl ------------------------------------------------------- +AC_CHECK_DECLS([IPV6_V6ONLY]) + +dnl -------------------------------------------------- +dnl * test for Linux sendfile(2) +dnl -------------------------------------------------- +AC_MSG_CHECKING(for sendfile in sys/sendfile.h) +AC_EGREP_HEADER(sendfile, sys/sendfile.h, + [ AC_DEFINE([HAVE_LINUX_SENDFILE], [1], [Define to 1 if you have a Linux sendfile(2) implementation.]) AC_MSG_RESULT(yes) ], + AC_MSG_RESULT(no)) + +dnl -------------------------------------------------- +dnl * test for BSD sendfile(2) +dnl -------------------------------------------------- +AC_MSG_CHECKING(for sendfile in sys/socket.h) +AC_EGREP_HEADER(sendfile, sys/socket.h, + [ AC_DEFINE([HAVE_BSD_SENDFILE], [1], [Define to 1 if you have a BSDish sendfile(2) implementation.]) AC_MSG_RESULT(yes) ], + AC_MSG_RESULT(no)) + +AC_CHECK_FUNCS(gethostent) + +case "$host" in +*-mingw32) + EXTRA_SRCS="cbits/initWinSock.c, cbits/winSockErr.c, cbits/asyncAccept.c" + EXTRA_LIBS=ws2_32 + CALLCONV=stdcall ;; +*-solaris2*) + EXTRA_SRCS="cbits/ancilData.c" + EXTRA_LIBS="nsl, socket" + CALLCONV=ccall ;; +*) + EXTRA_SRCS="cbits/ancilData.c" + EXTRA_LIBS= + CALLCONV=ccall ;; +esac +AC_SUBST([CALLCONV]) +AC_SUBST([EXTRA_CPPFLAGS]) +AC_SUBST([EXTRA_LIBS]) +AC_SUBST([EXTRA_SRCS]) + +AC_CONFIG_FILES([network.buildinfo]) + +AC_OUTPUT diff --git a/include/HsNet.h b/include/HsNet.h new file mode 100644 --- /dev/null +++ b/include/HsNet.h @@ -0,0 +1,195 @@ +/* ----------------------------------------------------------------------------- + * + * Definitions for package `net' which are visible in Haskell land. + * + * ---------------------------------------------------------------------------*/ + +#ifndef HSNET_H +#define HSNET_H + +#include "HsNetworkConfig.h" + +#ifdef NEED_WINVER +# define WINVER 0x0501 +#endif + +/* ultra-evil... */ +#undef PACKAGE_BUGREPORT +#undef PACKAGE_NAME +#undef PACKAGE_STRING +#undef PACKAGE_TARNAME +#undef PACKAGE_VERSION + +#ifndef INLINE +# if defined(_MSC_VER) +# define INLINE extern __inline +# elif defined(__GNUC__) +# define INLINE extern inline +# else +# define INLINE inline +# endif +#endif + +#ifdef HAVE_GETADDRINFO +# define IPV6_SOCKET_SUPPORT 1 +#else +# undef IPV6_SOCKET_SUPPORT +#endif + +#if defined(HAVE_WINSOCK2_H) && !defined(__CYGWIN__) +#include +# ifdef HAVE_WS2TCPIP_H +# include +// fix for MingW not defining IPV6_V6ONLY +# define IPV6_V6ONLY 27 +# endif +# ifdef HAVE_WSPIAPI_H +# include +# endif + +extern void shutdownWinSock(); +extern int initWinSock (); +extern const char* getWSErrorDescr(int err); + +# if !defined(__HUGS__) +extern void* newAcceptParams(int sock, + int sz, + void* sockaddr); +extern int acceptNewSock(void* d); +extern int acceptDoProc(void* param); +# endif + +#else + +#ifdef HAVE_LIMITS_H +# include +#endif +#ifdef HAVE_STDLIB_H +# include +#endif +#ifdef HAVE_UNISTD_H +#include +#endif +#ifdef HAVE_SYS_TYPES_H +# include +#endif +#ifdef HAVE_FCNTL_H +# include +#endif +#ifdef HAVE_SYS_UIO_H +# include +#endif +#ifdef HAVE_SYS_SOCKET_H +# include +#endif +#ifdef HAVE_NETINET_TCP_H +# include +#endif +#ifdef HAVE_NETINET_IN_H +# include +#endif +#ifdef HAVE_SYS_UN_H +# include +#endif +#ifdef HAVE_ARPA_INET_H +# include +#endif +#ifdef HAVE_NETDB_H +#include +#endif + +#ifdef HAVE_BSD_SENDFILE +#include +#endif +#ifdef HAVE_LINUX_SENDFILE +#if !defined(__USE_FILE_OFFSET64) +#include +#endif +#endif + +extern int +sendFd(int sock, int outfd); + +extern int +recvFd(int sock); + +/* The next two are scheduled for deletion */ +extern int +sendAncillary(int sock, + int level, + int type, + int flags, + void* data, + int len); + +extern int +recvAncillary(int sock, + int* pLevel, + int* pType, + int flags, + void** pData, + int* pLen); + +#endif /* HAVE_WINSOCK2_H && !__CYGWIN */ + +INLINE char * +my_inet_ntoa( +#if defined(HAVE_WINSOCK2_H) + u_long addr +#elif defined(HAVE_IN_ADDR_T) + in_addr_t addr +#elif defined(HAVE_INTTYPES_H) + u_int32_t addr +#else + unsigned long addr +#endif + ) +{ + struct in_addr a; + a.s_addr = addr; + return inet_ntoa(a); +} + +#ifdef HAVE_GETADDRINFO +INLINE int +hsnet_getnameinfo(const struct sockaddr* a,socklen_t b, char* c, +# if defined(HAVE_WINSOCK2_H) && !defined(__CYGWIN__) + DWORD d, char* e, DWORD f, int g) +# else + socklen_t d, char* e, socklen_t f, int g) +# endif +{ + return getnameinfo(a,b,c,d,e,f,g); +} + +INLINE int +hsnet_getaddrinfo(const char *hostname, const char *servname, + const struct addrinfo *hints, struct addrinfo **res) +{ + return getaddrinfo(hostname, servname, hints, res); +} + +INLINE void +hsnet_freeaddrinfo(struct addrinfo *ai) +{ + freeaddrinfo(ai); +} +#endif + +#if defined(HAVE_WINSOCK2_H) && !defined(cygwin32_HOST_OS) +# define WITH_WINSOCK 1 +#endif + +#if !defined(mingw32_HOST_OS) && !defined(_WIN32) +# define DOMAIN_SOCKET_SUPPORT 1 +#endif + +#if !defined(CALLCONV) +# if defined(WITH_WINSOCK) +# define CALLCONV stdcall +# else +# define CALLCONV ccall +# endif +#endif + +#endif /* HSNET_H */ diff --git a/include/HsNetworkConfig.h.in b/include/HsNetworkConfig.h.in new file mode 100644 --- /dev/null +++ b/include/HsNetworkConfig.h.in @@ -0,0 +1,147 @@ +/* include/HsNetworkConfig.h.in. Generated from configure.ac by autoheader. */ + +/* Define to 1 if you have the header file. */ +#undef HAVE_ARPA_INET_H + +/* Define to 1 if you have a BSDish sendfile(2) implementation. */ +#undef HAVE_BSD_SENDFILE + +/* Define to 1 if you have the declaration of `AI_ADDRCONFIG', and to 0 if you + don't. */ +#undef HAVE_DECL_AI_ADDRCONFIG + +/* Define to 1 if you have the declaration of `AI_ALL', and to 0 if you don't. + */ +#undef HAVE_DECL_AI_ALL + +/* Define to 1 if you have the declaration of `AI_NUMERICSERV', and to 0 if + you don't. */ +#undef HAVE_DECL_AI_NUMERICSERV + +/* Define to 1 if you have the declaration of `AI_V4MAPPED', and to 0 if you + don't. */ +#undef HAVE_DECL_AI_V4MAPPED + +/* Define to 1 if you have the declaration of `IPV6_V6ONLY', and to 0 if you + don't. */ +#undef HAVE_DECL_IPV6_V6ONLY + +/* Define to 1 if you have the header file. */ +#undef HAVE_FCNTL_H + +/* Define to 1 if you have the `gai_strerror' function. */ +#undef HAVE_GAI_STRERROR + +/* Define to 1 if you have the `getaddrinfo' function. */ +#undef HAVE_GETADDRINFO + +/* Define to 1 if you have the `gethostent' function. */ +#undef HAVE_GETHOSTENT + +/* Define to 1 if you have the header file. */ +#undef HAVE_INTTYPES_H + +/* Define to 1 if in_addr_t is available. */ +#undef HAVE_IN_ADDR_T + +/* Define to 1 if you have the `ws2_32' library (-lws2_32). */ +#undef HAVE_LIBWS2_32 + +/* Define to 1 if you have the header file. */ +#undef HAVE_LIMITS_H + +/* Define to 1 if you have a Linux sendfile(2) implementation. */ +#undef HAVE_LINUX_SENDFILE + +/* Define to 1 if you have the header file. */ +#undef HAVE_MEMORY_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_NETDB_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_NETINET_IN_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_NETINET_TCP_H + +/* Define to 1 if you have the `readlink' function. */ +#undef HAVE_READLINK + +/* Define to 1 if you have the header file. */ +#undef HAVE_STDINT_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_STDLIB_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_STRINGS_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_STRING_H + +/* Define to 1 if `msg_accrights' is member of `struct msghdr'. */ +#undef HAVE_STRUCT_MSGHDR_MSG_ACCRIGHTS + +/* Define to 1 if `msg_control' is member of `struct msghdr'. */ +#undef HAVE_STRUCT_MSGHDR_MSG_CONTROL + +/* Define to 1 if `sa_len' is member of `struct sockaddr'. */ +#undef HAVE_STRUCT_SOCKADDR_SA_LEN + +/* Define to 1 if you have both SO_PEERCRED and struct ucred. */ +#undef HAVE_STRUCT_UCRED + +/* Define to 1 if you have the `symlink' function. */ +#undef HAVE_SYMLINK + +/* Define to 1 if you have the header file. */ +#undef HAVE_SYS_SOCKET_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_SYS_STAT_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_SYS_TYPES_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_SYS_UIO_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_SYS_UN_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_UNISTD_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_WINSOCK2_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_WS2TCPIP_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_WSPIAPI_H + +/* Define to 1 if the `getaddrinfo' function needs WINVER set. */ +#undef NEED_WINVER_XP + +/* Define to the address where bug reports for this package should be sent. */ +#undef PACKAGE_BUGREPORT + +/* Define to the full name of this package. */ +#undef PACKAGE_NAME + +/* Define to the full name and version of this package. */ +#undef PACKAGE_STRING + +/* Define to the one symbol short name of this package. */ +#undef PACKAGE_TARNAME + +/* Define to the version of this package. */ +#undef PACKAGE_VERSION + +/* Define to 1 if you have the ANSI C header files. */ +#undef STDC_HEADERS + +/* Define to empty if `const' does not conform to ANSI C. */ +#undef const diff --git a/install-sh b/install-sh new file mode 100644 --- /dev/null +++ b/install-sh @@ -0,0 +1,295 @@ +#!/bin/sh +# install - install a program, script, or datafile + +scriptversion=2003-09-24.23 + +# This originates from X11R5 (mit/util/scripts/install.sh), which was +# later released in X11R6 (xc/config/util/install.sh) with the +# following copyright and license. +# +# Copyright (C) 1994 X Consortium +# +# Permission is hereby granted, free of charge, to any person obtaining a copy +# of this software and associated documentation files (the "Software"), to +# deal in the Software without restriction, including without limitation the +# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +# sell copies of the Software, and to permit persons to whom the Software is +# furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +# X CONSORTIUM BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN +# AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNEC- +# TION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +# +# Except as contained in this notice, the name of the X Consortium shall not +# be used in advertising or otherwise to promote the sale, use or other deal- +# ings in this Software without prior written authorization from the X Consor- +# tium. +# +# +# FSF changes to this file are in the public domain. +# +# Calling this script install-sh is preferred over install.sh, to prevent +# `make' implicit rules from creating a file called install from it +# when there is no Makefile. +# +# This script is compatible with the BSD install script, but was written +# from scratch. It can only install one file at a time, a restriction +# shared with many OS's install programs. + +# set DOITPROG to echo to test this script + +# Don't use :- since 4.3BSD and earlier shells don't like it. +doit="${DOITPROG-}" + +# put in absolute paths if you don't have them in your path; or use env. vars. + +mvprog="${MVPROG-mv}" +cpprog="${CPPROG-cp}" +chmodprog="${CHMODPROG-chmod}" +chownprog="${CHOWNPROG-chown}" +chgrpprog="${CHGRPPROG-chgrp}" +stripprog="${STRIPPROG-strip}" +rmprog="${RMPROG-rm}" +mkdirprog="${MKDIRPROG-mkdir}" + +transformbasename= +transform_arg= +instcmd="$mvprog" +chmodcmd="$chmodprog 0755" +chowncmd= +chgrpcmd= +stripcmd= +rmcmd="$rmprog -f" +mvcmd="$mvprog" +src= +dst= +dir_arg= + +usage="Usage: $0 [OPTION]... SRCFILE DSTFILE + or: $0 -d DIR1 DIR2... + +In the first form, install SRCFILE to DSTFILE, removing SRCFILE by default. +In the second, create the directory path DIR. + +Options: +-b=TRANSFORMBASENAME +-c copy source (using $cpprog) instead of moving (using $mvprog). +-d create directories instead of installing files. +-g GROUP $chgrp installed files to GROUP. +-m MODE $chmod installed files to MODE. +-o USER $chown installed files to USER. +-s strip installed files (using $stripprog). +-t=TRANSFORM +--help display this help and exit. +--version display version info and exit. + +Environment variables override the default commands: + CHGRPPROG CHMODPROG CHOWNPROG CPPROG MKDIRPROG MVPROG RMPROG STRIPPROG +" + +while test -n "$1"; do + case $1 in + -b=*) transformbasename=`echo $1 | sed 's/-b=//'` + shift + continue;; + + -c) instcmd=$cpprog + shift + continue;; + + -d) dir_arg=true + shift + continue;; + + -g) chgrpcmd="$chgrpprog $2" + shift + shift + continue;; + + --help) echo "$usage"; exit 0;; + + -m) chmodcmd="$chmodprog $2" + shift + shift + continue;; + + -o) chowncmd="$chownprog $2" + shift + shift + continue;; + + -s) stripcmd=$stripprog + shift + continue;; + + -t=*) transformarg=`echo $1 | sed 's/-t=//'` + shift + continue;; + + --version) echo "$0 $scriptversion"; exit 0;; + + *) if test -z "$src"; then + src=$1 + else + # this colon is to work around a 386BSD /bin/sh bug + : + dst=$1 + fi + shift + continue;; + esac +done + +if test -z "$src"; then + echo "$0: no input file specified." >&2 + exit 1 +fi + +# Protect names starting with `-'. +case $src in + -*) src=./$src ;; +esac + +if test -n "$dir_arg"; then + dst=$src + src= + + if test -d "$dst"; then + instcmd=: + chmodcmd= + else + instcmd=$mkdirprog + fi +else + # Waiting for this to be detected by the "$instcmd $src $dsttmp" command + # might cause directories to be created, which would be especially bad + # if $src (and thus $dsttmp) contains '*'. + if test ! -f "$src" && test ! -d "$src"; then + echo "$0: $src does not exist." >&2 + exit 1 + fi + + if test -z "$dst"; then + echo "$0: no destination specified." >&2 + exit 1 + fi + + # Protect names starting with `-'. + case $dst in + -*) dst=./$dst ;; + esac + + # If destination is a directory, append the input filename; won't work + # if double slashes aren't ignored. + if test -d "$dst"; then + dst=$dst/`basename "$src"` + fi +fi + +# This sed command emulates the dirname command. +dstdir=`echo "$dst" | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'` + +# Make sure that the destination directory exists. + +# Skip lots of stat calls in the usual case. +if test ! -d "$dstdir"; then + defaultIFS=' + ' + IFS="${IFS-$defaultIFS}" + + oIFS=$IFS + # Some sh's can't handle IFS=/ for some reason. + IFS='%' + set - `echo "$dstdir" | sed -e 's@/@%@g' -e 's@^%@/@'` + IFS=$oIFS + + pathcomp= + + while test $# -ne 0 ; do + pathcomp=$pathcomp$1 + shift + test -d "$pathcomp" || $mkdirprog "$pathcomp" + pathcomp=$pathcomp/ + done +fi + +if test -n "$dir_arg"; then + $doit $instcmd "$dst" \ + && { test -z "$chowncmd" || $doit $chowncmd "$dst"; } \ + && { test -z "$chgrpcmd" || $doit $chgrpcmd "$dst"; } \ + && { test -z "$stripcmd" || $doit $stripcmd "$dst"; } \ + && { test -z "$chmodcmd" || $doit $chmodcmd "$dst"; } + +else + # If we're going to rename the final executable, determine the name now. + if test -z "$transformarg"; then + dstfile=`basename "$dst"` + else + dstfile=`basename "$dst" $transformbasename \ + | sed $transformarg`$transformbasename + fi + + # don't allow the sed command to completely eliminate the filename. + test -z "$dstfile" && dstfile=`basename "$dst"` + + # Make a couple of temp file names in the proper directory. + dsttmp=$dstdir/_inst.$$_ + rmtmp=$dstdir/_rm.$$_ + + # Trap to clean up those temp files at exit. + trap 'status=$?; rm -f "$dsttmp" "$rmtmp" && exit $status' 0 + trap '(exit $?); exit' 1 2 13 15 + + # Move or copy the file name to the temp name + $doit $instcmd "$src" "$dsttmp" && + + # and set any options; do chmod last to preserve setuid bits. + # + # If any of these fail, we abort the whole thing. If we want to + # ignore errors from any of these, just make sure not to ignore + # errors from the above "$doit $instcmd $src $dsttmp" command. + # + { test -z "$chowncmd" || $doit $chowncmd "$dsttmp"; } \ + && { test -z "$chgrpcmd" || $doit $chgrpcmd "$dsttmp"; } \ + && { test -z "$stripcmd" || $doit $stripcmd "$dsttmp"; } \ + && { test -z "$chmodcmd" || $doit $chmodcmd "$dsttmp"; } && + + # Now remove or move aside any old file at destination location. We + # try this two ways since rm can't unlink itself on some systems and + # the destination file might be busy for other reasons. In this case, + # the final cleanup might fail but the new file should still install + # successfully. + { + if test -f "$dstdir/$dstfile"; then + $doit $rmcmd -f "$dstdir/$dstfile" 2>/dev/null \ + || $doit $mvcmd -f "$dstdir/$dstfile" "$rmtmp" 2>/dev/null \ + || { + echo "$0: cannot unlink or rename $dstdir/$dstfile" >&2 + (exit 1); exit + } + else + : + fi + } && + + # Now rename the file to the real destination. + $doit $mvcmd "$dsttmp" "$dstdir/$dstfile" +fi && + +# The final little trick to "correctly" pass the exit status to the exit trap. +{ + (exit 0); exit +} + +# Local variables: +# eval: (add-hook 'write-file-hooks 'time-stamp) +# time-stamp-start: "scriptversion=" +# time-stamp-format: "%:y-%02m-%02d.%02H" +# time-stamp-end: "$" +# End: diff --git a/network.buildinfo.in b/network.buildinfo.in new file mode 100644 --- /dev/null +++ b/network.buildinfo.in @@ -0,0 +1,5 @@ +executable: cabal +ghc-options: -DCALLCONV=@CALLCONV@ @EXTRA_CPPFLAGS@ +cc-options: -DCALLCONV=@CALLCONV@ @EXTRA_CPPFLAGS@ +c-sources: @EXTRA_SRCS@ +extra-libraries: @EXTRA_LIBS@