haskell/stackage
1
0
Fork 0
mirror of https://github.com/commercialhaskell/stackage.git synced 2026-01-12 07:18:31 +01:00
Code Issues Actions 1 Packages Projects Releases Wiki Activity

Patches to close #202 #203 #206

Browse Source
This commit is contained in:
Michael Snoyman 2014-04-03 08:33:32 +03:00
parent b9dfbd45f0
commit 5d3b6d2d4f
9 changed files with 815 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
Stackage/Config.hs
View File

@ -356,33 +356,12 @@ defaultStablePackages ghcVer requireHP = unPackageMap $ execWriter $ do
-- https://github.com/fpco/stackage/issues/200
addRange "Michael Snoyman" "hspec" "< 1.9"
-- https://github.com/fpco/stackage/issues/202
addRange "Michael Snoyman" "case-insensitive" "< 1.2"
addRange "Michael Snoyman" "xml-conduit" "< 1.2"
-- https://github.com/fpco/stackage/issues/203
addRange "Michael Snoyman" "exceptions" "< 0.4"
-- https://github.com/fpco/stackage/issues/204
addRange "Michael Snoyman" "intervals" "< 0.5"
-- https://github.com/fpco/stackage/issues/205
addRange "Michael Snoyman" "hastache" "< 0.6"
-- https://github.com/fpco/stackage/issues/206
addRange "Michael Snoyman" "conduit" "< 1.1"
addRange "Michael Snoyman" "conduit-extra" "< 1.1"
addRange "Michael Snoyman" "attoparsec-conduit" "< 1.1"
addRange "Michael Snoyman" "resourcet" "< 1.1"
addRange "Michael Snoyman" "blaze-builder-conduit" "< 1.1"
addRange "Michael Snoyman" "zlib-conduit" "< 1.1"
addRange "Michael Snoyman" "network-conduit" "< 1.1"
addRange "Michael Snoyman" "network-conduit-tls" "< 1.1"
addRange "Michael Snoyman" "http-conduit" "< 2.1"
addRange "Michael Snoyman" "http-client" "< 0.3"
addRange "Michael Snoyman" "http-client-conduit" "< 0.3"
addRange "Michael Snoyman" "http-client-multipart" "< 0.3"
-- https://github.com/ozataman/csv-conduit/issues/10
addRange "Michael Snoyman" "csv-conduit" "< 0.6.2 || > 0.6.2"

633
patching/patches/aws-0.8.5.patch
View File

@ -1,14 +1,635 @@
diff -ru orig/Aws/Aws.hs new/Aws/Aws.hs
--- orig/Aws/Aws.hs 2014-04-03 08:17:21.058394778 +0300
+++ new/Aws/Aws.hs 2014-04-03 08:17:20.000000000 +0300
@@ -33,7 +33,6 @@
import Control.Monad.IO.Class
import Control.Monad.Trans
import Control.Monad.Trans.Resource
-import Data.Attempt (Attempt(Success, Failure))
import qualified Data.ByteString as B
import qualified Data.CaseInsensitive as CI
import qualified Data.Conduit as C
@@ -185,11 +184,8 @@
unsafeAws cfg scfg manager request = do
metadataRef <- liftIO $ newIORef mempty
- let catchAll :: ResourceT IO a -> ResourceT IO (Attempt a)
- catchAll = E.handle (return . failure') . fmap Success
-
- failure' :: E.SomeException -> Attempt a
- failure' = Failure
+ let catchAll :: ResourceT IO a -> ResourceT IO (Either E.SomeException a)
+ catchAll = E.handle (return . Left) . fmap Right
resp <- catchAll $
unsafeAwsRef cfg scfg manager metadataRef request
@@ -268,8 +264,8 @@
where go request = do resp <- lift $ aws cfg scfg manager request
C.yield resp
case responseResult resp of
- Failure _ -> return ()
- Success x ->
+ Left _ -> return ()
+ Right x ->
case nextIteratedRequest request x of
Nothing -> return ()
Just nextRequest -> go nextRequest
diff -ru orig/Aws/Core.hs new/Aws/Core.hs
--- orig/Aws/Core.hs 2014-04-03 08:17:21.058394778 +0300
+++ new/Aws/Core.hs 2014-04-03 08:17:20.000000000 +0300
@@ -89,13 +89,12 @@
import Control.Applicative
import Control.Arrow
import qualified Control.Exception as E
-import qualified Control.Failure as F
import Control.Monad
import Control.Monad.IO.Class
+import Control.Monad.Trans.Resource (ResourceT, MonadThrow (throwM))
import qualified Crypto.Classes as Crypto
import qualified Crypto.HMAC as HMAC
import Crypto.Hash.CryptoAPI (MD5, SHA1, SHA256, hash')
-import Data.Attempt (Attempt(..), FromAttempt(..))
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Base16 as Base16
@@ -104,7 +103,7 @@
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.UTF8 as BU
import Data.Char
-import Data.Conduit (ResourceT, ($$+-))
+import Data.Conduit (($$+-))
import qualified Data.Conduit as C
import qualified Data.Conduit.List as CL
import Data.Default (def)
@@ -137,12 +136,12 @@
--
-- Response forms a Writer-like monad.
data Response m a = Response { responseMetadata :: m
- , responseResult :: Attempt a }
+ , responseResult :: Either E.SomeException a }
deriving (Show, Functor)
-- | Read a response result (if it's a success response, fail otherwise).
-readResponse :: FromAttempt f => Response m a -> f a
-readResponse = fromAttempt . responseResult
+readResponse :: MonadThrow n => Response m a -> n a
+readResponse = either throwM return . responseResult
-- | Read a response result (if it's a success response, fail otherwise). In MonadIO.
readResponseIO :: MonadIO io => Response m a -> io a
@@ -159,13 +158,13 @@
--multiResponse :: Monoid m => Response m a -> Response [m] a ->
instance Monoid m => Monad (Response m) where
- return x = Response mempty (Success x)
- Response m1 (Failure e) >>= _ = Response m1 (Failure e)
- Response m1 (Success x) >>= f = let Response m2 y = f x
+ return x = Response mempty (Right x)
+ Response m1 (Left e) >>= _ = Response m1 (Left e)
+ Response m1 (Right x) >>= f = let Response m2 y = f x
in Response (m1 `mappend` m2) y -- currently using First-semantics, Last SHOULD work too
-instance (Monoid m, E.Exception e) => F.Failure e (Response m) where
- failure e = Response mempty (F.failure e)
+instance Monoid m => MonadThrow (Response m) where
+ throwM e = Response mempty (throwM e)
-- | Add metadata to an 'IORef' (using 'mappend').
tellMetadataRef :: Monoid m => IORef m -> m -> IO ()
@@ -696,24 +695,24 @@
elCont name = laxElement name &/ content &| T.unpack
-- | Extract the first element from a parser result list, and throw an 'XmlException' if the list is empty.
-force :: F.Failure XmlException m => String -> [a] -> m a
+force :: MonadThrow m => String -> [a] -> m a
force = Cu.force . XmlException
-- | Extract the first element from a monadic parser result list, and throw an 'XmlException' if the list is empty.
-forceM :: F.Failure XmlException m => String -> [m a] -> m a
+forceM :: MonadThrow m => String -> [m a] -> m a
forceM = Cu.forceM . XmlException
-- | Read an integer from a 'T.Text', throwing an 'XmlException' on failure.
-textReadInt :: (F.Failure XmlException m, Num a) => T.Text -> m a
+textReadInt :: (MonadThrow m, Num a) => T.Text -> m a
textReadInt s = case reads $ T.unpack s of
[(n,"")] -> return $ fromInteger n
- _ -> F.failure $ XmlException "Invalid Integer"
+ _ -> throwM $ XmlException "Invalid Integer"
-- | Read an integer from a 'String', throwing an 'XmlException' on failure.
-readInt :: (F.Failure XmlException m, Num a) => String -> m a
+readInt :: (MonadThrow m, Num a) => String -> m a
readInt s = case reads s of
[(n,"")] -> return $ fromInteger n
- _ -> F.failure $ XmlException "Invalid Integer"
+ _ -> throwM $ XmlException "Invalid Integer"
-- | Create a complete 'HTTPResponseConsumer' from a simple function that takes a 'Cu.Cursor' to XML in the response
-- body.
@@ -731,5 +730,5 @@
let Response metadata x = parse cursor
liftIO $ tellMetadataRef metadataRef metadata
case x of
- Failure err -> liftIO $ C.monadThrow err
- Success v -> return v
+ Left err -> liftIO $ throwM err
+ Right v -> return v
diff -ru orig/Aws/DynamoDb/Core.hs new/Aws/DynamoDb/Core.hs
--- orig/Aws/DynamoDb/Core.hs 2014-04-03 08:17:21.062394778 +0300
+++ new/Aws/DynamoDb/Core.hs 2014-04-03 08:17:20.000000000 +0300
@@ -2,6 +2,7 @@
import Aws.Core
import qualified Control.Exception as C
+import Control.Monad.Trans.Resource (throwM)
import Crypto.Hash.CryptoAPI (SHA256, hash)
import qualified Data.Aeson as A
import qualified Data.ByteString as B
@@ -125,5 +126,5 @@
(HTTP.Status{HTTP.statusCode=200}) -> do
case A.fromJSON val of
A.Success a -> return a
- A.Error err -> monadThrow $ DyError (HTTP.responseStatus resp) "" err
- _ -> monadThrow $ DyError (HTTP.responseStatus resp) "" (show val)
+ A.Error err -> throwM $ DyError (HTTP.responseStatus resp) "" err
+ _ -> throwM $ DyError (HTTP.responseStatus resp) "" (show val)
diff -ru orig/Aws/Ec2/InstanceMetadata.hs new/Aws/Ec2/InstanceMetadata.hs
--- orig/Aws/Ec2/InstanceMetadata.hs 2014-04-03 08:17:21.062394778 +0300
+++ new/Aws/Ec2/InstanceMetadata.hs 2014-04-03 08:17:20.000000000 +0300
@@ -2,8 +2,7 @@
import Control.Applicative
import Control.Exception
-import Control.Failure
-import Control.Monad.Trans.Resource
+import Control.Monad.Trans.Resource (throwM)
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as B8
import Data.ByteString.Lazy.UTF8 as BU
@@ -16,19 +15,19 @@
instance Exception InstanceMetadataException
-getInstanceMetadata :: HTTP.Manager -> String -> String -> ResIO L.ByteString
+getInstanceMetadata :: HTTP.Manager -> String -> String -> IO L.ByteString
getInstanceMetadata mgr p x = do req <- HTTP.parseUrl ("http://169.254.169.254/" ++ p ++ '/' : x)
HTTP.responseBody <$> HTTP.httpLbs req mgr
-getInstanceMetadataListing :: HTTP.Manager -> String -> ResIO [String]
+getInstanceMetadataListing :: HTTP.Manager -> String -> IO [String]
getInstanceMetadataListing mgr p = map BU.toString . B8.split '\n' <$> getInstanceMetadata mgr p ""
-getInstanceMetadataFirst :: HTTP.Manager -> String -> ResIO L.ByteString
+getInstanceMetadataFirst :: HTTP.Manager -> String -> IO L.ByteString
getInstanceMetadataFirst mgr p = do listing <- getInstanceMetadataListing mgr p
case listing of
- [] -> failure (MetadataNotFound p)
+ [] -> throwM (MetadataNotFound p)
(x:_) -> getInstanceMetadata mgr p x
-getInstanceMetadataOrFirst :: HTTP.Manager -> String -> Maybe String -> ResIO L.ByteString
+getInstanceMetadataOrFirst :: HTTP.Manager -> String -> Maybe String -> IO L.ByteString
getInstanceMetadataOrFirst mgr p (Just x) = getInstanceMetadata mgr p x
getInstanceMetadataOrFirst mgr p Nothing = getInstanceMetadataFirst mgr p
diff -ru orig/Aws/Iam/Core.hs new/Aws/Iam/Core.hs
--- orig/Aws/Iam/Core.hs 2014-04-03 08:17:21.062394778 +0300
+++ new/Aws/Iam/Core.hs 2014-04-03 08:17:20.000000000 +0300
@@ -19,8 +19,8 @@
import qualified Blaze.ByteString.Builder as Blaze
import qualified Blaze.ByteString.Builder.Char8 as Blaze8
import Control.Exception (Exception)
-import qualified Control.Failure as F
import Control.Monad
+import Control.Monad.Trans.Resource (MonadThrow, throwM)
import Data.ByteString (ByteString)
import Data.IORef
import Data.List (intersperse, sort)
@@ -152,13 +152,13 @@
fromError cursor = do
errCode <- force "Missing Error Code" $ cursor $// elContent "Code"
errMsg <- force "Missing Error Message" $ cursor $// elContent "Message"
- F.failure $ IamError (HTTP.responseStatus resp) errCode errMsg
+ throwM $ IamError (HTTP.responseStatus resp) errCode errMsg
-- | Parses IAM @DateTime@ data type.
-parseDateTime :: (F.Failure XmlException m) => String -> m UTCTime
+parseDateTime :: MonadThrow m => String -> m UTCTime
parseDateTime x
= case parseTime defaultTimeLocale iso8601UtcDate x of
- Nothing -> F.failure $ XmlException $ "Invalid DateTime: " ++ x
+ Nothing -> throwM $ XmlException $ "Invalid DateTime: " ++ x
Just dt -> return dt
-- | The IAM @User@ data type.
@@ -180,7 +180,7 @@
deriving (Eq, Ord, Show, Typeable)
-- | Parses the IAM @User@ data type.
-parseUser :: (F.Failure XmlException m) => Cu.Cursor -> m User
+parseUser :: MonadThrow m => Cu.Cursor -> m User
parseUser cursor = do
userArn <- attr "Arn"
userCreateDate <- attr "CreateDate" >>= parseDateTime . Text.unpack
diff -ru orig/Aws/Iam/Internal.hs new/Aws/Iam/Internal.hs
--- orig/Aws/Iam/Internal.hs 2014-04-03 08:17:21.062394778 +0300
+++ new/Aws/Iam/Internal.hs 2014-04-03 08:17:20.000000000 +0300
@@ -15,8 +15,8 @@
import Aws.Iam.Core
import Control.Applicative
import Control.Arrow (second)
-import qualified Control.Failure as F
import Control.Monad
+import Control.Monad.Trans.Resource (MonadThrow)
import Data.ByteString (ByteString)
import Data.Maybe
import Data.Monoid ((<>))
@@ -62,7 +62,7 @@
-- | Reads and returns the @IsTruncated@ and @Marker@ attributes present in
-- all IAM data pagination responses.
markedIterResponse
- :: F.Failure XmlException m
+ :: MonadThrow m
=> Cu.Cursor
-> m (Bool, Maybe Text)
markedIterResponse cursor = do
diff -ru orig/Aws/S3/Commands/CopyObject.hs new/Aws/S3/Commands/CopyObject.hs
--- orig/Aws/S3/Commands/CopyObject.hs 2014-04-03 08:17:21.062394778 +0300
+++ new/Aws/S3/Commands/CopyObject.hs 2014-04-03 08:17:20.000000000 +0300
@@ -5,7 +5,7 @@
import Aws.S3.Core
import Control.Applicative
import Control.Arrow (second)
-import Control.Failure
+import Control.Monad.Trans.Resource (throwM)
import qualified Data.CaseInsensitive as CI
import Data.Maybe
import qualified Data.Text as T
@@ -93,7 +93,7 @@
return $ CopyObjectResponse vid lastMod etag
where parse el = do
let parseHttpDate' x = case parseTime defaultTimeLocale iso8601UtcDate x of
- Nothing -> failure $ XmlException ("Invalid Last-Modified " ++ x)
+ Nothing -> throwM $ XmlException ("Invalid Last-Modified " ++ x)
Just y -> return y
lastMod <- forceM "Missing Last-Modified" $ el $/ elContent "LastModified" &| (parseHttpDate' . T.unpack)
etag <- force "Missing ETag" $ el $/ elContent "ETag"
diff -ru orig/Aws/S3/Core.hs new/Aws/S3/Core.hs
--- orig/Aws/S3/Core.hs 2014-04-03 08:17:21.062394778 +0300
+++ new/Aws/S3/Core.hs 2014-04-03 08:17:20.000000000 +0300
@@ -5,8 +5,8 @@
import Control.Arrow ((***))
import Control.Monad
import Control.Monad.IO.Class
+import Control.Monad.Trans.Resource (MonadThrow, throwM)
import Crypto.Hash.CryptoAPI (MD5)
-import Data.Attempt (Attempt(..))
import Data.Conduit (($$+-))
import Data.Function
import Data.IORef
@@ -20,12 +20,10 @@
import qualified Blaze.ByteString.Builder as Blaze
import qualified Blaze.ByteString.Builder.Char8 as Blaze8
import qualified Control.Exception as C
-import qualified Control.Failure as F
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Base64 as Base64
import qualified Data.CaseInsensitive as CI
-import qualified Data.Conduit as C
import qualified Data.Serialize as Serialize
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
@@ -248,10 +246,10 @@
= do doc <- HTTP.responseBody resp $$+- XML.sinkDoc XML.def
let cursor = Cu.fromDocument doc
liftIO $ case parseError cursor of
- Success err -> C.monadThrow err
- Failure otherErr -> C.monadThrow otherErr
+ Right err -> throwM err
+ Left otherErr -> throwM otherErr
where
- parseError :: Cu.Cursor -> Attempt S3Error
+ parseError :: Cu.Cursor -> Either C.SomeException S3Error
parseError root = do code <- force "Missing error Code" $ root $/ elContent "Code"
message <- force "Missing error Message" $ root $/ elContent "Message"
let resource = listToMaybe $ root $/ elContent "Resource"
@@ -279,7 +277,7 @@
}
deriving (Show)
-parseUserInfo :: F.Failure XmlException m => Cu.Cursor -> m UserInfo
+parseUserInfo :: MonadThrow m => Cu.Cursor -> m UserInfo
parseUserInfo el = do id_ <- force "Missing user ID" $ el $/ elContent "ID"
displayName <- force "Missing user DisplayName" $ el $/ elContent "DisplayName"
return UserInfo { userId = id_, userDisplayName = displayName }
@@ -308,10 +306,10 @@
| ReducedRedundancy
deriving (Show)
-parseStorageClass :: F.Failure XmlException m => T.Text -> m StorageClass
+parseStorageClass :: MonadThrow m => T.Text -> m StorageClass
parseStorageClass "STANDARD" = return Standard
parseStorageClass "REDUCED_REDUNDANCY" = return ReducedRedundancy
-parseStorageClass s = F.failure . XmlException $ "Invalid Storage Class: " ++ T.unpack s
+parseStorageClass s = throwM . XmlException $ "Invalid Storage Class: " ++ T.unpack s
writeStorageClass :: StorageClass -> T.Text
writeStorageClass Standard = "STANDARD"
@@ -321,9 +319,9 @@
= AES256
deriving (Show)
-parseServerSideEncryption :: F.Failure XmlException m => T.Text -> m ServerSideEncryption
+parseServerSideEncryption :: MonadThrow m => T.Text -> m ServerSideEncryption
parseServerSideEncryption "AES256" = return AES256
-parseServerSideEncryption s = F.failure . XmlException $ "Invalid Server Side Encryption: " ++ T.unpack s
+parseServerSideEncryption s = throwM . XmlException $ "Invalid Server Side Encryption: " ++ T.unpack s
writeServerSideEncryption :: ServerSideEncryption -> T.Text
writeServerSideEncryption AES256 = "AES256"
@@ -358,11 +356,11 @@
}
deriving (Show)
-parseObjectInfo :: F.Failure XmlException m => Cu.Cursor -> m ObjectInfo
+parseObjectInfo :: MonadThrow m => Cu.Cursor -> m ObjectInfo
parseObjectInfo el
= do key <- force "Missing object Key" $ el $/ elContent "Key"
let time s = case parseTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" $ T.unpack s of
- Nothing -> F.failure $ XmlException "Invalid time"
+ Nothing -> throwM $ XmlException "Invalid time"
Just v -> return v
lastModified <- forceM "Missing object LastModified" $ el $/ elContent "LastModified" &| time
eTag <- force "Missing object ETag" $ el $/ elContent "ETag"
@@ -392,7 +390,7 @@
}
deriving (Show)
-parseObjectMetadata :: F.Failure HeaderException m => HTTP.ResponseHeaders -> m ObjectMetadata
+parseObjectMetadata :: MonadThrow m => HTTP.ResponseHeaders -> m ObjectMetadata
parseObjectMetadata h = ObjectMetadata
`liftM` deleteMarker
`ap` etag
@@ -406,15 +404,15 @@
Nothing -> return False
Just "true" -> return True
Just "false" -> return False
- Just x -> F.failure $ HeaderException ("Invalid x-amz-delete-marker " ++ x)
+ Just x -> throwM $ HeaderException ("Invalid x-amz-delete-marker " ++ x)
etag = case T.decodeUtf8 `fmap` lookup "ETag" h of
Just x -> return x
- Nothing -> F.failure $ HeaderException "ETag missing"
+ Nothing -> throwM $ HeaderException "ETag missing"
lastModified = case B8.unpack `fmap` lookup "Last-Modified" h of
Just ts -> case parseHttpDate ts of
Just t -> return t
- Nothing -> F.failure $ HeaderException ("Invalid Last-Modified: " ++ ts)
- Nothing -> F.failure $ HeaderException "Last-Modified missing"
+ Nothing -> throwM $ HeaderException ("Invalid Last-Modified: " ++ ts)
+ Nothing -> throwM $ HeaderException "Last-Modified missing"
versionId = T.decodeUtf8 `fmap` lookup "x-amz-version-id" h
-- expiration = return undefined
userMetadata = flip mapMaybe ht $
diff -ru orig/Aws/Ses/Core.hs new/Aws/Ses/Core.hs
--- orig/Aws/Ses/Core.hs 2014-04-03 08:17:21.062394778 +0300
+++ new/Aws/Ses/Core.hs 2014-04-03 08:17:20.000000000 +0300
@@ -22,8 +22,8 @@
import qualified Blaze.ByteString.Builder as Blaze
import qualified Blaze.ByteString.Builder.Char8 as Blaze8
import qualified Control.Exception as C
-import qualified Control.Failure as F
import Control.Monad (mplus)
+import Control.Monad.Trans.Resource (throwM)
import qualified Data.ByteString as B
import qualified Data.ByteString.Base64 as B64
import Data.ByteString.Char8 ({-IsString-})
@@ -128,7 +128,7 @@
fromError cursor = do
errCode <- force "Missing Error Code" $ cursor $// elContent "Code"
errMessage <- force "Missing Error Message" $ cursor $// elContent "Message"
- F.failure $ SesError (HTTP.responseStatus resp) errCode errMessage
+ throwM $ SesError (HTTP.responseStatus resp) errCode errMessage
class SesAsQuery a where
-- | Write a data type as a list of query parameters.
diff -ru orig/Aws/SimpleDb/Core.hs new/Aws/SimpleDb/Core.hs
--- orig/Aws/SimpleDb/Core.hs 2014-04-03 08:17:21.066394778 +0300
+++ new/Aws/SimpleDb/Core.hs 2014-04-03 08:17:20.000000000 +0300
@@ -4,8 +4,8 @@
import qualified Blaze.ByteString.Builder as Blaze
import qualified Blaze.ByteString.Builder.Char8 as Blaze8
import qualified Control.Exception as C
-import qualified Control.Failure as F
import Control.Monad
+import Control.Monad.Trans.Resource (MonadThrow, throwM)
import qualified Data.ByteString as B
import qualified Data.ByteString.Base64 as Base64
import Data.IORef
@@ -149,16 +149,16 @@
(err:_) -> fromError err
fromError cursor = do errCode <- force "Missing Error Code" $ cursor $// elCont "Code"
errMessage <- force "Missing Error Message" $ cursor $// elCont "Message"
- F.failure $ SdbError (HTTP.responseStatus resp) errCode errMessage
+ throwM $ SdbError (HTTP.responseStatus resp) errCode errMessage
class SdbFromResponse a where
sdbFromResponse :: Cu.Cursor -> Response SdbMetadata a
-sdbCheckResponseType :: F.Failure XmlException m => a -> T.Text -> Cu.Cursor -> m a
+sdbCheckResponseType :: MonadThrow m => a -> T.Text -> Cu.Cursor -> m a
sdbCheckResponseType a n c = do _ <- force ("Expected response type " ++ T.unpack n) (Cu.laxElement n c)
return a
-decodeBase64 :: F.Failure XmlException m => Cu.Cursor -> m T.Text
+decodeBase64 :: MonadThrow m => Cu.Cursor -> m T.Text
decodeBase64 cursor =
let encoded = T.concat $ cursor $/ Cu.content
encoding = listToMaybe $ cursor $| Cu.laxAttribute "encoding" &| T.toCaseFold
@@ -166,15 +166,15 @@
case encoding of
Nothing -> return encoded
Just "base64" -> case Base64.decode . T.encodeUtf8 $ encoded of
- Left msg -> F.failure $ XmlException ("Invalid Base64 data: " ++ msg)
+ Left msg -> throwM $ XmlException ("Invalid Base64 data: " ++ msg)
Right x -> return $ T.decodeUtf8 x
- Just actual -> F.failure $ XmlException ("Unrecognized encoding " ++ T.unpack actual)
+ Just actual -> throwM $ XmlException ("Unrecognized encoding " ++ T.unpack actual)
data Attribute a
= ForAttribute { attributeName :: T.Text, attributeData :: a }
deriving (Show)
-readAttribute :: F.Failure XmlException m => Cu.Cursor -> m (Attribute T.Text)
+readAttribute :: MonadThrow m => Cu.Cursor -> m (Attribute T.Text)
readAttribute cursor = do
name <- forceM "Missing Name" $ cursor $/ Cu.laxElement "Name" &| decodeBase64
value <- forceM "Missing Value" $ cursor $/ Cu.laxElement "Value" &| decodeBase64
@@ -225,7 +225,7 @@
= Item { itemName :: T.Text, itemData :: a }
deriving (Show)
-readItem :: F.Failure XmlException m => Cu.Cursor -> m (Item [Attribute T.Text])
+readItem :: MonadThrow m => Cu.Cursor -> m (Item [Attribute T.Text])
readItem cursor = do
name <- force "Missing Name" <=< sequence $ cursor $/ Cu.laxElement "Name" &| decodeBase64
attributes <- sequence $ cursor $/ Cu.laxElement "Attribute" &| readAttribute
diff -ru orig/Aws/Sqs/Commands/Message.hs new/Aws/Sqs/Commands/Message.hs
--- orig/Aws/Sqs/Commands/Message.hs 2014-04-03 08:17:21.066394778 +0300
+++ new/Aws/Sqs/Commands/Message.hs 2014-04-03 08:17:20.000000000 +0300
@@ -4,9 +4,9 @@
import Aws.Core
import Aws.Sqs.Core
import Control.Applicative
+import Control.Monad.Trans.Resource (MonadThrow)
import Data.Maybe
import Text.XML.Cursor (($/), ($//), (&/), (&|))
-import qualified Control.Failure as F
import qualified Data.ByteString.Char8 as B
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
@@ -98,7 +98,7 @@
}
deriving (Show)
-readMessageAttribute :: F.Failure XmlException m => Cu.Cursor -> m (MessageAttribute,T.Text)
+readMessageAttribute :: MonadThrow m => Cu.Cursor -> m (MessageAttribute,T.Text)
readMessageAttribute cursor = do
name <- force "Missing Name" $ cursor $/ Cu.laxElement "Name" &/ Cu.content
value <- force "Missing Value" $ cursor $/ Cu.laxElement "Value" &/ Cu.content
diff -ru orig/Aws/Sqs/Core.hs new/Aws/Sqs/Core.hs
--- orig/Aws/Sqs/Core.hs 2014-04-03 08:17:21.066394778 +0300
+++ new/Aws/Sqs/Core.hs 2014-04-03 08:17:20.000000000 +0300
@@ -5,14 +5,12 @@
import qualified Blaze.ByteString.Builder as Blaze
import qualified Blaze.ByteString.Builder.Char8 as Blaze8
import qualified Control.Exception as C
-import qualified Control.Failure as F
import Control.Monad
import Control.Monad.IO.Class
-import Data.Attempt (Attempt(..))
+import Control.Monad.Trans.Resource (MonadThrow, throwM)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import Data.Conduit (($$+-))
-import qualified Data.Conduit as C
import Data.IORef
import Data.List
import Data.Maybe
@@ -234,10 +232,10 @@
= do doc <- HTTP.responseBody resp $$+- XML.sinkDoc XML.def
let cursor = Cu.fromDocument doc
liftIO $ case parseError cursor of
- Success err -> C.monadThrow err
- Failure otherErr -> C.monadThrow otherErr
+ Right err -> throwM err
+ Left otherErr -> throwM otherErr
where
- parseError :: Cu.Cursor -> Attempt SqsError
+ parseError :: Cu.Cursor -> Either C.SomeException SqsError
parseError root = do cursor <- force "Missing Error" $ root $/ Cu.laxElement "Error"
code <- force "Missing error Code" $ cursor $/ elContent "Code"
message <- force "Missing error Message" $ cursor $/ elContent "Message"
@@ -291,7 +289,7 @@
| PermissionGetQueueAttributes
deriving (Show, Enum, Eq)
-parseQueueAttribute :: F.Failure XmlException m => T.Text -> m QueueAttribute
+parseQueueAttribute :: MonadThrow m => T.Text -> m QueueAttribute
parseQueueAttribute "ApproximateNumberOfMessages" = return ApproximateNumberOfMessages
parseQueueAttribute "ApproximateNumberOfMessagesNotVisible" = return ApproximateNumberOfMessagesNotVisible
parseQueueAttribute "VisibilityTimeout" = return VisibilityTimeout
@@ -301,7 +299,7 @@
parseQueueAttribute "MaximumMessageSize" = return MaximumMessageSize
parseQueueAttribute "MessageRetentionPeriod" = return MessageRetentionPeriod
parseQueueAttribute "QueueArn" = return QueueArn
-parseQueueAttribute x = F.failure $ XmlException ( "Invalid Attribute Name. " ++ show x)
+parseQueueAttribute x = throwM $ XmlException ( "Invalid Attribute Name. " ++ show x)
printQueueAttribute :: QueueAttribute -> T.Text
printQueueAttribute QueueAll = "All"
@@ -315,12 +313,12 @@
printQueueAttribute MessageRetentionPeriod = "MessageRetentionPeriod"
printQueueAttribute QueueArn = "QueueArn"
-parseMessageAttribute :: F.Failure XmlException m => T.Text -> m MessageAttribute
+parseMessageAttribute :: MonadThrow m => T.Text -> m MessageAttribute
parseMessageAttribute "SenderId" = return SenderId
parseMessageAttribute "SentTimestamp" = return SentTimestamp
parseMessageAttribute "ApproximateReceiveCount" = return ApproximateReceiveCount
parseMessageAttribute "ApproximateFirstReceiveTimestamp" = return ApproximateFirstReceiveTimestamp
-parseMessageAttribute x = F.failure $ XmlException ( "Invalid Attribute Name. " ++ show x)
+parseMessageAttribute x = throwM $ XmlException ( "Invalid Attribute Name. " ++ show x)
printMessageAttribute :: MessageAttribute -> T.Text
printMessageAttribute MessageAll = "All"
diff -ru orig/aws.cabal new/aws.cabal
--- orig/aws.cabal 2014-04-02 13:40:50.015820737 +0300
+++ new/aws.cabal 2014-04-02 13:40:49.000000000 +0300
@@ -130,7 +130,9 @@
--- orig/aws.cabal 2014-04-03 08:17:21.070394778 +0300
+++ new/aws.cabal 2014-04-03 08:17:20.000000000 +0300
@@ -20,7 +20,7 @@
Source-repository this
type: git
location: https://github.com/aristidb/aws.git
- tag: 0.8.5
+ tag: 0.8.6
Source-repository head
type: git
@@ -98,8 +98,6 @@
Aws.DynamoDb.Core
Build-depends:
- attempt >= 0.3.1.1 && < 0.5,
- attoparsec-conduit >= 1.0 && < 1.1,
aeson >= 0.6 && < 0.8,
base == 4.*,
base16-bytestring == 0.1.*,
@@ -108,29 +106,29 @@
bytestring >= 0.9 && < 0.11,
case-insensitive >= 0.2 && < 1.3,
cereal >= 0.3 && < 0.5,
- conduit >= 1.0 && < 1.1,
+ conduit >= 1.1 && < 1.2,
+ conduit-extra >= 1.1 && < 1.2,
containers >= 0.4,
crypto-api >= 0.9,
cryptohash >= 0.8 && < 0.12,
cryptohash-cryptoapi == 0.1.*,
data-default == 0.5.*,
directory >= 1.0 && < 1.3,
- failure >= 0.2.0.1 && < 0.3,
filepath >= 1.1 && < 1.4,
- http-conduit >= 1.9 && < 2.1,
+ http-conduit >= 2.1 && < 2.2,
http-types >= 0.7 && < 0.9,
lifted-base >= 0.1 && < 0.3,
monad-control >= 0.3,
mtl == 2.*,
old-locale == 1.*,
- resourcet >= 0.3.3 && <0.5,
+ resourcet >= 1.1 && < 1.2,
text >= 0.11,
time >= 1.1.4 && < 1.5,
transformers >= 0.2.2.0 && < 0.4,
unordered-containers >= 0.2,
utf8-string == 0.3.*,
vector >= 0.10,
- xml-conduit >= 1.1 && <1.2
+ xml-conduit >= 1.1 && <1.2,
+ http-client < 0.3,
+ ghc-prim
+ xml-conduit >= 1.2 && <1.3
GHC-Options: -Wall
diff -ru orig/README.org new/README.org
--- orig/README.org 2014-04-03 08:17:21.058394778 +0300
+++ new/README.org 2014-04-03 08:17:20.000000000 +0300
@@ -90,6 +90,10 @@
** 0.8 series
+- 0.8.6
+ - move Instance metadata functions out of ResourceT to remove problem with exceptions-0.5
+ (this makes a fresh install of aws on a clean system possible again)
+
- 0.8.5
- compatibility with case-insensitive 1.2
- support for V4 signatures

53
patching/patches/cereal-conduit-0.7.2.patch Normal file
View File

@ -0,0 +1,53 @@
diff -ru orig/cereal-conduit.cabal new/cereal-conduit.cabal
--- orig/cereal-conduit.cabal 2014-04-03 08:22:14.122388542 +0300
+++ new/cereal-conduit.cabal 2014-04-03 08:22:13.000000000 +0300
@@ -19,7 +19,8 @@
library
build-depends: base >= 4 && < 5
- , conduit >= 1.0.0 && < 1.1
+ , conduit >= 1.0.0 && < 1.2
+ , resourcet >= 0.4 && < 1.2
, cereal >= 0.4.0.0 && < 0.5
, bytestring
, transformers >= 0.2.0.0
diff -ru orig/Data/Conduit/Cereal.hs new/Data/Conduit/Cereal.hs
--- orig/Data/Conduit/Cereal.hs 2014-04-03 08:22:14.122388542 +0300
+++ new/Data/Conduit/Cereal.hs 2014-04-03 08:22:13.000000000 +0300
@@ -19,6 +19,7 @@
import Control.Exception.Base
import Control.Monad.Trans.Class (MonadTrans, lift)
+import Control.Monad.Trans.Resource (MonadThrow, monadThrow)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Conduit as C
@@ -34,7 +35,7 @@
instance Exception GetException
-- | Run a 'Get' repeatedly on the input stream, producing an output stream of whatever the 'Get' outputs.
-conduitGet :: C.MonadThrow m => Get o -> C.Conduit BS.ByteString m o
+conduitGet :: MonadThrow m => Get o -> C.Conduit BS.ByteString m o
conduitGet = mkConduitGet errorHandler
where errorHandler msg = pipeError $ GetException msg
@@ -42,7 +43,7 @@
--
-- If 'Get' succeed it will return the data read and unconsumed part of the input stream.
-- If the 'Get' fails due to deserialization error or early termination of the input stream it raise an error.
-sinkGet :: C.MonadThrow m => Get r -> C.Consumer BS.ByteString m r
+sinkGet :: MonadThrow m => Get r -> C.Consumer BS.ByteString m r
sinkGet = mkSinkGet errorHandler terminationHandler
where errorHandler msg = pipeError $ GetException msg
terminationHandler f = case f BS.empty of
@@ -50,8 +51,8 @@
Done r lo -> C.leftover lo >> return r
Partial _ -> pipeError $ GetException "Failed reading: Internal error: unexpected Partial."
-pipeError :: (C.MonadThrow m, MonadTrans t, Exception e) => e -> t m a
-pipeError e = lift $ C.monadThrow e
+pipeError :: (MonadThrow m, MonadTrans t, Exception e) => e -> t m a
+pipeError e = lift $ monadThrow e
-- | Convert a 'Put' into a 'Source'. Runs in constant memory.
sourcePut :: Monad m => Put -> C.Producer m BS.ByteString

12
patching/patches/diagrams-builder-0.5.0.6.patch Normal file
View File

@ -0,0 +1,12 @@
diff -ru orig/diagrams-builder.cabal new/diagrams-builder.cabal
--- orig/diagrams-builder.cabal 2014-04-03 08:17:21.630394766 +0300
+++ new/diagrams-builder.cabal 2014-04-03 08:17:21.000000000 +0300
@@ -59,7 +59,7 @@
cmdargs >= 0.6 && < 0.11,
lens >= 3.9 && < 4.2,
hashable >= 1.1 && < 1.3,
- exceptions >= 0.3 && < 0.4
+ exceptions >= 0.3 && < 0.6
hs-source-dirs: src
default-language: Haskell2010
other-extensions: StandaloneDeriving,

12
patching/patches/esqueleto-1.3.8.patch Normal file
View File

@ -0,0 +1,12 @@
diff -ru orig/esqueleto.cabal new/esqueleto.cabal
--- orig/esqueleto.cabal 2014-04-03 08:31:02.238377300 +0300
+++ new/esqueleto.cabal 2014-04-03 08:31:01.000000000 +0300
@@ -91,7 +91,7 @@
, containers
, HUnit
, QuickCheck
- , hspec >= 1.9
+ , hspec >= 1.8
, persistent-sqlite >= 1.2 && < 1.4
, persistent-template >= 1.2 && < 1.4
, monad-control

62
patching/patches/process-conduit-1.0.0.2.patch Normal file
View File

@ -0,0 +1,62 @@
diff -ru orig/Data/Conduit/Process.hs new/Data/Conduit/Process.hs
--- orig/Data/Conduit/Process.hs 2014-04-03 08:26:07.254383579 +0300
+++ new/Data/Conduit/Process.hs 2014-04-03 08:26:06.000000000 +0300
@@ -21,6 +21,7 @@
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Trans.Loop
+import Control.Monad.Trans.Resource (MonadResource, monadThrow)
import qualified Data.ByteString as S
import Data.Conduit
import qualified Data.Conduit.List as CL
diff -ru orig/process-conduit.cabal new/process-conduit.cabal
--- orig/process-conduit.cabal 2014-04-03 08:26:07.258383579 +0300
+++ new/process-conduit.cabal 2014-04-03 08:26:06.000000000 +0300
@@ -33,7 +33,8 @@
, bytestring >= 0.9
, text >= 0.11
, process >= 1.0
- , conduit == 1.0.*
+ , conduit >= 1.0 && < 1.2
+ , resourcet >= 0.4 && < 1.2
, shakespeare-text >= 1.0
, shakespeare
@@ -47,4 +48,6 @@
, bytestring
, hspec >= 1.3
, conduit
+ , conduit-extra
+ , resourcet
, process-conduit
diff -ru orig/System/Process/QQ.hs new/System/Process/QQ.hs
--- orig/System/Process/QQ.hs 2014-04-03 08:26:07.254383579 +0300
+++ new/System/Process/QQ.hs 2014-04-03 08:26:06.000000000 +0300
@@ -14,6 +14,7 @@
import qualified Data.Text.Lazy as LT
import Language.Haskell.TH.Quote
import Text.Shakespeare.Text
+import Control.Monad.Trans.Resource (runResourceT)
import Data.Conduit.Process
@@ -28,7 +29,7 @@
-- | Command result of (Lazy) ByteString.
cmd :: QuasiQuoter
cmd = def { quoteExp = \str -> [|
- BL.fromChunks <$> C.runResourceT (sourceCmd (LT.unpack $(quoteExp lt str)) C.$$ CL.consume)
+ BL.fromChunks <$> runResourceT (sourceCmd (LT.unpack $(quoteExp lt str)) C.$$ CL.consume)
|] }
-- | Source of shell command
diff -ru orig/test.hs new/test.hs
--- orig/test.hs 2014-04-03 08:26:07.254383579 +0300
+++ new/test.hs 2014-04-03 08:26:06.000000000 +0300
@@ -7,6 +7,7 @@
import Data.Conduit
import qualified Data.Conduit.Binary as CB
import Test.Hspec
+import Control.Monad.Trans.Resource (runResourceT)
main :: IO ()
main = hspec $ do

16
patching/patches/stm-conduit-2.3.0.patch Normal file
View File

@ -0,0 +1,16 @@
diff -ru orig/stm-conduit.cabal new/stm-conduit.cabal
--- orig/stm-conduit.cabal 2014-04-03 08:22:14.310388538 +0300
+++ new/stm-conduit.cabal 2014-04-03 08:22:14.000000000 +0300
@@ -29,9 +29,10 @@
, stm-chans >= 2.0 && < 3.1
, cereal >= 0.4.0.1
, cereal-conduit >= 0.7.2
- , conduit == 1.0.*
+ , conduit >= 1.0 && < 1.2
+ , conduit-extra >= 1.0 && < 1.2
, directory >= 1.1
- , resourcet >= 0.3 && < 0.5
+ , resourcet >= 0.3 && < 1.2
, async >= 2.0.1
, monad-control >= 0.3.2
, monad-loops >= 0.4.2

12
patching/patches/temporary-1.2.0.1.patch Normal file
View File

@ -0,0 +1,12 @@
diff -ru orig/temporary.cabal new/temporary.cabal
--- orig/temporary.cabal 2014-04-03 08:17:21.902394760 +0300
+++ new/temporary.cabal 2014-04-03 08:17:21.000000000 +0300
@@ -23,7 +23,7 @@
other-modules: Distribution.Compat.Exception
Distribution.Compat.TempFile
build-depends: base >= 3 && < 6, filepath >= 1.1 && < 1.4, directory >= 1.0 && < 1.3,
- transformers >= 0.2.0.0 && < 0.4, exceptions >= 0.1.1 && < 0.4
+ transformers >= 0.2.0.0 && < 0.4, exceptions >= 0.1.1 && < 0.6
if !os(windows)
build-depends: unix >= 2.3 && < 2.8

21
patching/patches/websockets-0.8.2.0.patch Normal file
View File

@ -0,0 +1,21 @@
diff -ru orig/websockets.cabal new/websockets.cabal
--- orig/websockets.cabal 2014-04-03 08:32:53.818374925 +0300
+++ new/websockets.cabal 2014-04-03 08:32:53.000000000 +0300
@@ -69,7 +69,7 @@
binary >= 0.5 && < 0.8,
blaze-builder >= 0.3 && < 0.4,
bytestring >= 0.9 && < 0.11,
- case-insensitive >= 0.3 && < 1.2,
+ case-insensitive >= 0.3 && < 1.3,
containers >= 0.3 && < 0.6,
io-streams >= 1.1 && < 1.2,
mtl >= 2.0 && < 2.2,
@@ -105,7 +105,7 @@
binary >= 0.5 && < 0.8,
blaze-builder >= 0.3 && < 0.4,
bytestring >= 0.9 && < 0.11,
- case-insensitive >= 0.3 && < 1.2,
+ case-insensitive >= 0.3 && < 1.3,
containers >= 0.3 && < 0.6,
io-streams >= 1.1 && < 1.2,
mtl >= 2.0 && < 2.2,