mirror of
https://github.com/commercialhaskell/stackage.git
synced 2026-01-28 15:10:26 +01:00
Delete a whole bunch of old patches
This commit is contained in:
Michael Snoyman
parent
1ef4ceafe9
commit
9301f5524f
@ -1,23 +0,0 @@
|
|||||||
diff -ru orig/Biobase/Turner/Import.hs new/Biobase/Turner/Import.hs
|
|
||||||
--- orig/Biobase/Turner/Import.hs 2014-04-03 10:53:56.310194793 +0300
|
|
||||||
+++ new/Biobase/Turner/Import.hs 2014-04-03 10:53:56.000000000 +0300
|
|
||||||
@@ -37,6 +37,7 @@
|
|
||||||
module Biobase.Turner.Import where
|
|
||||||
|
|
||||||
import Control.Arrow
|
|
||||||
+import Control.Monad.Trans.Resource (runResourceT)
|
|
||||||
import Data.Array.Repa.Index
|
|
||||||
import Data.ByteString.Char8 as BS
|
|
||||||
import Data.ByteString.Lex.Double
|
|
||||||
diff -ru orig/BiobaseTurner.cabal new/BiobaseTurner.cabal
|
|
||||||
--- orig/BiobaseTurner.cabal 2014-04-03 10:53:56.310194793 +0300
|
|
||||||
+++ new/BiobaseTurner.cabal 2014-04-03 10:53:56.000000000 +0300
|
|
||||||
@@ -35,6 +35,8 @@
|
|
||||||
bytestring >= 0.9 ,
|
|
||||||
bytestring-lexing >= 0.4 ,
|
|
||||||
conduit >= 0.5 ,
|
|
||||||
+ conduit-extra >= 1.0 ,
|
|
||||||
+ resourcet >= 0.4 ,
|
|
||||||
containers >= 0.4 ,
|
|
||||||
filepath >= 1 ,
|
|
||||||
lens >= 3.8 ,
|
|
||||||
@ -1,15 +0,0 @@
|
|||||||
diff -ru orig/BlogLiterately-diagrams.cabal new/BlogLiterately-diagrams.cabal
|
|
||||||
--- orig/BlogLiterately-diagrams.cabal 2014-06-03 16:05:19.882144431 +0300
|
|
||||||
+++ new/BlogLiterately-diagrams.cabal 2014-06-03 16:05:19.000000000 +0300
|
|
||||||
@@ -79,9 +79,9 @@
|
|
||||||
containers,
|
|
||||||
filepath,
|
|
||||||
directory,
|
|
||||||
- diagrams-cairo >= 1.0.1 && < 1.2,
|
|
||||||
+ diagrams-cairo >= 1.0.1 && < 1.3,
|
|
||||||
diagrams-builder >= 0.5 && < 0.6,
|
|
||||||
- diagrams-lib >= 1.0.1 && < 1.2,
|
|
||||||
+ diagrams-lib >= 1.0.1 && < 1.3,
|
|
||||||
BlogLiterately >= 0.6 && < 0.8,
|
|
||||||
pandoc >= 1.9 && < 1.13,
|
|
||||||
safe ==0.3.*
|
|
||||||
@ -1,34 +0,0 @@
|
|||||||
diff -ru orig/ChasingBottoms.cabal new/ChasingBottoms.cabal
|
|
||||||
--- orig/ChasingBottoms.cabal 2014-06-10 13:09:03.210534172 +0300
|
|
||||||
+++ new/ChasingBottoms.cabal 2014-06-10 13:09:03.000000000 +0300
|
|
||||||
@@ -121,7 +121,7 @@
|
|
||||||
|
|
||||||
other-modules: Test.ChasingBottoms.IsType
|
|
||||||
|
|
||||||
- build-depends: QuickCheck >= 2.1 && < 2.7,
|
|
||||||
+ build-depends: QuickCheck >= 2.1 && < 2.8,
|
|
||||||
mtl >= 1.1 && < 2.2,
|
|
||||||
base >= 4.0 && < 4.8,
|
|
||||||
containers >= 0.3 && < 0.6,
|
|
||||||
@@ -150,7 +150,7 @@
|
|
||||||
Test.ChasingBottoms.TestUtilities.Generators,
|
|
||||||
Test.ChasingBottoms.TimeOut.Tests
|
|
||||||
|
|
||||||
- build-depends: QuickCheck >= 2.1 && < 2.7,
|
|
||||||
+ build-depends: QuickCheck >= 2.1 && < 2.8,
|
|
||||||
mtl >= 1.1 && < 2.2,
|
|
||||||
base >= 4.0 && < 4.8,
|
|
||||||
containers >= 0.3 && < 0.6,
|
|
||||||
diff -ru orig/Test/ChasingBottoms/ContinuousFunctions.hs new/Test/ChasingBottoms/ContinuousFunctions.hs
|
|
||||||
--- orig/Test/ChasingBottoms/ContinuousFunctions.hs 2014-06-10 13:09:03.202534172 +0300
|
|
||||||
+++ new/Test/ChasingBottoms/ContinuousFunctions.hs 2014-06-10 13:09:03.000000000 +0300
|
|
||||||
@@ -143,7 +143,8 @@
|
|
||||||
, listOf
|
|
||||||
) where
|
|
||||||
|
|
||||||
-import Test.QuickCheck hiding ((><), listOf)
|
|
||||||
+import Test.QuickCheck hiding ((><), listOf, infiniteListOf)
|
|
||||||
+import Test.QuickCheck.Gen.Unsafe (promote)
|
|
||||||
import Data.Sequence as Seq
|
|
||||||
import Data.Foldable as Seq (foldr)
|
|
||||||
import Prelude as P hiding (concat)
|
|
||||||
File diff suppressed because it is too large
Load Diff
@ -1,28 +0,0 @@
|
|||||||
diff -ru orig/MusicBrainz.cabal new/MusicBrainz.cabal
|
|
||||||
--- orig/MusicBrainz.cabal 2014-06-30 16:08:08.987902131 +0300
|
|
||||||
+++ new/MusicBrainz.cabal 2014-06-30 16:08:08.000000000 +0300
|
|
||||||
@@ -23,8 +23,10 @@
|
|
||||||
, monad-control ==0.3.*
|
|
||||||
, bytestring
|
|
||||||
, conduit >= 1.0.0
|
|
||||||
+ , conduit-extra >= 1.0.0
|
|
||||||
, text
|
|
||||||
, time
|
|
||||||
+ , resourcet
|
|
||||||
, vector >=0.9
|
|
||||||
, xml-types ==0.3.*
|
|
||||||
, http-conduit >= 1.8.8
|
|
||||||
diff -ru orig/Network/Protocol/MusicBrainz/XML2/WebService.hs new/Network/Protocol/MusicBrainz/XML2/WebService.hs
|
|
||||||
--- orig/Network/Protocol/MusicBrainz/XML2/WebService.hs 2014-06-30 16:08:08.987902131 +0300
|
|
||||||
+++ new/Network/Protocol/MusicBrainz/XML2/WebService.hs 2014-06-30 16:08:08.000000000 +0300
|
|
||||||
@@ -11,8 +11,9 @@
|
|
||||||
import Control.Applicative (liftA2, (<|>))
|
|
||||||
import Control.Monad.IO.Class (MonadIO)
|
|
||||||
import Control.Monad.Trans.Control (MonadBaseControl)
|
|
||||||
+import Control.Monad.Trans.Resource (MonadThrow, runResourceT)
|
|
||||||
import qualified Data.ByteString.Lazy as BL
|
|
||||||
-import Data.Conduit (Consumer, ($=), ($$), MonadThrow, runResourceT)
|
|
||||||
+import Data.Conduit (Consumer, ($=), ($$))
|
|
||||||
import Data.Conduit.Binary (sourceLbs)
|
|
||||||
import Data.List (intercalate)
|
|
||||||
import Data.Maybe (fromMaybe)
|
|
||||||
@ -1,19 +0,0 @@
|
|||||||
diff -ru orig/Octree.cabal new/Octree.cabal
|
|
||||||
--- orig/Octree.cabal 2014-04-17 19:22:31.263672240 +0300
|
|
||||||
+++ new/Octree.cabal 2014-04-17 19:22:31.000000000 +0300
|
|
||||||
@@ -32,13 +32,13 @@
|
|
||||||
|
|
||||||
Test-suite test_Octree
|
|
||||||
Type: exitcode-stdio-1.0
|
|
||||||
- Build-depends: base>=4.0 && < 4.7, AC-Vector >= 2.3.0, QuickCheck >= 2.4.0
|
|
||||||
+ Build-depends: base>=4.0 && < 4.8, AC-Vector >= 2.3.0, QuickCheck >= 2.4.0
|
|
||||||
Main-is: tests/test_Octree.hs
|
|
||||||
|
|
||||||
Test-suite readme
|
|
||||||
type: exitcode-stdio-1.0
|
|
||||||
-- We have a symlink: README.lhs -> README.md
|
|
||||||
main-is: README.lhs
|
|
||||||
- Build-depends: base>=4.0 && < 4.7, AC-Vector >= 2.3.0, QuickCheck >= 2.4.0, markdown-unlit
|
|
||||||
+ Build-depends: base>=4.0 && < 4.8, AC-Vector >= 2.3.0, QuickCheck >= 2.4.0, markdown-unlit
|
|
||||||
ghc-options: -pgmL markdown-unlit
|
|
||||||
|
|
||||||
@ -1,19 +0,0 @@
|
|||||||
diff -ru orig/Octree.cabal new/Octree.cabal
|
|
||||||
--- orig/Octree.cabal 2014-05-01 18:10:50.650819156 +0300
|
|
||||||
+++ new/Octree.cabal 2014-05-01 18:10:50.000000000 +0300
|
|
||||||
@@ -33,13 +33,13 @@
|
|
||||||
|
|
||||||
Test-suite test_Octree
|
|
||||||
Type: exitcode-stdio-1.0
|
|
||||||
- Build-depends: base>=4.0 && < 4.7, AC-Vector >= 2.3.0, QuickCheck >= 2.4.0
|
|
||||||
+ Build-depends: base>=4.0 && < 4.8, AC-Vector >= 2.3.0, QuickCheck >= 2.4.0
|
|
||||||
Main-is: tests/test_Octree.hs
|
|
||||||
|
|
||||||
Test-suite readme
|
|
||||||
type: exitcode-stdio-1.0
|
|
||||||
-- We have a symlink: README.lhs -> README.md
|
|
||||||
main-is: README.lhs
|
|
||||||
- Build-depends: base>=4.0 && < 4.7, AC-Vector >= 2.3.0, QuickCheck >= 2.4.0, markdown-unlit
|
|
||||||
+ Build-depends: base>=4.0 && < 4.8, AC-Vector >= 2.3.0, QuickCheck >= 2.4.0, markdown-unlit
|
|
||||||
ghc-options: -pgmL markdown-unlit
|
|
||||||
|
|
||||||
@ -1,30 +0,0 @@
|
|||||||
diff -ruN orig/arbtt.cabal new/arbtt.cabal
|
|
||||||
--- orig/arbtt.cabal 2014-08-10 08:32:58.666725004 +0300
|
|
||||||
+++ new/arbtt.cabal 2014-08-10 08:32:58.000000000 +0300
|
|
||||||
@@ -35,7 +35,7 @@
|
|
||||||
build-depends:
|
|
||||||
base == 4.5.* || == 4.6.* || == 4.7.*,
|
|
||||||
filepath, directory, transformers, time >= 1.4, utf8-string,
|
|
||||||
- aeson == 0.6.* || == 0.7.*,
|
|
||||||
+ aeson,
|
|
||||||
array == 0.4.* || == 0.5.*,
|
|
||||||
binary >= 0.5,
|
|
||||||
bytestring, deepseq, strict, old-locale
|
|
||||||
@@ -82,7 +82,7 @@
|
|
||||||
binary >= 0.5,
|
|
||||||
deepseq, bytestring, utf8-string, time >= 1.4, strict,
|
|
||||||
transformers, unix, directory, filepath,
|
|
||||||
- aeson == 0.6.* || == 0.7.*,
|
|
||||||
+ aeson,
|
|
||||||
array == 0.4.* || == 0.5.*,
|
|
||||||
terminal-progress-bar, bytestring-progress
|
|
||||||
other-modules:
|
|
||||||
@@ -112,7 +112,7 @@
|
|
||||||
base == 4.5.* || == 4.6.* || == 4.7.*,
|
|
||||||
parsec == 3.*,
|
|
||||||
containers == 0.5.*,
|
|
||||||
- aeson == 0.6.* || == 0.7.*,
|
|
||||||
+ aeson,
|
|
||||||
array == 0.4.* || == 0.5.*,
|
|
||||||
binary >= 0.5,
|
|
||||||
deepseq, bytestring, utf8-string, time >= 1.4, strict,
|
|
||||||
@ -1,40 +0,0 @@
|
|||||||
diff -ruN orig/Control/Concurrent/Async.hs new/Control/Concurrent/Async.hs
|
|
||||||
--- orig/Control/Concurrent/Async.hs 2014-08-11 12:23:17.688591763 +0300
|
|
||||||
+++ new/Control/Concurrent/Async.hs 2014-08-11 12:23:17.000000000 +0300
|
|
||||||
@@ -246,7 +246,10 @@
|
|
||||||
--
|
|
||||||
{-# INLINE waitCatch #-}
|
|
||||||
waitCatch :: Async a -> IO (Either SomeException a)
|
|
||||||
-waitCatch = atomically . waitCatchSTM
|
|
||||||
+waitCatch = tryAgain . atomically . waitCatchSTM
|
|
||||||
+ where
|
|
||||||
+ -- See: https://github.com/simonmar/async/issues/14
|
|
||||||
+ tryAgain f = f `catch` \BlockedIndefinitelyOnSTM -> f
|
|
||||||
|
|
||||||
-- | Check whether an 'Async' has completed yet. If it has not
|
|
||||||
-- completed yet, then the result is @Nothing@, otherwise the result
|
|
||||||
diff -ruN orig/test/test-async.hs new/test/test-async.hs
|
|
||||||
--- orig/test/test-async.hs 2014-08-11 12:23:17.688591763 +0300
|
|
||||||
+++ new/test/test-async.hs 2014-08-11 12:23:17.000000000 +0300
|
|
||||||
@@ -29,6 +29,7 @@
|
|
||||||
testCase "async_cancel" async_cancel
|
|
||||||
, testCase "async_poll" async_poll
|
|
||||||
, testCase "async_poll2" async_poll2
|
|
||||||
+ , testCase "withasync_waitCatch_blocked" withasync_waitCatch_blocked
|
|
||||||
]
|
|
||||||
|
|
||||||
value = 42 :: Int
|
|
||||||
@@ -104,3 +105,13 @@
|
|
||||||
when (isNothing r) $ assertFailure ""
|
|
||||||
r <- poll a -- poll twice, just to check we don't deadlock
|
|
||||||
when (isNothing r) $ assertFailure ""
|
|
||||||
+
|
|
||||||
+withasync_waitCatch_blocked :: Assertion
|
|
||||||
+withasync_waitCatch_blocked = do
|
|
||||||
+ r <- withAsync (newEmptyMVar >>= takeMVar) waitCatch
|
|
||||||
+ case r of
|
|
||||||
+ Left e ->
|
|
||||||
+ case fromException e of
|
|
||||||
+ Just BlockedIndefinitelyOnMVar -> return ()
|
|
||||||
+ Nothing -> assertFailure $ show e
|
|
||||||
+ Right () -> assertFailure ""
|
|
||||||
@ -1,147 +0,0 @@
|
|||||||
diff -ru orig/authenticate-oauth.cabal new/authenticate-oauth.cabal
|
|
||||||
--- orig/authenticate-oauth.cabal 2014-02-21 07:19:28.878548521 +0200
|
|
||||||
+++ new/authenticate-oauth.cabal 2014-02-21 07:19:28.000000000 +0200
|
|
||||||
@@ -19,7 +19,7 @@
|
|
||||||
, transformers >= 0.1 && < 0.4
|
|
||||||
, bytestring >= 0.9
|
|
||||||
, crypto-pubkey-types >= 0.1 && < 0.5
|
|
||||||
- , RSA >= 1.2 && < 1.3
|
|
||||||
+ , RSA >= 1.2 && < 2.1
|
|
||||||
, time
|
|
||||||
, data-default
|
|
||||||
, base64-bytestring >= 0.1 && < 1.1
|
|
||||||
diff -ru orig/Web/Authenticate/OAuth.hs new/Web/Authenticate/OAuth.hs
|
|
||||||
--- orig/Web/Authenticate/OAuth.hs 2014-02-21 07:19:28.874548521 +0200
|
|
||||||
+++ new/Web/Authenticate/OAuth.hs 2014-02-21 07:19:28.000000000 +0200
|
|
||||||
@@ -1,5 +1,5 @@
|
|
||||||
-{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, MultiParamTypeClasses #-}
|
|
||||||
-{-# LANGUAGE OverloadedStrings, StandaloneDeriving #-}
|
|
||||||
+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, StandaloneDeriving, FlexibleContexts #-}
|
|
||||||
+{-# LANGUAGE CPP #-}
|
|
||||||
{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
|
|
||||||
module Web.Authenticate.OAuth
|
|
||||||
( -- * Data types
|
|
||||||
@@ -15,48 +15,50 @@
|
|
||||||
authorizeUrl, authorizeUrl', getAccessToken, getTemporaryCredential,
|
|
||||||
getTokenCredential, getTemporaryCredentialWithScope,
|
|
||||||
getAccessTokenProxy, getTemporaryCredentialProxy,
|
|
||||||
- getTokenCredentialProxy,
|
|
||||||
+ getTokenCredentialProxy,
|
|
||||||
getAccessToken', getTemporaryCredential',
|
|
||||||
-- * Utility Methods
|
|
||||||
paramEncode, addScope, addMaybeProxy
|
|
||||||
) where
|
|
||||||
-import Blaze.ByteString.Builder (toByteString, Builder)
|
|
||||||
-import Codec.Crypto.RSA (ha_SHA1, rsassa_pkcs1_v1_5_sign)
|
|
||||||
-import Control.Exception
|
|
||||||
-import Control.Monad
|
|
||||||
-import Control.Monad.IO.Class (MonadIO, liftIO)
|
|
||||||
-import Control.Monad.Trans.Control
|
|
||||||
-import Control.Monad.Trans.Resource
|
|
||||||
-import Crypto.Types.PubKey.RSA (PrivateKey (..), PublicKey (..))
|
|
||||||
-import Data.ByteString.Base64
|
|
||||||
-import qualified Data.ByteString.Char8 as BS
|
|
||||||
-import qualified Data.ByteString.Lazy.Char8 as BSL
|
|
||||||
-import Data.Char
|
|
||||||
-import Data.Conduit (Source, ($$), ($=))
|
|
||||||
-import Data.Conduit.Blaze (builderToByteString)
|
|
||||||
-import qualified Data.Conduit.List as CL
|
|
||||||
-import Data.Default
|
|
||||||
-import Data.Digest.Pure.SHA
|
|
||||||
-import qualified Data.IORef as I
|
|
||||||
-import Data.List (sortBy)
|
|
||||||
-import Data.Maybe
|
|
||||||
-import Data.Time
|
|
||||||
-import Network.HTTP.Conduit
|
|
||||||
-import Network.HTTP.Types (SimpleQuery, parseSimpleQuery)
|
|
||||||
-import Network.HTTP.Types (Header)
|
|
||||||
-import Network.HTTP.Types (renderSimpleQuery, status200)
|
|
||||||
-import Numeric
|
|
||||||
-import System.Random
|
|
||||||
-#if MIN_VERSION_base(4,7,0)
|
|
||||||
-import Data.Data hiding (Proxy (..))
|
|
||||||
-#else
|
|
||||||
+import Network.HTTP.Conduit
|
|
||||||
import Data.Data
|
|
||||||
+import qualified Data.ByteString.Char8 as BS
|
|
||||||
+import qualified Data.ByteString.Lazy.Char8 as BSL
|
|
||||||
+import Data.Maybe
|
|
||||||
+import Network.HTTP.Types (parseSimpleQuery, SimpleQuery)
|
|
||||||
+import Control.Exception
|
|
||||||
+import Control.Monad
|
|
||||||
+import Data.List (sortBy)
|
|
||||||
+import System.Random
|
|
||||||
+import Data.Char
|
|
||||||
+import Data.Digest.Pure.SHA
|
|
||||||
+import Data.ByteString.Base64
|
|
||||||
+import Data.Time
|
|
||||||
+import Numeric
|
|
||||||
+#if MIN_VERSION_RSA(2, 0, 0)
|
|
||||||
+import Codec.Crypto.RSA (rsassa_pkcs1_v1_5_sign, hashSHA1)
|
|
||||||
+#else
|
|
||||||
+import Codec.Crypto.RSA (rsassa_pkcs1_v1_5_sign, ha_SHA1)
|
|
||||||
#endif
|
|
||||||
+import Crypto.Types.PubKey.RSA (PrivateKey(..), PublicKey(..))
|
|
||||||
+import Network.HTTP.Types (Header)
|
|
||||||
+import Blaze.ByteString.Builder (toByteString)
|
|
||||||
+import Control.Monad.IO.Class (MonadIO)
|
|
||||||
+import Network.HTTP.Types (renderSimpleQuery, status200)
|
|
||||||
+import Data.Conduit (($$), ($=), Source)
|
|
||||||
+import qualified Data.Conduit.List as CL
|
|
||||||
+import Data.Conduit.Blaze (builderToByteString)
|
|
||||||
+import Blaze.ByteString.Builder (Builder)
|
|
||||||
+import Control.Monad.IO.Class (liftIO)
|
|
||||||
+import Control.Monad.Trans.Control
|
|
||||||
+import Control.Monad.Trans.Resource
|
|
||||||
+import Data.Default
|
|
||||||
+import qualified Data.IORef as I
|
|
||||||
|
|
||||||
-- | Data type for OAuth client (consumer).
|
|
||||||
---
|
|
||||||
--- The constructor for this data type is not exposed.
|
|
||||||
--- Instead, you should use the 'def' method or 'newOAuth' function to retrieve a default instance,
|
|
||||||
+--
|
|
||||||
+-- The constructor for this data type is not exposed.
|
|
||||||
+-- Instead, you should use the 'def' method or 'newOAuth' function to retrieve a default instance,
|
|
||||||
-- and then use the records below to make modifications.
|
|
||||||
-- This approach allows us to add configuration options without breaking backwards compatibility.
|
|
||||||
data OAuth = OAuth { oauthServerName :: String -- ^ Service name (default: @\"\"@)
|
|
||||||
@@ -71,7 +73,7 @@
|
|
||||||
, oauthAuthorizeUri :: String
|
|
||||||
-- ^ Uri to authorize (default: @\"\"@).
|
|
||||||
-- You MUST specify if you use 'authorizeUrl' or 'authorizeZUrl'';
|
|
||||||
- -- otherwise you can just leave this empty.
|
|
||||||
+ -- otherwise you can just leave this empty.
|
|
||||||
, oauthSignatureMethod :: SignMethod
|
|
||||||
-- ^ Signature Method (default: 'HMACSHA1')
|
|
||||||
, oauthConsumerKey :: BS.ByteString
|
|
||||||
@@ -188,7 +190,7 @@
|
|
||||||
getTemporaryCredential' hook oa manager = do
|
|
||||||
let req = fromJust $ parseUrl $ oauthRequestUri oa
|
|
||||||
crd = maybe id (insert "oauth_callback") (oauthCallback oa) $ emptyCredential
|
|
||||||
- req' <- signOAuth oa crd $ hook (req { method = "POST" })
|
|
||||||
+ req' <- signOAuth oa crd $ hook (req { method = "POST" })
|
|
||||||
rsp <- httpLbs req' manager
|
|
||||||
if responseStatus rsp == status200
|
|
||||||
then do
|
|
||||||
@@ -211,7 +213,7 @@
|
|
||||||
-> String -- ^ URL to authorize
|
|
||||||
authorizeUrl' f oa cr = oauthAuthorizeUri oa ++ BS.unpack (renderSimpleQuery True queries)
|
|
||||||
where fixed = ("oauth_token", token cr):f oa cr
|
|
||||||
- queries =
|
|
||||||
+ queries =
|
|
||||||
case oauthCallback oa of
|
|
||||||
Nothing -> fixed
|
|
||||||
Just callback -> ("oauth_callback", callback):fixed
|
|
||||||
@@ -346,7 +348,11 @@
|
|
||||||
PLAINTEXT ->
|
|
||||||
return $ BS.intercalate "&" $ map paramEncode [oauthConsumerSecret oa, tokenSecret tok]
|
|
||||||
RSASHA1 pr ->
|
|
||||||
+#if MIN_VERSION_RSA(2, 0, 0)
|
|
||||||
+ liftM (encode . toStrict . rsassa_pkcs1_v1_5_sign hashSHA1 pr) (getBaseString tok req)
|
|
||||||
+#else
|
|
||||||
liftM (encode . toStrict . rsassa_pkcs1_v1_5_sign ha_SHA1 pr) (getBaseString tok req)
|
|
||||||
+#endif
|
|
||||||
|
|
||||||
#if MIN_VERSION_http_conduit(2, 0, 0)
|
|
||||||
addAuthHeader :: BS.ByteString -> Credential -> Request -> Request
|
|
||||||
@ -1,596 +0,0 @@
|
|||||||
diff -ru orig/Aws/Aws.hs new/Aws/Aws.hs
|
|
||||||
--- orig/Aws/Aws.hs 2014-04-04 10:18:25.108401067 +0300
|
|
||||||
+++ new/Aws/Aws.hs 2014-04-04 10:18:24.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-04 10:18:25.108401067 +0300
|
|
||||||
+++ new/Aws/Core.hs 2014-04-04 10:18:24.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-04 10:18:25.108401067 +0300
|
|
||||||
+++ new/Aws/DynamoDb/Core.hs 2014-04-04 10:18:24.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-04 10:18:25.112401067 +0300
|
|
||||||
+++ new/Aws/Ec2/InstanceMetadata.hs 2014-04-04 10:18:24.000000000 +0300
|
|
||||||
@@ -2,7 +2,7 @@
|
|
||||||
|
|
||||||
import Control.Applicative
|
|
||||||
import Control.Exception
|
|
||||||
-import Control.Failure
|
|
||||||
+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
|
|
||||||
@@ -25,7 +25,7 @@
|
|
||||||
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 -> IO L.ByteString
|
|
||||||
diff -ru orig/Aws/Iam/Core.hs new/Aws/Iam/Core.hs
|
|
||||||
--- orig/Aws/Iam/Core.hs 2014-04-04 10:18:25.112401067 +0300
|
|
||||||
+++ new/Aws/Iam/Core.hs 2014-04-04 10:18:24.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-04 10:18:25.112401067 +0300
|
|
||||||
+++ new/Aws/Iam/Internal.hs 2014-04-04 10:18:24.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-04 10:18:25.112401067 +0300
|
|
||||||
+++ new/Aws/S3/Commands/CopyObject.hs 2014-04-04 10:18:24.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-04 10:18:25.112401067 +0300
|
|
||||||
+++ new/Aws/S3/Core.hs 2014-04-04 10:18:24.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-04 10:18:25.112401067 +0300
|
|
||||||
+++ new/Aws/Ses/Core.hs 2014-04-04 10:18:24.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-04 10:18:25.116401067 +0300
|
|
||||||
+++ new/Aws/SimpleDb/Core.hs 2014-04-04 10:18:24.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-04 10:18:25.116401067 +0300
|
|
||||||
+++ new/Aws/Sqs/Commands/Message.hs 2014-04-04 10:18:24.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-04 10:18:25.116401067 +0300
|
|
||||||
+++ new/Aws/Sqs/Core.hs 2014-04-04 10:18:24.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-04 10:18:25.120401065 +0300
|
|
||||||
+++ new/aws.cabal 2014-04-04 10:18:24.000000000 +0300
|
|
||||||
@@ -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,30 @@
|
|
||||||
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.2 && <1.3
|
|
||||||
+ , ghc-prim
|
|
||||||
|
|
||||||
GHC-Options: -Wall
|
|
||||||
|
|
||||||
12
patching/patches/aws-0.9.3.patch
Normal file
12
patching/patches/aws-0.9.3.patch
Normal file
@ -0,0 +1,12 @@
|
|||||||
|
diff -ruN orig/aws.cabal new/aws.cabal
|
||||||
|
--- orig/aws.cabal 2014-08-28 07:02:24.655832025 +0300
|
||||||
|
+++ new/aws.cabal 2014-08-28 07:02:24.000000000 +0300
|
||||||
|
@@ -109,7 +109,7 @@
|
||||||
|
bytestring >= 0.9 && < 0.11,
|
||||||
|
case-insensitive >= 0.2 && < 1.3,
|
||||||
|
cereal >= 0.3 && < 0.5,
|
||||||
|
- conduit >= 1.1 && < 1.2,
|
||||||
|
+ conduit >= 1.1 && < 1.3,
|
||||||
|
conduit-extra >= 1.1 && < 1.2,
|
||||||
|
containers >= 0.4,
|
||||||
|
cryptohash >= 0.11 && < 0.12,
|
||||||
@ -1,25 +0,0 @@
|
|||||||
diff -ru orig/src/Data/Bytes/Serial.hs new/src/Data/Bytes/Serial.hs
|
|
||||||
--- orig/src/Data/Bytes/Serial.hs 2014-06-08 07:58:00.820951939 +0300
|
|
||||||
+++ new/src/Data/Bytes/Serial.hs 2014-06-08 07:58:00.000000000 +0300
|
|
||||||
@@ -58,7 +58,9 @@
|
|
||||||
import Data.Int
|
|
||||||
import Data.Bits
|
|
||||||
import Data.Monoid as Monoid
|
|
||||||
+#if MIN_VERSION_base(4, 6, 0)
|
|
||||||
import Data.Ord (Down(..))
|
|
||||||
+#endif
|
|
||||||
import Data.Functor.Identity as Functor
|
|
||||||
import Data.Functor.Constant as Functor
|
|
||||||
import Data.Functor.Product as Functor
|
|
||||||
@@ -475,9 +477,11 @@
|
|
||||||
serialize = serialize . (fromIntegral::Int -> Int8) . fromEnum
|
|
||||||
deserialize = (toEnum . (fromIntegral::Int8 -> Int)) `liftM` deserialize
|
|
||||||
|
|
||||||
+#if MIN_VERSION_base(4, 6, 0)
|
|
||||||
instance Serial a => Serial (Down a) where
|
|
||||||
serialize (Down a) = serialize a
|
|
||||||
deserialize = Down `liftM` deserialize
|
|
||||||
+#endif
|
|
||||||
|
|
||||||
instance Serial Version where
|
|
||||||
serialize (Version vb ts) = serialize (fmap VarInt vb, ts)
|
|
||||||
@ -1,46 +0,0 @@
|
|||||||
diff -ru orig/bzlib-conduit.cabal new/bzlib-conduit.cabal
|
|
||||||
--- orig/bzlib-conduit.cabal 2014-04-02 12:25:07.231917434 +0300
|
|
||||||
+++ new/bzlib-conduit.cabal 2014-04-02 12:25:06.000000000 +0300
|
|
||||||
@@ -26,7 +26,8 @@
|
|
||||||
build-depends: base == 4.*
|
|
||||||
, bytestring >=0.9 && <0.11
|
|
||||||
, mtl == 2.*
|
|
||||||
- , conduit >= 0.5 && < 1.1
|
|
||||||
+ , conduit >= 0.5 && < 1.2
|
|
||||||
+ , conduit-extra >= 1.0 && < 1.2
|
|
||||||
, resourcet
|
|
||||||
, data-default
|
|
||||||
, bindings-DSL
|
|
||||||
@@ -54,7 +55,9 @@
|
|
||||||
, QuickCheck
|
|
||||||
, random
|
|
||||||
, conduit
|
|
||||||
+ , conduit-extra
|
|
||||||
, bzlib-conduit
|
|
||||||
+ , resourcet
|
|
||||||
|
|
||||||
benchmark bench
|
|
||||||
type: exitcode-stdio-1.0
|
|
||||||
@@ -62,4 +65,5 @@
|
|
||||||
main-is: bench.hs
|
|
||||||
build-depends: base == 4.*
|
|
||||||
, conduit
|
|
||||||
+ , conduit-extra
|
|
||||||
, bzlib-conduit
|
|
||||||
diff -ru orig/test/test.hs new/test/test.hs
|
|
||||||
--- orig/test/test.hs 2014-04-02 12:25:07.227917434 +0300
|
|
||||||
+++ new/test/test.hs 2014-04-02 12:25:06.000000000 +0300
|
|
||||||
@@ -1,6 +1,7 @@
|
|
||||||
{-# LANGUAGE ViewPatterns #-}
|
|
||||||
import Control.Applicative
|
|
||||||
import Control.Monad
|
|
||||||
+import Control.Monad.Trans.Resource (runResourceT)
|
|
||||||
import qualified Data.ByteString.Char8 as S
|
|
||||||
import qualified Data.ByteString.Lazy.Char8 as L
|
|
||||||
import Data.Conduit
|
|
||||||
@@ -36,4 +37,4 @@
|
|
||||||
<$> replicateM (abs n) randomIO
|
|
||||||
dest <- runResourceT $ do
|
|
||||||
C.sourceList (P.map S.pack ss) =$= bzip2 =$= bunzip2 $$ B.take (10^9)
|
|
||||||
- return $ dest == L.pack (concat ss)
|
|
||||||
+ return $ dest == L.pack (P.concat ss)
|
|
||||||
@ -1,53 +0,0 @@
|
|||||||
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
|
|
||||||
@ -1,21 +0,0 @@
|
|||||||
diff -ru orig/concurrent-extra.cabal new/concurrent-extra.cabal
|
|
||||||
--- orig/concurrent-extra.cabal 2014-04-04 14:42:42.732063525 +0300
|
|
||||||
+++ new/concurrent-extra.cabal 2014-04-04 14:42:42.000000000 +0300
|
|
||||||
@@ -50,7 +50,7 @@
|
|
||||||
-------------------------------------------------------------------------------
|
|
||||||
|
|
||||||
library
|
|
||||||
- build-depends: base >= 3 && < 4.7
|
|
||||||
+ build-depends: base >= 3 && < 4.8
|
|
||||||
, base-unicode-symbols >= 0.1.1 && < 0.3
|
|
||||||
, stm >= 2.1.2.1 && < 2.5
|
|
||||||
, unbounded-delays >= 0.1 && < 0.2
|
|
||||||
@@ -80,7 +80,7 @@
|
|
||||||
|
|
||||||
ghc-options: -Wall -threaded
|
|
||||||
|
|
||||||
- build-depends: base >= 3 && < 4.7
|
|
||||||
+ build-depends: base >= 3 && < 4.8
|
|
||||||
, base-unicode-symbols >= 0.1.1 && < 0.3
|
|
||||||
, stm >= 2.1.2.1 && < 2.5
|
|
||||||
, unbounded-delays >= 0.1 && < 0.2
|
|
||||||
File diff suppressed because one or more lines are too long
@ -1,32 +0,0 @@
|
|||||||
diff -ru orig/csv-conduit.cabal new/csv-conduit.cabal
|
|
||||||
--- orig/csv-conduit.cabal 2014-04-03 10:44:52.994206357 +0300
|
|
||||||
+++ new/csv-conduit.cabal 2014-04-03 10:44:52.000000000 +0300
|
|
||||||
@@ -78,6 +78,7 @@
|
|
||||||
, base >= 4 && < 5
|
|
||||||
, bytestring
|
|
||||||
, conduit >= 1.0 && < 2.0
|
|
||||||
+ , conduit-extra
|
|
||||||
, containers >= 0.3
|
|
||||||
, monad-control
|
|
||||||
, text
|
|
||||||
@@ -90,6 +91,7 @@
|
|
||||||
, mtl
|
|
||||||
, mmorph
|
|
||||||
, primitive
|
|
||||||
+ , resourcet
|
|
||||||
ghc-prof-options: -fprof-auto
|
|
||||||
|
|
||||||
if impl(ghc >= 7.2.1)
|
|
||||||
diff -ru orig/src/Data/CSV/Conduit.hs new/src/Data/CSV/Conduit.hs
|
|
||||||
--- orig/src/Data/CSV/Conduit.hs 2014-04-03 10:44:52.962206360 +0300
|
|
||||||
+++ new/src/Data/CSV/Conduit.hs 2014-04-03 10:44:52.000000000 +0300
|
|
||||||
@@ -36,6 +36,9 @@
|
|
||||||
import Control.Monad.Primitive
|
|
||||||
import Control.Monad.ST
|
|
||||||
import Control.Monad.Trans
|
|
||||||
+import Control.Monad.Trans.Resource (MonadResource, MonadThrow,
|
|
||||||
+ runExceptionT,
|
|
||||||
+ runResourceT)
|
|
||||||
import Data.Attoparsec.Types (Parser)
|
|
||||||
import qualified Data.ByteString as B
|
|
||||||
import Data.ByteString.Char8 (ByteString)
|
|
||||||
@ -1,12 +0,0 @@
|
|||||||
diff -ru orig/diagrams-builder.cabal new/diagrams-builder.cabal
|
|
||||||
--- orig/diagrams-builder.cabal 2014-05-23 06:40:50.633726383 +0300
|
|
||||||
+++ new/diagrams-builder.cabal 2014-05-23 06:40:50.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.6
|
|
||||||
+ exceptions >= 0.3 && < 0.7
|
|
||||||
hs-source-dirs: src
|
|
||||||
default-language: Haskell2010
|
|
||||||
other-extensions: StandaloneDeriving,
|
|
||||||
@ -1,12 +0,0 @@
|
|||||||
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,
|
|
||||||
@ -1,12 +0,0 @@
|
|||||||
diff -ru orig/diagrams-builder.cabal new/diagrams-builder.cabal
|
|
||||||
--- orig/diagrams-builder.cabal 2014-05-11 11:28:24.019992070 +0300
|
|
||||||
+++ new/diagrams-builder.cabal 2014-05-11 11:28:23.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.6
|
|
||||||
+ exceptions >= 0.3 && < 0.7
|
|
||||||
hs-source-dirs: src
|
|
||||||
default-language: Haskell2010
|
|
||||||
other-extensions: StandaloneDeriving,
|
|
||||||
@ -1,27 +0,0 @@
|
|||||||
diff -ruN orig/diagrams-builder.cabal new/diagrams-builder.cabal
|
|
||||||
--- orig/diagrams-builder.cabal 2014-08-10 08:43:22.462711726 +0300
|
|
||||||
+++ new/diagrams-builder.cabal 2014-08-10 08:43:22.000000000 +0300
|
|
||||||
@@ -57,7 +57,7 @@
|
|
||||||
split >= 0.2 && < 0.3,
|
|
||||||
haskell-src-exts >= 1.14 && < 1.16,
|
|
||||||
cmdargs >= 0.6 && < 0.11,
|
|
||||||
- lens >= 3.9 && < 4.3,
|
|
||||||
+ lens,
|
|
||||||
hashable >= 1.1 && < 1.3,
|
|
||||||
exceptions >= 0.3 && < 0.7
|
|
||||||
hs-source-dirs: src
|
|
||||||
@@ -100,7 +100,7 @@
|
|
||||||
diagrams-lib >= 0.6 && < 1.3,
|
|
||||||
diagrams-cairo >= 0.6 && < 1.3,
|
|
||||||
cmdargs >= 0.6 && < 0.11,
|
|
||||||
- lens >= 3.8 && < 4.3
|
|
||||||
+ lens
|
|
||||||
|
|
||||||
executable diagrams-builder-svg
|
|
||||||
main-is: diagrams-builder-svg.hs
|
|
||||||
@@ -141,4 +141,4 @@
|
|
||||||
diagrams-lib >= 0.6 && < 1.3,
|
|
||||||
diagrams-postscript >= 0.6 && < 1.2,
|
|
||||||
cmdargs >= 0.6 && < 0.11,
|
|
||||||
- lens >= 3.8 && < 4.3
|
|
||||||
+ lens
|
|
||||||
@ -1,21 +0,0 @@
|
|||||||
diff -ruN orig/diagrams-haddock.cabal new/diagrams-haddock.cabal
|
|
||||||
--- orig/diagrams-haddock.cabal 2014-08-10 08:43:22.698711721 +0300
|
|
||||||
+++ new/diagrams-haddock.cabal 2014-08-10 08:43:22.000000000 +0300
|
|
||||||
@@ -48,7 +48,7 @@
|
|
||||||
diagrams-lib >= 0.6 && < 1.3,
|
|
||||||
diagrams-svg >= 0.8.0.1 && < 1.2,
|
|
||||||
vector-space >= 0.8 && < 0.9,
|
|
||||||
- lens >= 3.8 && < 4.3,
|
|
||||||
+ lens,
|
|
||||||
cpphs >= 1.15,
|
|
||||||
cautious-file >= 1.0 && < 1.1,
|
|
||||||
uniplate >= 1.6 && < 1.7,
|
|
||||||
@@ -81,7 +81,7 @@
|
|
||||||
tasty-quickcheck >= 0.8 && < 0.9,
|
|
||||||
parsec >= 3,
|
|
||||||
haskell-src-exts >= 1.14 && < 1.16,
|
|
||||||
- lens >= 3.8 && < 4.3,
|
|
||||||
+ lens,
|
|
||||||
diagrams-haddock
|
|
||||||
hs-source-dirs: test
|
|
||||||
default-language: Haskell2010
|
|
||||||
@ -1,96 +0,0 @@
|
|||||||
diff -ru orig/distributed-process.cabal new/distributed-process.cabal
|
|
||||||
--- orig/distributed-process.cabal 2014-03-27 18:23:44.792359466 +0200
|
|
||||||
+++ new/distributed-process.cabal 2014-03-27 18:23:44.000000000 +0200
|
|
||||||
@@ -39,7 +39,7 @@
|
|
||||||
|
|
||||||
Library
|
|
||||||
Build-Depends: base >= 4.4 && < 5,
|
|
||||||
- binary >= 0.5 && < 0.7,
|
|
||||||
+ binary >= 0.5,
|
|
||||||
network-transport >= 0.3 && < 0.4,
|
|
||||||
stm >= 2.3 && < 2.5,
|
|
||||||
transformers >= 0.2 && < 0.4,
|
|
||||||
@@ -53,7 +53,7 @@
|
|
||||||
ghc-prim >= 0.2 && < 0.4,
|
|
||||||
distributed-static >= 0.2 && < 0.3,
|
|
||||||
rank1dynamic >= 0.1 && < 0.2,
|
|
||||||
- syb >= 0.3 && < 0.4
|
|
||||||
+ syb >= 0.3
|
|
||||||
Exposed-modules: Control.Distributed.Process,
|
|
||||||
Control.Distributed.Process.Serializable,
|
|
||||||
Control.Distributed.Process.Closure,
|
|
||||||
@@ -90,11 +90,11 @@
|
|
||||||
Main-Is: TestCH.hs
|
|
||||||
Build-Depends: base >= 4.4 && < 5,
|
|
||||||
random >= 1.0 && < 1.1,
|
|
||||||
- ansi-terminal >= 0.5 && < 0.6,
|
|
||||||
+ ansi-terminal >= 0.5,
|
|
||||||
distributed-process,
|
|
||||||
network-transport >= 0.3 && < 0.4,
|
|
||||||
network-transport-tcp >= 0.3 && < 0.4,
|
|
||||||
- binary >= 0.5 && < 0.7,
|
|
||||||
+ binary >= 0.5,
|
|
||||||
network >= 2.3 && < 2.5,
|
|
||||||
HUnit >= 1.2 && < 1.3,
|
|
||||||
test-framework >= 0.6 && < 0.9,
|
|
||||||
@@ -111,7 +111,7 @@
|
|
||||||
Main-Is: TestClosure.hs
|
|
||||||
Build-Depends: base >= 4.4 && < 5,
|
|
||||||
random >= 1.0 && < 1.1,
|
|
||||||
- ansi-terminal >= 0.5 && < 0.6,
|
|
||||||
+ ansi-terminal >= 0.5,
|
|
||||||
distributed-static >= 0.2 && < 0.3,
|
|
||||||
distributed-process,
|
|
||||||
network-transport >= 0.3 && < 0.4,
|
|
||||||
@@ -131,13 +131,13 @@
|
|
||||||
Main-Is: TestStats.hs
|
|
||||||
Build-Depends: base >= 4.4 && < 5,
|
|
||||||
random >= 1.0 && < 1.1,
|
|
||||||
- ansi-terminal >= 0.5 && < 0.6,
|
|
||||||
+ ansi-terminal >= 0.5,
|
|
||||||
containers >= 0.4 && < 0.6,
|
|
||||||
stm >= 2.3 && < 2.5,
|
|
||||||
distributed-process,
|
|
||||||
network-transport >= 0.3 && < 0.4,
|
|
||||||
network-transport-tcp >= 0.3 && < 0.4,
|
|
||||||
- binary >= 0.5 && < 0.7,
|
|
||||||
+ binary >= 0.5,
|
|
||||||
network >= 2.3 && < 2.5,
|
|
||||||
HUnit >= 1.2 && < 1.3,
|
|
||||||
test-framework >= 0.6 && < 0.9,
|
|
||||||
@@ -156,7 +156,7 @@
|
|
||||||
distributed-process,
|
|
||||||
network-transport-tcp >= 0.3 && < 0.4,
|
|
||||||
bytestring >= 0.9 && < 0.11,
|
|
||||||
- binary >= 0.5 && < 0.7
|
|
||||||
+ binary >= 0.5
|
|
||||||
else
|
|
||||||
buildable: False
|
|
||||||
Main-Is: benchmarks/Throughput.hs
|
|
||||||
@@ -169,7 +169,7 @@
|
|
||||||
distributed-process,
|
|
||||||
network-transport-tcp >= 0.3 && < 0.4,
|
|
||||||
bytestring >= 0.9 && < 0.11,
|
|
||||||
- binary >= 0.5 && < 0.7
|
|
||||||
+ binary >= 0.5
|
|
||||||
else
|
|
||||||
buildable: False
|
|
||||||
Main-Is: benchmarks/Latency.hs
|
|
||||||
@@ -182,7 +182,7 @@
|
|
||||||
distributed-process,
|
|
||||||
network-transport-tcp >= 0.3 && < 0.4,
|
|
||||||
bytestring >= 0.9 && < 0.11,
|
|
||||||
- binary >= 0.5 && < 0.7
|
|
||||||
+ binary >= 0.5
|
|
||||||
else
|
|
||||||
buildable: False
|
|
||||||
Main-Is: benchmarks/Channels.hs
|
|
||||||
@@ -195,7 +195,7 @@
|
|
||||||
distributed-process,
|
|
||||||
network-transport-tcp >= 0.3 && < 0.4,
|
|
||||||
bytestring >= 0.9 && < 0.11,
|
|
||||||
- binary >= 0.5 && < 0.7
|
|
||||||
+ binary >= 0.5
|
|
||||||
else
|
|
||||||
buildable: False
|
|
||||||
Main-Is: benchmarks/Spawns.hs
|
|
||||||
@ -1,21 +0,0 @@
|
|||||||
diff -ru orig/distributed-process-simplelocalnet.cabal new/distributed-process-simplelocalnet.cabal
|
|
||||||
--- orig/distributed-process-simplelocalnet.cabal 2014-03-27 18:23:44.960359467 +0200
|
|
||||||
+++ new/distributed-process-simplelocalnet.cabal 2014-03-27 18:23:44.000000000 +0200
|
|
||||||
@@ -33,7 +33,7 @@
|
|
||||||
network >= 2.3 && < 2.5,
|
|
||||||
network-multicast >= 0.0 && < 0.1,
|
|
||||||
data-accessor >= 0.2 && < 0.3,
|
|
||||||
- binary >= 0.5 && < 0.7,
|
|
||||||
+ binary >= 0.5,
|
|
||||||
containers >= 0.4 && < 0.6,
|
|
||||||
transformers >= 0.2 && < 0.4,
|
|
||||||
network-transport >= 0.3 && < 0.4,
|
|
||||||
@@ -55,7 +55,7 @@
|
|
||||||
network >= 2.3 && < 2.5,
|
|
||||||
network-multicast >= 0.0 && < 0.1,
|
|
||||||
data-accessor >= 0.2 && < 0.3,
|
|
||||||
- binary >= 0.5 && < 0.7,
|
|
||||||
+ binary >= 0.5,
|
|
||||||
containers >= 0.4 && < 0.6,
|
|
||||||
transformers >= 0.2 && < 0.4,
|
|
||||||
network-transport >= 0.3 && < 0.4,
|
|
||||||
@ -1,11 +0,0 @@
|
|||||||
diff -ru orig/distributive.cabal new/distributive.cabal
|
|
||||||
--- orig/distributive.cabal 2014-04-03 09:44:06.518283977 +0300
|
|
||||||
+++ new/distributive.cabal 2014-04-03 09:44:06.000000000 +0300
|
|
||||||
@@ -36,6 +36,7 @@
|
|
||||||
tagged >= 0.7 && < 1,
|
|
||||||
transformers >= 0.2 && < 0.4,
|
|
||||||
transformers-compat >= 0.1 && < 0.2
|
|
||||||
+ , ghc-prim
|
|
||||||
|
|
||||||
hs-source-dirs: src
|
|
||||||
exposed-modules:
|
|
||||||
@ -1,12 +0,0 @@
|
|||||||
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
|
|
||||||
@ -1,12 +0,0 @@
|
|||||||
diff -ru orig/fay.cabal new/fay.cabal
|
|
||||||
--- orig/fay.cabal 2014-03-13 05:59:43.874058759 +0200
|
|
||||||
+++ new/fay.cabal 2014-03-13 05:59:43.000000000 +0200
|
|
||||||
@@ -122,7 +122,7 @@
|
|
||||||
, language-ecmascript >= 0.15 && < 1.0
|
|
||||||
, mtl < 2.2
|
|
||||||
, pretty-show >= 1.6 && < 1.7
|
|
||||||
- , process < 1.2
|
|
||||||
+ , process < 1.3
|
|
||||||
, safe < 0.4
|
|
||||||
, split < 0.3
|
|
||||||
, syb < 0.5
|
|
||||||
@ -1,12 +0,0 @@
|
|||||||
diff -ru orig/fb.cabal new/fb.cabal
|
|
||||||
--- orig/fb.cabal 2014-06-30 12:41:53.267551936 +0300
|
|
||||||
+++ new/fb.cabal 2014-06-30 12:41:52.000000000 +0300
|
|
||||||
@@ -76,7 +76,7 @@
|
|
||||||
, data-default
|
|
||||||
, http-types
|
|
||||||
, http-conduit >= 2.0 && < 2.2
|
|
||||||
- , attoparsec >= 0.10.4 && < 0.12
|
|
||||||
+ , attoparsec >= 0.10.4 && < 0.13
|
|
||||||
, unordered-containers
|
|
||||||
, aeson >= 0.5 && < 0.8
|
|
||||||
, base16-bytestring >= 0.1
|
|
||||||
@ -1,12 +0,0 @@
|
|||||||
diff -ru orig/foldl.cabal new/foldl.cabal
|
|
||||||
--- orig/foldl.cabal 2014-03-13 07:47:41.009928017 +0200
|
|
||||||
+++ new/foldl.cabal 2014-03-13 07:47:40.000000000 +0200
|
|
||||||
@@ -24,7 +24,7 @@
|
|
||||||
base >= 4 && < 5 ,
|
|
||||||
bytestring >= 0.9.2.1 && < 0.11,
|
|
||||||
primitive < 0.6 ,
|
|
||||||
- text >= 0.11.2.0 && < 1.1 ,
|
|
||||||
+ text >= 0.11.2.0 && < 1.2 ,
|
|
||||||
vector >= 0.7 && < 0.11
|
|
||||||
Exposed-Modules:
|
|
||||||
Control.Foldl,
|
|
||||||
@ -1,12 +0,0 @@
|
|||||||
diff -ruN orig/force-layout.cabal new/force-layout.cabal
|
|
||||||
--- orig/force-layout.cabal 2014-08-10 08:43:22.898711717 +0300
|
|
||||||
+++ new/force-layout.cabal 2014-08-10 08:43:22.000000000 +0300
|
|
||||||
@@ -23,7 +23,7 @@
|
|
||||||
build-depends: base >= 4.2 && < 4.8,
|
|
||||||
vector-space >=0.7 && <0.9,
|
|
||||||
vector-space-points >= 0.1.1 && < 0.3,
|
|
||||||
- lens >= 3 && < 4.3,
|
|
||||||
+ lens,
|
|
||||||
containers >=0.4 && < 0.6,
|
|
||||||
data-default-class >= 0.0.1 && < 0.1
|
|
||||||
hs-source-dirs: src
|
|
||||||
@ -1,23 +0,0 @@
|
|||||||
diff -ru orig/Github/Private.hs new/Github/Private.hs
|
|
||||||
--- orig/Github/Private.hs 2014-04-03 09:50:34.182275724 +0300
|
|
||||||
+++ new/Github/Private.hs 2014-04-03 09:50:33.000000000 +0300
|
|
||||||
@@ -14,7 +14,7 @@
|
|
||||||
import qualified Data.ByteString.Lazy.Char8 as LBS
|
|
||||||
import Network.HTTP.Types (Method, Status(..))
|
|
||||||
import Network.HTTP.Conduit
|
|
||||||
-import Data.Conduit (ResourceT)
|
|
||||||
+import Control.Monad.Trans.Resource (ResourceT)
|
|
||||||
import qualified Control.Exception as E
|
|
||||||
import Data.Maybe (fromMaybe)
|
|
||||||
|
|
||||||
diff -ru orig/github.cabal new/github.cabal
|
|
||||||
--- orig/github.cabal 2014-04-03 09:50:34.194275724 +0300
|
|
||||||
+++ new/github.cabal 2014-04-03 09:50:33.000000000 +0300
|
|
||||||
@@ -158,6 +158,7 @@
|
|
||||||
http-types,
|
|
||||||
data-default,
|
|
||||||
vector,
|
|
||||||
+ resourcet,
|
|
||||||
unordered-containers >= 0.2 && < 0.3
|
|
||||||
|
|
||||||
-- Modules not exported by this package.
|
|
||||||
@ -1,191 +0,0 @@
|
|||||||
diff -ru orig/Git/Commit/Push.hs new/Git/Commit/Push.hs
|
|
||||||
--- orig/Git/Commit/Push.hs 2014-04-06 09:02:45.571789820 +0300
|
|
||||||
+++ new/Git/Commit/Push.hs 2014-04-06 09:02:45.000000000 +0300
|
|
||||||
@@ -1,11 +1,11 @@
|
|
||||||
module Git.Commit.Push where
|
|
||||||
|
|
||||||
import Control.Applicative
|
|
||||||
-import Control.Failure
|
|
||||||
import Control.Monad
|
|
||||||
import Control.Monad.IO.Class
|
|
||||||
import Control.Monad.Trans.Class
|
|
||||||
import Control.Monad.Trans.Control
|
|
||||||
+import Control.Monad.Trans.Resource
|
|
||||||
import Data.Function
|
|
||||||
import qualified Data.HashSet as HashSet
|
|
||||||
import Data.List
|
|
||||||
@@ -33,14 +33,14 @@
|
|
||||||
mrref' <- for mrref $ \rref ->
|
|
||||||
if rref `elem` commits
|
|
||||||
then lift $ copyCommitOid rref
|
|
||||||
- else failure $ PushNotFastForward
|
|
||||||
+ else throwM $ PushNotFastForward
|
|
||||||
$ "SHA " <> renderObjOid rref
|
|
||||||
<> " not found in remote"
|
|
||||||
objs <- lift $ listAllObjects mrref' coid
|
|
||||||
let shas = HashSet.fromList $ map (renderOid . untagObjOid) objs
|
|
||||||
(cref,_) <- copyCommit coid Nothing shas
|
|
||||||
unless (renderObjOid coid == renderObjOid cref) $
|
|
||||||
- failure $ BackendError $ "Error copying commit: "
|
|
||||||
+ throwM $ BackendError $ "Error copying commit: "
|
|
||||||
<> renderObjOid coid <> " /= " <> renderObjOid cref
|
|
||||||
-- jww (2013-04-18): This is something the user must decide to do
|
|
||||||
-- updateReference_ remoteRefName (RefObj cref)
|
|
||||||
@@ -79,6 +79,6 @@
|
|
||||||
|
|
||||||
mref <- fmap renderOid <$> resolveReference refName
|
|
||||||
unless (maybe False (renderObjOid coid ==) mref) $
|
|
||||||
- failure (BackendError $
|
|
||||||
+ throwM (BackendError $
|
|
||||||
"Could not resolve destination reference '"
|
|
||||||
<> refName <> "'in project")
|
|
||||||
diff -ru orig/Git/Commit.hs new/Git/Commit.hs
|
|
||||||
--- orig/Git/Commit.hs 2014-04-06 09:02:45.571789820 +0300
|
|
||||||
+++ new/Git/Commit.hs 2014-04-06 09:02:45.000000000 +0300
|
|
||||||
@@ -1,8 +1,8 @@
|
|
||||||
module Git.Commit where
|
|
||||||
|
|
||||||
-import Control.Failure
|
|
||||||
import Control.Monad
|
|
||||||
import Control.Monad.Trans.Class
|
|
||||||
+import Control.Monad.Trans.Resource
|
|
||||||
import Data.Conduit
|
|
||||||
import qualified Data.Conduit.List as CL
|
|
||||||
import Data.Function
|
|
||||||
@@ -41,7 +41,7 @@
|
|
||||||
(parentRefs,needed') <- foldM copyParent ([],needed) parents
|
|
||||||
(tr,needed'') <- copyTree (commitTree commit) needed'
|
|
||||||
unless (renderObjOid (commitTree commit) == renderObjOid tr) $
|
|
||||||
- failure $ BackendError $ "Error copying tree: "
|
|
||||||
+ throwM $ BackendError $ "Error copying tree: "
|
|
||||||
<> renderObjOid (commitTree commit)
|
|
||||||
<> " /= " <> renderObjOid tr
|
|
||||||
|
|
||||||
@@ -60,7 +60,7 @@
|
|
||||||
copyParent (prefs,needed') cref = do
|
|
||||||
(cref2,needed'') <- copyCommit cref Nothing needed'
|
|
||||||
unless (renderObjOid cref == renderObjOid cref2) $
|
|
||||||
- failure $ BackendError $ "Error copying commit: "
|
|
||||||
+ throwM $ BackendError $ "Error copying commit: "
|
|
||||||
<> renderObjOid cref <> " /= " <> renderObjOid cref2
|
|
||||||
let x = cref2 `seq` (cref2:prefs)
|
|
||||||
return $ x `seq` needed'' `seq` (x,needed'')
|
|
||||||
diff -ru orig/Git/Repository.hs new/Git/Repository.hs
|
|
||||||
--- orig/Git/Repository.hs 2014-04-06 09:02:45.571789820 +0300
|
|
||||||
+++ new/Git/Repository.hs 2014-04-06 09:02:45.000000000 +0300
|
|
||||||
@@ -6,6 +6,7 @@
|
|
||||||
import Data.Conduit
|
|
||||||
import Git.Types
|
|
||||||
import System.Directory
|
|
||||||
+import Control.Monad.Trans.Control (MonadBaseControl)
|
|
||||||
|
|
||||||
withNewRepository :: (MonadGit r n, MonadBaseControl IO n, MonadIO m)
|
|
||||||
=> RepositoryFactory n m r
|
|
||||||
diff -ru orig/Git/Tree/Builder.hs new/Git/Tree/Builder.hs
|
|
||||||
--- orig/Git/Tree/Builder.hs 2014-04-06 09:02:45.571789820 +0300
|
|
||||||
+++ new/Git/Tree/Builder.hs 2014-04-06 09:02:45.000000000 +0300
|
|
||||||
@@ -25,12 +25,12 @@
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Control.Applicative
|
|
||||||
-import Control.Failure
|
|
||||||
import Control.Monad
|
|
||||||
import Control.Monad.Fix
|
|
||||||
import Control.Monad.Logger
|
|
||||||
import Control.Monad.IO.Class
|
|
||||||
import Control.Monad.Trans.Class
|
|
||||||
+import Control.Monad.Trans.Resource
|
|
||||||
import Control.Monad.Trans.State
|
|
||||||
import qualified Data.ByteString as B
|
|
||||||
import Data.Char
|
|
||||||
@@ -143,9 +143,9 @@
|
|
||||||
|
|
||||||
update bm _ _ (Right Nothing) = return (bm, TreeEntryNotFound)
|
|
||||||
update _ _ _ (Right (Just BlobEntry {})) =
|
|
||||||
- failure TreeCannotTraverseBlob
|
|
||||||
+ throwM TreeCannotTraverseBlob
|
|
||||||
update _ _ _ (Right (Just CommitEntry {})) =
|
|
||||||
- failure TreeCannotTraverseCommit
|
|
||||||
+ throwM TreeCannotTraverseCommit
|
|
||||||
|
|
||||||
update bm name names arg = do
|
|
||||||
sbm <- case arg of
|
|
||||||
diff -ru orig/Git/Tree.hs new/Git/Tree.hs
|
|
||||||
--- orig/Git/Tree.hs 2014-04-06 09:02:45.571789820 +0300
|
|
||||||
+++ new/Git/Tree.hs 2014-04-06 09:02:45.000000000 +0300
|
|
||||||
@@ -1,8 +1,8 @@
|
|
||||||
module Git.Tree where
|
|
||||||
|
|
||||||
-import Control.Failure
|
|
||||||
import Control.Monad
|
|
||||||
import Control.Monad.Trans.Class
|
|
||||||
+import Control.Monad.Trans.Resource
|
|
||||||
import Data.Conduit
|
|
||||||
import qualified Data.Conduit.List as CL
|
|
||||||
import Data.HashSet (HashSet)
|
|
||||||
@@ -22,7 +22,7 @@
|
|
||||||
copyTreeEntry (BlobEntry oid kind) needed = do
|
|
||||||
(b,needed') <- copyBlob oid needed
|
|
||||||
unless (renderObjOid oid == renderObjOid b) $
|
|
||||||
- failure $ BackendError $ "Error copying blob: "
|
|
||||||
+ throwM $ BackendError $ "Error copying blob: "
|
|
||||||
<> renderObjOid oid <> " /= " <> renderObjOid b
|
|
||||||
return (BlobEntry b kind, needed')
|
|
||||||
copyTreeEntry (CommitEntry oid) needed = do
|
|
||||||
diff -ru orig/Git/Types.hs new/Git/Types.hs
|
|
||||||
--- orig/Git/Types.hs 2014-04-06 09:02:45.571789820 +0300
|
|
||||||
+++ new/Git/Types.hs 2014-04-06 09:02:45.000000000 +0300
|
|
||||||
@@ -2,9 +2,9 @@
|
|
||||||
|
|
||||||
import Control.Applicative
|
|
||||||
import qualified Control.Exception.Lifted as Exc
|
|
||||||
-import Control.Failure
|
|
||||||
import Control.Monad
|
|
||||||
import Control.Monad.Trans.Class
|
|
||||||
+import Control.Monad.Trans.Resource
|
|
||||||
import Data.ByteString (ByteString)
|
|
||||||
import qualified Data.ByteString.Base16 as B16
|
|
||||||
import qualified Data.ByteString.Lazy as BL
|
|
||||||
@@ -35,7 +35,7 @@
|
|
||||||
|
|
||||||
-- | 'Repository' is the central point of contact between user code and Git
|
|
||||||
-- data objects. Every object must belong to some repository.
|
|
||||||
-class (Applicative m, Monad m, Failure GitException m,
|
|
||||||
+class (Applicative m, Monad m, MonadThrow m,
|
|
||||||
IsOid (Oid r), Show (Oid r), Eq (Oid r), Ord (Oid r))
|
|
||||||
=> MonadGit r m | m -> r where
|
|
||||||
type Oid r :: *
|
|
||||||
diff -ru orig/Git/Working.hs new/Git/Working.hs
|
|
||||||
--- orig/Git/Working.hs 2014-04-06 09:02:45.571789820 +0300
|
|
||||||
+++ new/Git/Working.hs 2014-04-06 09:02:45.000000000 +0300
|
|
||||||
@@ -3,7 +3,6 @@
|
|
||||||
module Git.Working where
|
|
||||||
|
|
||||||
import Control.Applicative
|
|
||||||
-import Control.Failure
|
|
||||||
import Control.Monad.IO.Class
|
|
||||||
import Control.Monad.Trans.Resource
|
|
||||||
import Data.Conduit
|
|
||||||
@@ -39,7 +38,7 @@
|
|
||||||
| cloneSubmodules -> cloneSubmodule oid fullPath
|
|
||||||
| otherwise -> liftIO $ createDirectory fullPath
|
|
||||||
where
|
|
||||||
- decodeError path e = failure $ PathEncodingError $
|
|
||||||
+ decodeError path e = throwM $ PathEncodingError $
|
|
||||||
"Could not decode path " <> T.pack (show path) <> ":" <> T.pack e
|
|
||||||
|
|
||||||
checkoutBlob oid kind fullPath = do
|
|
||||||
diff -ru orig/gitlib.cabal new/gitlib.cabal
|
|
||||||
--- orig/gitlib.cabal 2014-04-06 09:02:45.575789820 +0300
|
|
||||||
+++ new/gitlib.cabal 2014-04-06 09:02:45.000000000 +0300
|
|
||||||
@@ -43,9 +43,9 @@
|
|
||||||
, base16-bytestring >= 0.1.1.5
|
|
||||||
, bytestring >= 0.9.2.1
|
|
||||||
, conduit >= 1.0.0
|
|
||||||
+ , conduit-extra >= 1.0.0
|
|
||||||
, containers >= 0.4.2.1
|
|
||||||
, directory >= 1.1.0.2
|
|
||||||
- , failure >= 0.2.0.1
|
|
||||||
, filepath >= 1.3.0.0
|
|
||||||
, hashable >= 1.1.2.5
|
|
||||||
, lifted-base >= 0.2
|
|
||||||
@ -1,43 +0,0 @@
|
|||||||
diff -ru orig/Git/CmdLine.hs new/Git/CmdLine.hs
|
|
||||||
--- orig/Git/CmdLine.hs 2014-04-06 18:49:23.851795879 +0300
|
|
||||||
+++ new/Git/CmdLine.hs 2014-04-06 18:49:23.000000000 +0300
|
|
||||||
@@ -23,8 +23,9 @@
|
|
||||||
import Control.Monad.Reader.Class
|
|
||||||
import Control.Monad.Trans.Class
|
|
||||||
import Control.Monad.Trans.Reader (ReaderT, runReaderT)
|
|
||||||
+import Control.Monad.Trans.Resource (MonadThrow (..))
|
|
||||||
import qualified Data.ByteString as B
|
|
||||||
-import Data.Conduit hiding (MonadBaseControl)
|
|
||||||
+import Data.Conduit
|
|
||||||
import qualified Data.Conduit.List as CL
|
|
||||||
import Data.Foldable (for_)
|
|
||||||
import Data.Function
|
|
||||||
@@ -88,7 +89,7 @@
|
|
||||||
-- instance HasCliRepo (env, CliRepo) where
|
|
||||||
-- getCliRepo = snd
|
|
||||||
|
|
||||||
-instance (Applicative m, Failure GitException m, MonadIO m)
|
|
||||||
+instance (Applicative m, Failure GitException m, MonadIO m, MonadThrow m)
|
|
||||||
=> MonadGit CliRepo (ReaderT CliRepo m) where
|
|
||||||
type Oid CliRepo = SHA
|
|
||||||
data Tree CliRepo = CmdLineTree (TreeOid CliRepo)
|
|
||||||
@@ -127,7 +128,7 @@
|
|
||||||
|
|
||||||
diffContentsWithTree = error "Not defined cliDiffContentsWithTree"
|
|
||||||
|
|
||||||
-type MonadCli m = (Applicative m, Failure GitException m, MonadIO m)
|
|
||||||
+type MonadCli m = (Applicative m, Failure GitException m, MonadIO m, MonadThrow m)
|
|
||||||
|
|
||||||
mkOid :: MonadCli m => forall o. TL.Text -> ReaderT CliRepo m (Tagged o SHA)
|
|
||||||
mkOid = fmap Tagged <$> textToSha . toStrict
|
|
||||||
diff -ru orig/gitlib-cmdline.cabal new/gitlib-cmdline.cabal
|
|
||||||
--- orig/gitlib-cmdline.cabal 2014-04-06 18:49:23.895795879 +0300
|
|
||||||
+++ new/gitlib-cmdline.cabal 2014-04-06 18:49:23.000000000 +0300
|
|
||||||
@@ -39,6 +39,7 @@
|
|
||||||
, transformers >= 0.2.2
|
|
||||||
, transformers-base >= 0.4.1
|
|
||||||
, unordered-containers >= 0.2.3.0
|
|
||||||
+ , resourcet
|
|
||||||
exposed-modules:
|
|
||||||
Git.CmdLine
|
|
||||||
|
|
||||||
@ -1,280 +0,0 @@
|
|||||||
diff -ru orig/Git/Libgit2/Internal.hs new/Git/Libgit2/Internal.hs
|
|
||||||
--- orig/Git/Libgit2/Internal.hs 2014-04-06 09:02:46.523789820 +0300
|
|
||||||
+++ new/Git/Libgit2/Internal.hs 2014-04-06 09:02:46.000000000 +0300
|
|
||||||
@@ -8,9 +8,9 @@
|
|
||||||
|
|
||||||
import Bindings.Libgit2
|
|
||||||
import Control.Applicative
|
|
||||||
-import Control.Failure
|
|
||||||
import Control.Monad
|
|
||||||
import Control.Monad.Trans.Control
|
|
||||||
+import Control.Monad.Trans.Resource
|
|
||||||
import Data.ByteString
|
|
||||||
import qualified Data.Text as T
|
|
||||||
import qualified Data.Text.ICU.Convert as U
|
|
||||||
@@ -85,7 +85,7 @@
|
|
||||||
let p = castPtr ptr'
|
|
||||||
fptr <- FC.newForeignPtr p (c'git_object_free p)
|
|
||||||
run $ Right <$> createFn coidCopy (castForeignPtr fptr) ptr'
|
|
||||||
- either (failure . Git.BackendError) return result
|
|
||||||
+ either (throwM . Git.BackendError) return result
|
|
||||||
|
|
||||||
-- lgLookupObject :: Text -> LgRepository Dynamic
|
|
||||||
-- lgLookupObject str
|
|
||||||
diff -ru orig/Git/Libgit2/Types.hs new/Git/Libgit2/Types.hs
|
|
||||||
--- orig/Git/Libgit2/Types.hs 2014-04-06 09:02:46.523789820 +0300
|
|
||||||
+++ new/Git/Libgit2/Types.hs 2014-04-06 09:02:46.000000000 +0300
|
|
||||||
@@ -10,10 +10,10 @@
|
|
||||||
|
|
||||||
import Bindings.Libgit2
|
|
||||||
import Control.Applicative
|
|
||||||
-import Control.Failure
|
|
||||||
import Control.Monad.IO.Class
|
|
||||||
import Control.Monad.Logger
|
|
||||||
import Control.Monad.Trans.Control
|
|
||||||
+import Control.Monad.Trans.Resource
|
|
||||||
import Data.IORef
|
|
||||||
import Foreign.ForeignPtr
|
|
||||||
import qualified Git
|
|
||||||
@@ -52,7 +52,7 @@
|
|
||||||
type TreeBuilder = Git.TreeBuilder LgRepo
|
|
||||||
type Options = Git.Options LgRepo
|
|
||||||
|
|
||||||
-type MonadLg m = (Applicative m, Failure Git.GitException m,
|
|
||||||
+type MonadLg m = (Applicative m, MonadThrow m,
|
|
||||||
MonadIO m, MonadBaseControl IO m, MonadLogger m)
|
|
||||||
|
|
||||||
-- Types.hs
|
|
||||||
diff -ru orig/Git/Libgit2.hs new/Git/Libgit2.hs
|
|
||||||
--- orig/Git/Libgit2.hs 2014-04-06 09:02:46.523789820 +0300
|
|
||||||
+++ new/Git/Libgit2.hs 2014-04-06 09:02:46.000000000 +0300
|
|
||||||
@@ -60,7 +60,6 @@
|
|
||||||
import Control.Concurrent.Async.Lifted
|
|
||||||
import Control.Concurrent.STM
|
|
||||||
import Control.Exception.Lifted
|
|
||||||
-import Control.Failure
|
|
||||||
import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence)
|
|
||||||
import Control.Monad.IO.Class
|
|
||||||
import Control.Monad.Logger
|
|
||||||
@@ -154,11 +153,11 @@
|
|
||||||
|
|
||||||
lgParseOid :: MonadLg m => Text -> m Oid
|
|
||||||
lgParseOid str
|
|
||||||
- | len > 40 = failure (Git.OidParseFailed str)
|
|
||||||
+ | len > 40 = throwM (Git.OidParseFailed str)
|
|
||||||
| otherwise = do
|
|
||||||
moid <- liftIO $ lgParseOidIO str len
|
|
||||||
case moid of
|
|
||||||
- Nothing -> failure (Git.OidParseFailed str)
|
|
||||||
+ Nothing -> throwM (Git.OidParseFailed str)
|
|
||||||
Just oid -> return oid
|
|
||||||
where
|
|
||||||
len = T.length str
|
|
||||||
@@ -179,7 +178,7 @@
|
|
||||||
instance Eq OidPtr where
|
|
||||||
oid1 == oid2 = oid1 `compare` oid2 == EQ
|
|
||||||
|
|
||||||
-instance (Applicative m, Failure Git.GitException m,
|
|
||||||
+instance (Applicative m, MonadThrow m,
|
|
||||||
MonadBaseControl IO m, MonadIO m, MonadLogger m)
|
|
||||||
=> Git.MonadGit LgRepo (ReaderT LgRepo m) where
|
|
||||||
type Oid LgRepo = OidPtr
|
|
||||||
@@ -427,7 +426,7 @@
|
|
||||||
return $ Just fptr
|
|
||||||
case mfptr of
|
|
||||||
Nothing ->
|
|
||||||
- failure (Git.TreeCreateFailed "Failed to create new tree builder")
|
|
||||||
+ throwM (Git.TreeCreateFailed "Failed to create new tree builder")
|
|
||||||
Just fptr -> do
|
|
||||||
toid <- mapM Git.treeOid mtree
|
|
||||||
return (lgMakeBuilder fptr) { Git.mtbBaseTreeOid = toid }
|
|
||||||
@@ -441,7 +440,7 @@
|
|
||||||
withFilePath key $ \name ->
|
|
||||||
c'git_treebuilder_insert nullPtr ptr name coid
|
|
||||||
(fromIntegral mode)
|
|
||||||
- when (r2 < 0) $ failure (Git.TreeBuilderInsertFailed key)
|
|
||||||
+ when (r2 < 0) $ throwM (Git.TreeBuilderInsertFailed key)
|
|
||||||
|
|
||||||
treeEntryToOid :: TreeEntry -> (Oid, CUInt)
|
|
||||||
treeEntryToOid (Git.BlobEntry oid kind) =
|
|
||||||
@@ -503,7 +502,7 @@
|
|
||||||
liftIO $ withForeignPtr fptr $ \builder -> alloca $ \pptr -> do
|
|
||||||
r <- c'git_treebuilder_create pptr nullPtr
|
|
||||||
when (r < 0) $
|
|
||||||
- failure (Git.BackendError "Could not create new treebuilder")
|
|
||||||
+ throwM (Git.BackendError "Could not create new treebuilder")
|
|
||||||
builder' <- peek pptr
|
|
||||||
bracket
|
|
||||||
(mk'git_treebuilder_filter_cb (callback builder'))
|
|
||||||
@@ -522,7 +521,7 @@
|
|
||||||
coid
|
|
||||||
fmode
|
|
||||||
when (r < 0) $
|
|
||||||
- failure (Git.BackendError "Could not insert entry in treebuilder")
|
|
||||||
+ throwM (Git.BackendError "Could not insert entry in treebuilder")
|
|
||||||
return 0
|
|
||||||
|
|
||||||
lgLookupTree :: MonadLg m => TreeOid -> ReaderT LgRepo m Tree
|
|
||||||
@@ -547,7 +546,7 @@
|
|
||||||
0o100644 -> return Git.PlainBlob
|
|
||||||
0o100755 -> return Git.ExecutableBlob
|
|
||||||
0o120000 -> return Git.SymlinkBlob
|
|
||||||
- _ -> failure $ Git.BackendError $
|
|
||||||
+ _ -> throwM $ Git.BackendError $
|
|
||||||
"Unknown blob mode: " <> T.pack (show mode)
|
|
||||||
| typ == c'GIT_OBJ_TREE ->
|
|
||||||
return $ Git.TreeEntry (Tagged (mkOid oid))
|
|
||||||
@@ -642,7 +641,7 @@
|
|
||||||
r1 <- c'git_odb_exists ptr coid 0
|
|
||||||
c'git_odb_free ptr
|
|
||||||
return (Just (r1 == 0))
|
|
||||||
- maybe (failure Git.RepositoryInvalid) return result
|
|
||||||
+ maybe (throwM Git.RepositoryInvalid) return result
|
|
||||||
|
|
||||||
lgForEachObject :: Ptr C'git_odb
|
|
||||||
-> (Ptr C'git_oid -> Ptr () -> IO CInt)
|
|
||||||
@@ -663,7 +662,7 @@
|
|
||||||
r <- withForeignPtr (repoObj repo) $ \repoPtr ->
|
|
||||||
c'git_revwalk_new pptr repoPtr
|
|
||||||
when (r < 0) $
|
|
||||||
- failure (Git.BackendError "Could not create revwalker")
|
|
||||||
+ throwM (Git.BackendError "Could not create revwalker")
|
|
||||||
ptr <- peek pptr
|
|
||||||
FC.newForeignPtr ptr (c'git_revwalk_free ptr)
|
|
||||||
|
|
||||||
@@ -673,7 +672,7 @@
|
|
||||||
liftIO $ withForeignPtr (getOid oid) $ \coid -> do
|
|
||||||
r2 <- withForeignPtr walker $ flip c'git_revwalk_push coid
|
|
||||||
when (r2 < 0) $
|
|
||||||
- failure (Git.BackendError $ "Could not push oid "
|
|
||||||
+ throwM (Git.BackendError $ "Could not push oid "
|
|
||||||
<> pack (show oid) <> " onto revwalker")
|
|
||||||
|
|
||||||
case mhave of
|
|
||||||
@@ -681,7 +680,7 @@
|
|
||||||
Just have -> liftIO $ withForeignPtr (getOid (untag have)) $ \coid -> do
|
|
||||||
r2 <- withForeignPtr walker $ flip c'git_revwalk_hide coid
|
|
||||||
when (r2 < 0) $
|
|
||||||
- failure (Git.BackendError $ "Could not hide commit "
|
|
||||||
+ throwM (Git.BackendError $ "Could not hide commit "
|
|
||||||
<> pack (show (untag have)) <> " from revwalker")
|
|
||||||
|
|
||||||
liftIO $ withForeignPtr walker $ flip c'git_revwalk_sorting
|
|
||||||
@@ -831,7 +830,7 @@
|
|
||||||
else do
|
|
||||||
ref <- peek ptr
|
|
||||||
c'git_reference_delete ref
|
|
||||||
- when (r < 0) $ failure (Git.ReferenceDeleteFailed name)
|
|
||||||
+ when (r < 0) $ throwM (Git.ReferenceDeleteFailed name)
|
|
||||||
|
|
||||||
-- int git_reference_packall(git_repository *repo)
|
|
||||||
|
|
||||||
@@ -957,7 +956,7 @@
|
|
||||||
|
|
||||||
--compareRef = c'git_reference_cmp
|
|
||||||
|
|
||||||
-lgThrow :: (MonadIO m, Failure e m) => (Text -> e) -> m ()
|
|
||||||
+lgThrow :: (Exception e, MonadIO m, MonadThrow m) => (Text -> e) -> m ()
|
|
||||||
lgThrow f = do
|
|
||||||
errStr <- liftIO $ do
|
|
||||||
errPtr <- c'giterr_last
|
|
||||||
@@ -966,7 +965,7 @@
|
|
||||||
else do
|
|
||||||
err <- peek errPtr
|
|
||||||
peekCString (c'git_error'message err)
|
|
||||||
- failure (f (pack errStr))
|
|
||||||
+ throwM (f (pack errStr))
|
|
||||||
|
|
||||||
-- withLgTempRepo :: MonadLg m => ReaderT LgRepo m a -> m a
|
|
||||||
-- withLgTempRepo f = withTempDir $ \dir -> do
|
|
||||||
@@ -1048,13 +1047,13 @@
|
|
||||||
-- (Either Git.SHA ByteString)) m
|
|
||||||
-- (Git.TreeFilePath, Either Git.SHA ByteString)
|
|
||||||
handlePath (Right _) =
|
|
||||||
- lift $ failure $ Git.DiffTreeToIndexFailed
|
|
||||||
+ lift $ throwM $ Git.DiffTreeToIndexFailed
|
|
||||||
"Received a Right value when a Left RawFilePath was expected"
|
|
||||||
handlePath (Left path) = do
|
|
||||||
mcontent <- await
|
|
||||||
case mcontent of
|
|
||||||
Nothing ->
|
|
||||||
- lift $ failure $ Git.DiffTreeToIndexFailed $
|
|
||||||
+ lift $ throwM $ Git.DiffTreeToIndexFailed $
|
|
||||||
"Content not provided for " <> T.pack (show path)
|
|
||||||
Just x -> handleContent path x
|
|
||||||
|
|
||||||
@@ -1064,11 +1063,11 @@
|
|
||||||
-- (Either Git.SHA ByteString)) m
|
|
||||||
-- (Git.TreeFilePath, Either Git.SHA ByteString)
|
|
||||||
handleContent _path (Left _) =
|
|
||||||
- lift $ failure $ Git.DiffTreeToIndexFailed
|
|
||||||
+ lift $ throwM $ Git.DiffTreeToIndexFailed
|
|
||||||
"Received a Left value when a Right ByteString was expected"
|
|
||||||
handleContent path (Right content) = return (path, content)
|
|
||||||
|
|
||||||
- -- diffBlob :: Failure Git.GitException m
|
|
||||||
+ -- diffBlob :: MonadThrow m
|
|
||||||
-- => Git.TreeFilePath
|
|
||||||
-- -> Maybe (Either Git.SHA ByteString)
|
|
||||||
-- -> Maybe (ForeignPtr C'git_oid)
|
|
||||||
@@ -1183,8 +1182,8 @@
|
|
||||||
B.cons (fromIntegral lineOrigin) bs
|
|
||||||
return 0
|
|
||||||
|
|
||||||
-checkResult :: (Eq a, Num a, Failure Git.GitException m) => a -> Text -> m ()
|
|
||||||
-checkResult r why = when (r /= 0) $ failure (Git.BackendError why)
|
|
||||||
+checkResult :: (Eq a, Num a, MonadThrow m) => a -> Text -> m ()
|
|
||||||
+checkResult r why = when (r /= 0) $ throwM (Git.BackendError why)
|
|
||||||
|
|
||||||
lgBuildPackFile :: MonadLg m
|
|
||||||
=> FilePath -> [Either CommitOid TreeOid]
|
|
||||||
@@ -1353,7 +1352,7 @@
|
|
||||||
|
|
||||||
lgLoadPackFileInMemory
|
|
||||||
:: (MonadBaseControl IO m, MonadIO m, MonadLogger m,
|
|
||||||
- Failure Git.GitException m)
|
|
||||||
+ MonadThrow m)
|
|
||||||
=> FilePath
|
|
||||||
-> Ptr (Ptr C'git_odb_backend)
|
|
||||||
-> Ptr (Ptr C'git_odb)
|
|
||||||
@@ -1385,7 +1384,7 @@
|
|
||||||
return odbPtr
|
|
||||||
|
|
||||||
lgOpenPackFile :: (MonadBaseControl IO m, MonadIO m, MonadLogger m,
|
|
||||||
- Failure Git.GitException m)
|
|
||||||
+ MonadThrow m)
|
|
||||||
=> FilePath -> m (Ptr C'git_odb)
|
|
||||||
lgOpenPackFile idxPath = control $ \run ->
|
|
||||||
alloca $ \odbPtrPtr ->
|
|
||||||
@@ -1393,17 +1392,17 @@
|
|
||||||
lgLoadPackFileInMemory idxPath backendPtrPtr odbPtrPtr
|
|
||||||
|
|
||||||
lgClosePackFile :: (MonadBaseControl IO m, MonadIO m, MonadLogger m,
|
|
||||||
- Failure Git.GitException m)
|
|
||||||
+ MonadThrow m)
|
|
||||||
=> Ptr C'git_odb -> m ()
|
|
||||||
lgClosePackFile = liftIO . c'git_odb_free
|
|
||||||
|
|
||||||
lgWithPackFile :: (MonadBaseControl IO m, MonadIO m, MonadLogger m,
|
|
||||||
- Failure Git.GitException m)
|
|
||||||
+ MonadThrow m)
|
|
||||||
=> FilePath -> (Ptr C'git_odb -> m a) -> m a
|
|
||||||
lgWithPackFile idxPath = bracket (lgOpenPackFile idxPath) lgClosePackFile
|
|
||||||
|
|
||||||
lgReadFromPack :: (MonadBaseControl IO m, MonadIO m, MonadLogger m,
|
|
||||||
- Failure Git.GitException m)
|
|
||||||
+ MonadThrow m)
|
|
||||||
=> Ptr C'git_odb -> Git.SHA -> Bool
|
|
||||||
-> m (Maybe (C'git_otype, CSize, ByteString))
|
|
||||||
lgReadFromPack odbPtr sha metadataOnly = liftIO $ do
|
|
||||||
diff -ru orig/gitlib-libgit2.cabal new/gitlib-libgit2.cabal
|
|
||||||
--- orig/gitlib-libgit2.cabal 2014-04-06 09:02:46.527789820 +0300
|
|
||||||
+++ new/gitlib-libgit2.cabal 2014-04-06 09:02:46.000000000 +0300
|
|
||||||
@@ -42,7 +42,6 @@
|
|
||||||
, conduit >= 0.5.5
|
|
||||||
, containers >= 0.4.2.1
|
|
||||||
, directory >= 1.1.0.2
|
|
||||||
- , failure >= 0.2.0.1
|
|
||||||
, fast-logger
|
|
||||||
, filepath >= 1.3.0
|
|
||||||
, lifted-async >= 0.1.0
|
|
||||||
@ -1,276 +0,0 @@
|
|||||||
diff -ru orig/Git/S3.hs new/Git/S3.hs
|
|
||||||
--- orig/Git/S3.hs 2014-04-06 09:02:47.247789820 +0300
|
|
||||||
+++ new/Git/S3.hs 2014-04-06 09:02:47.000000000 +0300
|
|
||||||
@@ -42,7 +42,6 @@
|
|
||||||
import Control.Monad.Trans.Resource
|
|
||||||
import Control.Retry
|
|
||||||
import Data.Aeson as A
|
|
||||||
-import Data.Attempt
|
|
||||||
import Data.Bifunctor
|
|
||||||
import Data.Binary as Bin
|
|
||||||
import Data.ByteString (ByteString)
|
|
||||||
@@ -141,7 +140,7 @@
|
|
||||||
}
|
|
||||||
deriving (Eq, Show, Generic)
|
|
||||||
|
|
||||||
-type MonadS3 m = (Failure Git.GitException m,
|
|
||||||
+type MonadS3 m = (MonadThrow m,
|
|
||||||
MonadIO m, MonadBaseControl IO m, MonadLogger m)
|
|
||||||
|
|
||||||
data BackendCallbacks = BackendCallbacks
|
|
||||||
@@ -478,7 +477,10 @@
|
|
||||||
-> ResourceT m (Response (ResponseMetadata a) a)
|
|
||||||
awsRetry cfg svcfg mgr r =
|
|
||||||
transResourceT liftIO $
|
|
||||||
- retrying def (isFailure . responseResult) $ aws cfg svcfg mgr r
|
|
||||||
+ retrying def (isLeft . responseResult) $ aws cfg svcfg mgr r
|
|
||||||
+ where
|
|
||||||
+ isLeft Left{} = True
|
|
||||||
+ isLeft Right{} = False
|
|
||||||
|
|
||||||
listBucketS3 :: MonadS3 m => OdbS3Details -> ResourceT m [Text]
|
|
||||||
listBucketS3 dets = do
|
|
||||||
@@ -622,7 +624,7 @@
|
|
||||||
sha <- oidToSha oid
|
|
||||||
modifyIORef mshas (sha:)
|
|
||||||
return c'GIT_OK
|
|
||||||
- checkResult r "lgForEachObject failed"
|
|
||||||
+ either throwM return $ checkResult r "lgForEachObject failed"
|
|
||||||
|
|
||||||
-- Update the known objects map with the fact that we've got a local cache
|
|
||||||
-- of the pack file.
|
|
||||||
@@ -637,7 +639,7 @@
|
|
||||||
++ show (Prelude.length shas) ++ " objects"
|
|
||||||
return shas
|
|
||||||
|
|
||||||
-catalogPackFile :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
|
|
||||||
+catalogPackFile :: (MonadS3 m, MonadThrow m)
|
|
||||||
=> OdbS3Details -> Text -> FilePath -> m [SHA]
|
|
||||||
catalogPackFile dets packSha idxPath = do
|
|
||||||
-- Load the pack file, and iterate over the objects within it to determine
|
|
||||||
@@ -710,7 +712,7 @@
|
|
||||||
lgDebug $ "cacheUpdateEntry " ++ show (shaToText sha) ++ " " ++ show ce
|
|
||||||
liftIO $ atomically $ modifyTVar (knownObjects dets) $ M.insert sha ce
|
|
||||||
|
|
||||||
-cacheLoadObject :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
|
|
||||||
+cacheLoadObject :: (MonadS3 m, MonadThrow m)
|
|
||||||
=> OdbS3Details -> SHA -> CacheEntry -> Bool
|
|
||||||
-> m (Maybe ObjectInfo)
|
|
||||||
cacheLoadObject dets sha ce metadataOnly = do
|
|
||||||
@@ -958,7 +960,7 @@
|
|
||||||
remoteStoreObject _ _ _ =
|
|
||||||
throw (Git.BackendError "remoteStoreObject was not given any data")
|
|
||||||
|
|
||||||
-remoteCatalogContents :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
|
|
||||||
+remoteCatalogContents :: (MonadS3 m, MonadThrow m)
|
|
||||||
=> OdbS3Details -> ResourceT m ()
|
|
||||||
remoteCatalogContents dets = do
|
|
||||||
lgDebug "remoteCatalogContents"
|
|
||||||
@@ -982,7 +984,7 @@
|
|
||||||
|
|
||||||
| otherwise -> return ()
|
|
||||||
|
|
||||||
-accessObject :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
|
|
||||||
+accessObject :: (MonadS3 m, MonadThrow m)
|
|
||||||
=> OdbS3Details -> SHA -> Bool -> m (Maybe CacheEntry)
|
|
||||||
accessObject dets sha checkRemote = do
|
|
||||||
mentry <- cacheLookupEntry dets sha
|
|
||||||
@@ -1032,19 +1034,19 @@
|
|
||||||
-- cache and with the callback interface. This is to avoid recataloging
|
|
||||||
-- in the future.
|
|
||||||
|
|
||||||
-objectExists :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
|
|
||||||
+objectExists :: (MonadS3 m, MonadThrow m)
|
|
||||||
=> OdbS3Details -> SHA -> Bool -> m CacheEntry
|
|
||||||
objectExists dets sha checkRemote = do
|
|
||||||
mce <- accessObject dets sha checkRemote
|
|
||||||
return $ fromMaybe DoesNotExist mce
|
|
||||||
|
|
||||||
-readObject :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
|
|
||||||
+readObject :: (MonadS3 m, MonadThrow m)
|
|
||||||
=> OdbS3Details -> SHA -> Bool -> m (Maybe ObjectInfo)
|
|
||||||
readObject dets sha metadataOnly = do
|
|
||||||
ce <- objectExists dets sha True
|
|
||||||
cacheLoadObject dets sha ce metadataOnly `orElse` return Nothing
|
|
||||||
|
|
||||||
-readObjectMetadata :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
|
|
||||||
+readObjectMetadata :: (MonadS3 m, MonadThrow m)
|
|
||||||
=> OdbS3Details -> SHA -> m (Maybe ObjectInfo)
|
|
||||||
readObjectMetadata dets sha = readObject dets sha True
|
|
||||||
|
|
||||||
@@ -1054,7 +1056,7 @@
|
|
||||||
callbackRegisterObject dets sha info
|
|
||||||
cacheStoreObject dets sha info
|
|
||||||
|
|
||||||
-writePackFile :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
|
|
||||||
+writePackFile :: (MonadS3 m, MonadThrow m)
|
|
||||||
=> OdbS3Details -> BL.ByteString -> m ()
|
|
||||||
writePackFile dets bytes = do
|
|
||||||
let dir = tempDirectory dets
|
|
||||||
@@ -1073,7 +1075,7 @@
|
|
||||||
shas <- catalogPackFile dets packSha idxPath
|
|
||||||
callbackRegisterPackFile dets packSha shas
|
|
||||||
|
|
||||||
-readCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
|
|
||||||
+readCallback :: (MonadS3 m, MonadThrow m)
|
|
||||||
=> Ptr (Ptr ())
|
|
||||||
-> Ptr CSize
|
|
||||||
-> Ptr C'git_otype
|
|
||||||
@@ -1104,7 +1106,7 @@
|
|
||||||
BU.unsafeUseAsCString chunk $ copyBytes p ?? len
|
|
||||||
return $ p `plusPtr` len
|
|
||||||
|
|
||||||
-readPrefixCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
|
|
||||||
+readPrefixCallback :: (MonadS3 m, MonadThrow m)
|
|
||||||
=> Ptr C'git_oid
|
|
||||||
-> Ptr (Ptr ())
|
|
||||||
-> Ptr CSize
|
|
||||||
@@ -1140,7 +1142,7 @@
|
|
||||||
go dets sha False
|
|
||||||
| otherwise = return Nothing
|
|
||||||
|
|
||||||
-readHeaderCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
|
|
||||||
+readHeaderCallback :: (MonadS3 m, MonadThrow m)
|
|
||||||
=> Ptr CSize
|
|
||||||
-> Ptr C'git_otype
|
|
||||||
-> Ptr C'git_odb_backend
|
|
||||||
@@ -1158,7 +1160,7 @@
|
|
||||||
poke len_p (toLength len)
|
|
||||||
poke type_p (toType typ)
|
|
||||||
|
|
||||||
-writeCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
|
|
||||||
+writeCallback :: (MonadS3 m, MonadThrow m)
|
|
||||||
=> Ptr C'git_oid
|
|
||||||
-> Ptr C'git_odb_backend
|
|
||||||
-> Ptr ()
|
|
||||||
@@ -1184,7 +1186,7 @@
|
|
||||||
(ObjectInfo (fromLength len) (fromType obj_type)
|
|
||||||
Nothing (Just (BL.fromChunks [bytes])))
|
|
||||||
|
|
||||||
-existsCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
|
|
||||||
+existsCallback :: (MonadS3 m, MonadThrow m)
|
|
||||||
=> Ptr C'git_odb_backend -> Ptr C'git_oid -> CInt -> m CInt
|
|
||||||
existsCallback be oid confirmNotExists = do
|
|
||||||
(dets, sha) <- liftIO $ unpackDetails be oid
|
|
||||||
@@ -1194,18 +1196,18 @@
|
|
||||||
return $ if ce == DoesNotExist then 0 else 1)
|
|
||||||
(return c'GIT_ERROR)
|
|
||||||
|
|
||||||
-refreshCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
|
|
||||||
+refreshCallback :: (MonadS3 m, MonadThrow m)
|
|
||||||
=> Ptr C'git_odb_backend -> m CInt
|
|
||||||
refreshCallback _ =
|
|
||||||
return c'GIT_OK -- do nothing
|
|
||||||
|
|
||||||
-foreachCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
|
|
||||||
+foreachCallback :: (MonadS3 m, MonadThrow m)
|
|
||||||
=> Ptr C'git_odb_backend -> C'git_odb_foreach_cb -> Ptr ()
|
|
||||||
-> m CInt
|
|
||||||
foreachCallback _be _callback _payload =
|
|
||||||
return c'GIT_ERROR -- fallback to standard method
|
|
||||||
|
|
||||||
-writePackCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
|
|
||||||
+writePackCallback :: (MonadS3 m, MonadThrow m)
|
|
||||||
=> Ptr (Ptr C'git_odb_writepack)
|
|
||||||
-> Ptr C'git_odb_backend
|
|
||||||
-> C'git_transfer_progress_callback
|
|
||||||
@@ -1248,7 +1250,7 @@
|
|
||||||
foreign import ccall "&freeCallback"
|
|
||||||
freeCallbackPtr :: FunPtr F'git_odb_backend_free_callback
|
|
||||||
|
|
||||||
-packAddCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
|
|
||||||
+packAddCallback :: (MonadS3 m, MonadThrow m)
|
|
||||||
=> Ptr C'git_odb_writepack
|
|
||||||
-> Ptr ()
|
|
||||||
-> CSize
|
|
||||||
@@ -1267,7 +1269,7 @@
|
|
||||||
(castPtr dataPtr) (fromIntegral len)
|
|
||||||
writePackFile dets (BL.fromChunks [bytes])
|
|
||||||
|
|
||||||
-packCommitCallback :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
|
|
||||||
+packCommitCallback :: (MonadS3 m, MonadThrow m)
|
|
||||||
=> Ptr C'git_odb_writepack -> Ptr C'git_transfer_progress
|
|
||||||
-> m CInt
|
|
||||||
packCommitCallback _wp _progress =
|
|
||||||
@@ -1380,7 +1382,7 @@
|
|
||||||
liftIO $ writeIORef result res
|
|
||||||
readIORef result
|
|
||||||
|
|
||||||
-odbS3Backend :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
|
|
||||||
+odbS3Backend :: (MonadS3 m, MonadThrow m)
|
|
||||||
=> Aws.S3Configuration NormalQuery
|
|
||||||
-> Configuration
|
|
||||||
-> Manager
|
|
||||||
@@ -1475,7 +1477,7 @@
|
|
||||||
|
|
||||||
-- | Given a repository object obtained from Libgit2, add an S3 backend to it,
|
|
||||||
-- making it the primary store for objects associated with that repository.
|
|
||||||
-addS3Backend :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
|
|
||||||
+addS3Backend :: (MonadS3 m, MonadThrow m)
|
|
||||||
=> LgRepo
|
|
||||||
-> Text -- ^ bucket
|
|
||||||
-> Text -- ^ prefix
|
|
||||||
@@ -1505,7 +1507,7 @@
|
|
||||||
void $ liftIO $ odbBackendAdd repo odbS3 100
|
|
||||||
return repo
|
|
||||||
|
|
||||||
-s3Factory :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
|
|
||||||
+s3Factory :: (MonadS3 m, MonadThrow m)
|
|
||||||
=> Maybe Text -> Text -> Text -> FilePath -> BackendCallbacks
|
|
||||||
-> Git.RepositoryFactory (ReaderT LgRepo (NoLoggingT m)) m LgRepo
|
|
||||||
s3Factory bucket accessKey secretKey dir callbacks = lgFactory
|
|
||||||
@@ -1528,7 +1530,7 @@
|
|
||||||
dir
|
|
||||||
callbacks
|
|
||||||
|
|
||||||
-s3FactoryLogger :: (MonadS3 m, MonadUnsafeIO m, MonadThrow m)
|
|
||||||
+s3FactoryLogger :: (MonadS3 m, MonadThrow m)
|
|
||||||
=> Maybe Text -> Text -> Text -> FilePath -> BackendCallbacks
|
|
||||||
-> Git.RepositoryFactory (ReaderT LgRepo m) m LgRepo
|
|
||||||
s3FactoryLogger bucket accessKey secretKey dir callbacks = lgFactoryLogger
|
|
||||||
diff -ru orig/gitlib-s3.cabal new/gitlib-s3.cabal
|
|
||||||
--- orig/gitlib-s3.cabal 2014-04-06 09:02:47.247789820 +0300
|
|
||||||
+++ new/gitlib-s3.cabal 2014-04-06 09:02:47.000000000 +0300
|
|
||||||
@@ -33,7 +33,6 @@
|
|
||||||
, hspec-expectations >= 0.3
|
|
||||||
, data-default >= 0.5.1
|
|
||||||
, directory >= 1.1.0.2
|
|
||||||
- , failure >= 0.2.0.1
|
|
||||||
, filepath >= 1.3.0
|
|
||||||
, monad-logger >= 0.3.1.1
|
|
||||||
, resourcet >= 0.4.6
|
|
||||||
@@ -52,12 +51,12 @@
|
|
||||||
, ghc-prim
|
|
||||||
, hlibgit2 >= 0.18.0.11
|
|
||||||
, aeson >= 0.6.1.0
|
|
||||||
- , attempt >= 0.4.0
|
|
||||||
, aws >= 0.7.5
|
|
||||||
, bifunctors >= 3.2.0.1
|
|
||||||
, binary >= 0.5.1.0
|
|
||||||
, bytestring >= 0.9.2.1
|
|
||||||
, conduit >= 0.5.5
|
|
||||||
+ , conduit-extra
|
|
||||||
, data-default >= 0.5.1
|
|
||||||
, directory >= 1.1.0.2
|
|
||||||
, filepath >= 1.3.0
|
|
||||||
diff -ru orig/test/Smoke.hs new/test/Smoke.hs
|
|
||||||
--- orig/test/Smoke.hs 2014-04-06 09:02:47.247789820 +0300
|
|
||||||
+++ new/test/Smoke.hs 2014-04-06 09:02:47.000000000 +0300
|
|
||||||
@@ -11,7 +11,6 @@
|
|
||||||
|
|
||||||
import Aws
|
|
||||||
import Control.Applicative
|
|
||||||
-import Control.Failure
|
|
||||||
import Control.Monad.IO.Class
|
|
||||||
import Control.Monad.Logger
|
|
||||||
import Control.Monad.Trans.Reader
|
|
||||||
@@ -30,8 +29,7 @@
|
|
||||||
import Test.Hspec.Runner
|
|
||||||
|
|
||||||
s3Factory
|
|
||||||
- :: (Failure Git.GitException m, MonadIO m, MonadBaseControl IO m,
|
|
||||||
- MonadUnsafeIO m, MonadThrow m)
|
|
||||||
+ :: (MonadThrow m, MonadIO m, MonadBaseControl IO m)
|
|
||||||
=> Git.RepositoryFactory (ReaderT Lg.LgRepo (NoLoggingT m)) m Lg.LgRepo
|
|
||||||
s3Factory = Lg.lgFactory
|
|
||||||
{ Git.runRepository = \ctxt m ->
|
|
||||||
@ -1,11 +0,0 @@
|
|||||||
diff -ru orig/gitlib-test.cabal new/gitlib-test.cabal
|
|
||||||
--- orig/gitlib-test.cabal 2014-04-06 09:02:47.671789820 +0300
|
|
||||||
+++ new/gitlib-test.cabal 2014-04-06 09:02:47.000000000 +0300
|
|
||||||
@@ -28,6 +28,7 @@
|
|
||||||
, bytestring
|
|
||||||
, failure >= 0.2.0
|
|
||||||
, conduit
|
|
||||||
+ , conduit-extra
|
|
||||||
, monad-control >= 0.3.1
|
|
||||||
, tagged >= 0.4.4
|
|
||||||
, text >= 0.11.2
|
|
||||||
@ -1,12 +0,0 @@
|
|||||||
diff -ru orig/haskell-names.cabal new/haskell-names.cabal
|
|
||||||
--- orig/haskell-names.cabal 2014-03-06 15:00:30.424709530 +0200
|
|
||||||
+++ new/haskell-names.cabal 2014-03-06 15:00:30.000000000 +0200
|
|
||||||
@@ -271,7 +271,7 @@
|
|
||||||
, data-lens-template
|
|
||||||
, tagged
|
|
||||||
, traverse-with-class
|
|
||||||
- , type-eq == 0.4
|
|
||||||
+ , type-eq >= 0.4
|
|
||||||
, Cabal >= 1.14 && < 1.20
|
|
||||||
Hs-source-dirs: src
|
|
||||||
Ghc-options: -Wall -fno-warn-name-shadowing
|
|
||||||
@ -1,11 +0,0 @@
|
|||||||
diff -ru orig/haskell-packages.cabal new/haskell-packages.cabal
|
|
||||||
--- orig/haskell-packages.cabal 2014-02-20 12:04:23.945608732 +0200
|
|
||||||
+++ new/haskell-packages.cabal 2014-02-20 12:04:23.000000000 +0200
|
|
||||||
@@ -48,6 +48,6 @@
|
|
||||||
, containers
|
|
||||||
, mtl >= 2.1
|
|
||||||
, hse-cpp
|
|
||||||
- , EitherT
|
|
||||||
+ , either
|
|
||||||
, haskell-src-exts >= 1.14
|
|
||||||
, tagged
|
|
||||||
@ -1,12 +0,0 @@
|
|||||||
diff -ruN orig/System/Posix/Daemonize.hs new/System/Posix/Daemonize.hs
|
|
||||||
--- orig/System/Posix/Daemonize.hs 2014-08-10 13:47:22.378323475 +0300
|
|
||||||
+++ new/System/Posix/Daemonize.hs 2014-08-10 13:47:22.000000000 +0300
|
|
||||||
@@ -147,7 +147,7 @@
|
|
||||||
process daemon' args
|
|
||||||
where
|
|
||||||
|
|
||||||
- program' daemon = withSyslog (fromJust $ name daemon) (syslogOptions daemon) DAEMON $
|
|
||||||
+ program' daemon = withSyslog (fromJust $ name daemon) (syslogOptions daemon) DAEMON [] $
|
|
||||||
do let log = syslog Notice
|
|
||||||
log "starting"
|
|
||||||
pidWrite daemon
|
|
||||||
@ -1,12 +0,0 @@
|
|||||||
diff -ru orig/heist.cabal new/heist.cabal
|
|
||||||
--- orig/heist.cabal 2014-03-13 06:02:39.554055215 +0200
|
|
||||||
+++ new/heist.cabal 2014-03-13 06:02:39.000000000 +0200
|
|
||||||
@@ -153,7 +153,7 @@
|
|
||||||
filepath >= 1.3 && < 1.4,
|
|
||||||
hashable >= 1.1 && < 1.3,
|
|
||||||
mtl >= 2.0 && < 2.2,
|
|
||||||
- process >= 1.1 && < 1.2,
|
|
||||||
+ process >= 1.1 && < 1.3,
|
|
||||||
random >= 1.0.1.0 && < 1.1,
|
|
||||||
text >= 0.10 && < 1.2,
|
|
||||||
time >= 1.1 && < 1.5,
|
|
||||||
@ -1,21 +0,0 @@
|
|||||||
diff -ru orig/unit-tests/run-unit-tests.hs new/unit-tests/run-unit-tests.hs
|
|
||||||
--- orig/unit-tests/run-unit-tests.hs 2014-05-11 18:47:29.102698531 +0300
|
|
||||||
+++ new/unit-tests/run-unit-tests.hs 2014-05-11 18:47:28.000000000 +0300
|
|
||||||
@@ -191,7 +191,7 @@
|
|
||||||
test_catch :: TestCase
|
|
||||||
test_catch = TestCase "catch" [] $ do
|
|
||||||
setImports ["Prelude"]
|
|
||||||
- succeeds (action `catch` handler) @@? "catch failed"
|
|
||||||
+ succeeds (action `MC.catch` handler) @@? "catch failed"
|
|
||||||
where handler DivideByZero = return "catched"
|
|
||||||
handler e = throwM e
|
|
||||||
action = do s <- eval "1 `div` 0 :: Int"
|
|
||||||
@@ -203,7 +203,7 @@
|
|
||||||
liftIO $ do
|
|
||||||
r <- newEmptyMVar
|
|
||||||
let concurrent = runInterpreter (liftIO $ putMVar r False)
|
|
||||||
- `catch` \MultipleInstancesNotAllowed ->
|
|
||||||
+ `MC.catch` \MultipleInstancesNotAllowed ->
|
|
||||||
do liftIO $ putMVar r True
|
|
||||||
return $ Right ()
|
|
||||||
_ <- forkIO $ concurrent >> return ()
|
|
||||||
@ -1,58 +0,0 @@
|
|||||||
diff -ru orig/src/General/Web.hs new/src/General/Web.hs
|
|
||||||
--- orig/src/General/Web.hs 2014-06-09 15:25:38.583521732 +0300
|
|
||||||
+++ new/src/General/Web.hs 2014-06-09 15:25:38.000000000 +0300
|
|
||||||
@@ -21,6 +21,9 @@
|
|
||||||
import General.Base
|
|
||||||
import System.FilePath
|
|
||||||
import Network.Wai
|
|
||||||
+#if MIN_VERSION_wai(3, 0, 0)
|
|
||||||
+import Data.IORef
|
|
||||||
+#endif
|
|
||||||
#if MIN_VERSION_wai(2, 0, 0)
|
|
||||||
import Network.Wai.Internal
|
|
||||||
#endif
|
|
||||||
@@ -46,7 +49,15 @@
|
|
||||||
|
|
||||||
responseFlatten :: Response -> IO (Status, ResponseHeaders, LBString)
|
|
||||||
responseFlatten r = do
|
|
||||||
-#if MIN_VERSION_wai(2, 0, 0)
|
|
||||||
+#if MIN_VERSION_wai(3, 0, 0)
|
|
||||||
+ let (s,hs,withBody) = responseToStream r
|
|
||||||
+ ref <- newIORef mempty
|
|
||||||
+ let addChunk builder = modifyIORef ref (<> builder)
|
|
||||||
+ withBody $ \body -> body addChunk (return ())
|
|
||||||
+ builder <- readIORef ref
|
|
||||||
+ let res = toLazyByteString builder
|
|
||||||
+ return (s,hs,res)
|
|
||||||
+#elif MIN_VERSION_wai(2, 0, 0)
|
|
||||||
let (s,hs,withSrc) = responseToSource r
|
|
||||||
chunks <- withSrc $ \src -> src $$ consume
|
|
||||||
let res = toLazyByteString $ mconcat [x | Chunk x <- chunks]
|
|
||||||
diff -ru orig/src/Web/Server.hs new/src/Web/Server.hs
|
|
||||||
--- orig/src/Web/Server.hs 2014-06-09 15:25:38.575521732 +0300
|
|
||||||
+++ new/src/Web/Server.hs 2014-06-09 15:25:38.000000000 +0300
|
|
||||||
@@ -32,14 +32,23 @@
|
|
||||||
resp <- respArgs q
|
|
||||||
v <- newMVar ()
|
|
||||||
putStrLn $ "Starting Hoogle Server on port " ++ show port
|
|
||||||
- runSettings defaultSettings{settingsOnException=exception, settingsPort=port} $ \r -> liftIO $ do
|
|
||||||
+ runSettings defaultSettings{settingsOnException=exception, settingsPort=port}
|
|
||||||
+#if MIN_VERSION_wai(3, 0, 0)
|
|
||||||
+ $ \r sendResponse -> do
|
|
||||||
+#else
|
|
||||||
+ $ \r -> liftIO $ do
|
|
||||||
+#endif
|
|
||||||
start <- getCurrentTime
|
|
||||||
res <- talk resp q r
|
|
||||||
responseEvaluate res
|
|
||||||
stop <- getCurrentTime
|
|
||||||
let t = floor $ diffUTCTime stop start * 1000
|
|
||||||
withMVar v $ const $ putStrLn $ bsUnpack (rawPathInfo r) ++ bsUnpack (rawQueryString r) ++ " ms:" ++ show t
|
|
||||||
+#if MIN_VERSION_wai(3, 0, 0)
|
|
||||||
+ sendResponse res
|
|
||||||
+#else
|
|
||||||
return res
|
|
||||||
+#endif
|
|
||||||
|
|
||||||
|
|
||||||
#if MIN_VERSION_wai(2, 0, 0)
|
|
||||||
@ -1,23 +0,0 @@
|
|||||||
diff -ru orig/src/Network/Parser/Mime.hs new/src/Network/Parser/Mime.hs
|
|
||||||
--- orig/src/Network/Parser/Mime.hs 2014-03-19 12:03:48.222054709 +0200
|
|
||||||
+++ new/src/Network/Parser/Mime.hs 2014-03-19 12:03:47.000000000 +0200
|
|
||||||
@@ -43,7 +43,7 @@
|
|
||||||
_ -> MultiPart (Extension s)
|
|
||||||
(t, s) -> Other t s
|
|
||||||
where
|
|
||||||
- paired s = let (a,b) = (T.break (== '/') . T.toLower . TE.decodeLatin1) s in
|
|
||||||
+ paired s = let (a,b) = (T.break (== '/') . T.toLower . TE.decodeUtf8) s in
|
|
||||||
(a, T.drop 1 b)
|
|
||||||
|
|
||||||
-- Parse headers and map them to a MimeValue
|
|
||||||
@@ -53,8 +53,8 @@
|
|
||||||
let mv = L.foldl f nullMimeValue eh
|
|
||||||
return mv
|
|
||||||
where
|
|
||||||
- bs2t = M.fromList . Prelude.map (TE.decodeLatin1 *** TE.decodeLatin1) . M.toList
|
|
||||||
- hVal = TE.decodeLatin1 . hValue
|
|
||||||
+ bs2t = M.fromList . Prelude.map (TE.decodeUtf8 *** TE.decodeUtf8) . M.toList
|
|
||||||
+ hVal = TE.decodeUtf8 . hValue
|
|
||||||
f z x =
|
|
||||||
case hType x of
|
|
||||||
IdH -> z { mvHeaders = M.insert IdH (hVal x) (mvHeaders z) }
|
|
||||||
@ -1,20 +0,0 @@
|
|||||||
diff -ru orig/incremental-parser.cabal new/incremental-parser.cabal
|
|
||||||
--- orig/incremental-parser.cabal 2014-06-15 10:20:01.864931460 +0300
|
|
||||||
+++ new/incremental-parser.cabal 2014-06-15 10:20:01.000000000 +0300
|
|
||||||
@@ -29,15 +29,3 @@
|
|
||||||
GHC-prof-options: -auto-all
|
|
||||||
if impl(ghc >= 7.0.0)
|
|
||||||
default-language: Haskell2010
|
|
||||||
-
|
|
||||||
-test-suite Main
|
|
||||||
- Type: exitcode-stdio-1.0
|
|
||||||
- x-uses-tf: true
|
|
||||||
- Build-Depends: base < 5, monoid-subclasses < 0.4,
|
|
||||||
- QuickCheck >= 2 && < 3, checkers >= 0.2 && < 0.4,
|
|
||||||
- test-framework >= 0.4.1, test-framework-quickcheck2
|
|
||||||
- Main-is: Test/TestIncrementalParser.hs
|
|
||||||
- Other-Modules: Text.ParserCombinators.Incremental,
|
|
||||||
- Text.ParserCombinators.Incremental.LeftBiasedLocal, Text.ParserCombinators.Incremental.Symmetric,
|
|
||||||
- Control.Applicative.Monoid
|
|
||||||
- default-language: Haskell2010
|
|
||||||
Only in orig: Test
|
|
||||||
@ -1,12 +0,0 @@
|
|||||||
diff -ru orig/network-transport-tests.cabal new/network-transport-tests.cabal
|
|
||||||
--- orig/network-transport-tests.cabal 2014-03-25 06:24:53.648644213 +0200
|
|
||||||
+++ new/network-transport-tests.cabal 2014-03-25 06:24:53.000000000 +0200
|
|
||||||
@@ -24,7 +24,7 @@
|
|
||||||
bytestring >= 0.9 && < 0.11,
|
|
||||||
random >= 1.0 && < 1.1,
|
|
||||||
mtl >= 2.1 && < 2.2,
|
|
||||||
- ansi-terminal >= 0.5 && < 0.6
|
|
||||||
+ ansi-terminal >= 0.5
|
|
||||||
hs-source-dirs: src
|
|
||||||
ghc-options: -Wall -fno-warn-unused-do-bind
|
|
||||||
extensions: CPP,
|
|
||||||
@ -1,62 +0,0 @@
|
|||||||
diff -ruN orig/Control/Monad/Primitive.hs new/Control/Monad/Primitive.hs
|
|
||||||
--- orig/Control/Monad/Primitive.hs 2014-08-01 14:49:04.175318972 +0300
|
|
||||||
+++ new/Control/Monad/Primitive.hs 2014-08-01 14:49:03.000000000 +0300
|
|
||||||
@@ -44,7 +44,9 @@
|
|
||||||
primitive_ :: PrimMonad m
|
|
||||||
=> (State# (PrimState m) -> State# (PrimState m)) -> m ()
|
|
||||||
{-# INLINE primitive_ #-}
|
|
||||||
-primitive_ f = primitive (\s# -> (# f s#, () #))
|
|
||||||
+primitive_ f = primitive (\s# ->
|
|
||||||
+ case f s# of
|
|
||||||
+ s'# -> (# s'#, () #))
|
|
||||||
|
|
||||||
instance PrimMonad IO where
|
|
||||||
type PrimState IO = RealWorld
|
|
||||||
diff -ruN orig/primitive.cabal new/primitive.cabal
|
|
||||||
--- orig/primitive.cabal 2014-08-01 14:49:04.175318972 +0300
|
|
||||||
+++ new/primitive.cabal 2014-08-01 14:49:03.000000000 +0300
|
|
||||||
@@ -50,6 +50,16 @@
|
|
||||||
if arch(i386) || arch(x86_64)
|
|
||||||
cc-options: -msse2
|
|
||||||
|
|
||||||
+test-suite test
|
|
||||||
+ Default-Language: Haskell2010
|
|
||||||
+ hs-source-dirs: test
|
|
||||||
+ main-is: main.hs
|
|
||||||
+ type: exitcode-stdio-1.0
|
|
||||||
+ build-depends: base
|
|
||||||
+ , ghc-prim
|
|
||||||
+ , primitive
|
|
||||||
+ ghc-options: -O2
|
|
||||||
+
|
|
||||||
source-repository head
|
|
||||||
type: git
|
|
||||||
location: https://github.com/haskell/primitive
|
|
||||||
diff -ruN orig/test/main.hs new/test/main.hs
|
|
||||||
--- orig/test/main.hs 1970-01-01 02:00:00.000000000 +0200
|
|
||||||
+++ new/test/main.hs 2014-08-01 14:49:03.000000000 +0300
|
|
||||||
@@ -0,0 +1,24 @@
|
|
||||||
+{-# LANGUAGE MagicHash, UnboxedTuples #-}
|
|
||||||
+import Control.Monad.Primitive
|
|
||||||
+import Data.Primitive.Array
|
|
||||||
+import GHC.IO
|
|
||||||
+import GHC.Prim
|
|
||||||
+
|
|
||||||
+-- Since we only have a single test case right now, I'm going to avoid the
|
|
||||||
+-- issue of choosing a test framework for the moment. This also keeps the
|
|
||||||
+-- package as a whole light on dependencies.
|
|
||||||
+
|
|
||||||
+main :: IO ()
|
|
||||||
+main = do
|
|
||||||
+ arr <- newArray 1 'A'
|
|
||||||
+ let unit =
|
|
||||||
+ case writeArray arr 0 'B' of
|
|
||||||
+ IO f ->
|
|
||||||
+ case f realWorld# of
|
|
||||||
+ _ -> ()
|
|
||||||
+ c1 <- readArray arr 0
|
|
||||||
+ return $! unit
|
|
||||||
+ c2 <- readArray arr 0
|
|
||||||
+ if c1 == 'A' && c2 == 'B'
|
|
||||||
+ then return ()
|
|
||||||
+ else error $ "Expected AB, got: " ++ show (c1, c2)
|
|
||||||
@ -1,12 +0,0 @@
|
|||||||
Only in new: dist
|
|
||||||
diff -ru orig/process-conduit.cabal new/process-conduit.cabal
|
|
||||||
--- orig/process-conduit.cabal 2014-03-30 12:27:40.781431440 +0300
|
|
||||||
+++ new/process-conduit.cabal 2014-03-30 12:27:40.000000000 +0300
|
|
||||||
@@ -35,6 +35,7 @@
|
|
||||||
, process >= 1.0
|
|
||||||
, conduit == 1.0.*
|
|
||||||
, shakespeare-text >= 1.0
|
|
||||||
+ , shakespeare
|
|
||||||
|
|
||||||
ghc-options: -Wall
|
|
||||||
|
|
||||||
@ -1,62 +0,0 @@
|
|||||||
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
|
|
||||||
@ -1,21 +0,0 @@
|
|||||||
diff -ru orig/process-conduit.cabal new/process-conduit.cabal
|
|
||||||
--- orig/process-conduit.cabal 2014-04-04 10:13:39.716407142 +0300
|
|
||||||
+++ new/process-conduit.cabal 2014-04-04 10:13:39.000000000 +0300
|
|
||||||
@@ -48,4 +48,6 @@
|
|
||||||
, bytestring
|
|
||||||
, hspec >= 1.3
|
|
||||||
, conduit
|
|
||||||
+ , conduit-extra
|
|
||||||
+ , resourcet
|
|
||||||
, process-conduit
|
|
||||||
diff -ru orig/test.hs new/test.hs
|
|
||||||
--- orig/test.hs 2014-04-04 10:13:39.692407142 +0300
|
|
||||||
+++ new/test.hs 2014-04-04 10:13:39.000000000 +0300
|
|
||||||
@@ -5,6 +5,7 @@
|
|
||||||
|
|
||||||
import qualified Data.ByteString.Lazy.Char8 as L
|
|
||||||
import Data.Conduit
|
|
||||||
+import Control.Monad.Trans.Resource (runResourceT)
|
|
||||||
import qualified Data.Conduit.Binary as CB
|
|
||||||
import Test.Hspec
|
|
||||||
|
|
||||||
@ -1,12 +0,0 @@
|
|||||||
diff -ru orig/retry.cabal new/retry.cabal
|
|
||||||
--- orig/retry.cabal 2014-05-11 11:28:24.319992770 +0300
|
|
||||||
+++ new/retry.cabal 2014-05-11 11:28:24.000000000 +0300
|
|
||||||
@@ -30,7 +30,7 @@
|
|
||||||
exposed-modules: Control.Retry
|
|
||||||
build-depends:
|
|
||||||
base ==4.*,
|
|
||||||
- exceptions >= 0.5 && < 0.6,
|
|
||||||
+ exceptions >= 0.5 && < 0.7,
|
|
||||||
transformers,
|
|
||||||
data-default
|
|
||||||
hs-source-dirs: src
|
|
||||||
@ -1,19 +0,0 @@
|
|||||||
diff -ruN orig/retry.cabal new/retry.cabal
|
|
||||||
--- orig/retry.cabal 2014-08-05 09:28:48.350961123 +0300
|
|
||||||
+++ new/retry.cabal 2014-08-05 09:28:48.000000000 +0300
|
|
||||||
@@ -44,13 +44,13 @@
|
|
||||||
ghc-options: -threaded
|
|
||||||
build-depends:
|
|
||||||
base ==4.*
|
|
||||||
- , exceptions >= 0.5 && < 0.6
|
|
||||||
+ , exceptions >= 0.5
|
|
||||||
, transformers
|
|
||||||
, data-default-class
|
|
||||||
, time
|
|
||||||
, QuickCheck >= 2.7 && < 2.8
|
|
||||||
, HUnit >= 1.2.5.2 && < 1.3
|
|
||||||
- , hspec >= 1.9 && < 1.10
|
|
||||||
+ , hspec >= 1.9
|
|
||||||
default-language: Haskell2010
|
|
||||||
|
|
||||||
|
|
||||||
@ -1,14 +0,0 @@
|
|||||||
diff -ru orig/scientific.cabal new/scientific.cabal
|
|
||||||
--- orig/scientific.cabal 2014-03-06 14:57:06.880706336 +0200
|
|
||||||
+++ new/scientific.cabal 2014-03-06 14:57:06.000000000 +0200
|
|
||||||
@@ -47,8 +47,8 @@
|
|
||||||
|
|
||||||
build-depends: scientific
|
|
||||||
, base >= 4.3 && < 4.8
|
|
||||||
- , tasty >= 0.3.1 && < 0.8
|
|
||||||
- , tasty-smallcheck >= 0.2 && < 0.3
|
|
||||||
+ , tasty >= 0.3.1 && < 0.9
|
|
||||||
+ , tasty-smallcheck >= 0.2 && < 0.9
|
|
||||||
, smallcheck >= 1.0 && < 1.2
|
|
||||||
, text >= 0.8 && < 1.2
|
|
||||||
|
|
||||||
@ -1,12 +0,0 @@
|
|||||||
diff -ru orig/snap.cabal new/snap.cabal
|
|
||||||
--- orig/snap.cabal 2014-03-19 10:17:25.886213731 +0200
|
|
||||||
+++ new/snap.cabal 2014-03-19 10:17:25.000000000 +0200
|
|
||||||
@@ -154,7 +154,7 @@
|
|
||||||
containers >= 0.3 && < 0.6,
|
|
||||||
directory >= 1.0 && < 1.3,
|
|
||||||
directory-tree >= 0.11 && < 0.12,
|
|
||||||
- dlist >= 0.5 && < 0.7,
|
|
||||||
+ dlist >= 0.5 && < 0.8,
|
|
||||||
errors >= 1.4 && < 1.5,
|
|
||||||
filepath >= 1.1 && < 1.4,
|
|
||||||
-- Blacklist bad versions of hashable
|
|
||||||
@ -1,12 +0,0 @@
|
|||||||
diff -ru orig/Database/SQLite/Simple.hs new/Database/SQLite/Simple.hs
|
|
||||||
--- orig/Database/SQLite/Simple.hs 2014-02-14 14:38:24.411759783 +0200
|
|
||||||
+++ new/Database/SQLite/Simple.hs 2014-02-14 14:38:24.000000000 +0200
|
|
||||||
@@ -343,7 +343,7 @@
|
|
||||||
| otherwise -> errorColumnMismatch (ColumnOutOfBounds col)
|
|
||||||
Errors [] -> throwIO $ ConversionFailed "" "" "unknown error"
|
|
||||||
Errors [x] ->
|
|
||||||
- throw x `catch` (\e -> errorColumnMismatch (e :: ColumnOutOfBounds))
|
|
||||||
+ throw x `Control.Exception.catch` (\e -> errorColumnMismatch (e :: ColumnOutOfBounds))
|
|
||||||
Errors xs -> throwIO $ ManyErrors xs
|
|
||||||
where
|
|
||||||
errorColumnMismatch :: ColumnOutOfBounds -> IO r
|
|
||||||
@ -1,705 +0,0 @@
|
|||||||
diff -ru orig/Statistics/Distribution/Beta.hs new/Statistics/Distribution/Beta.hs
|
|
||||||
--- orig/Statistics/Distribution/Beta.hs 2014-04-14 09:04:31.421509375 +0300
|
|
||||||
+++ new/Statistics/Distribution/Beta.hs 2014-04-14 09:04:31.000000000 +0300
|
|
||||||
@@ -1,4 +1,4 @@
|
|
||||||
-{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
|
|
||||||
+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, CPP #-}
|
|
||||||
-----------------------------------------------------------------------------
|
|
||||||
-- |
|
|
||||||
-- Module : Statistics.Distribution.Beta
|
|
||||||
@@ -27,6 +27,10 @@
|
|
||||||
incompleteBeta, invIncompleteBeta, logBeta, digamma)
|
|
||||||
import Numeric.MathFunctions.Constants (m_NaN)
|
|
||||||
import qualified Statistics.Distribution as D
|
|
||||||
+#if !MIN_VERSION_binary(0, 6, 0)
|
|
||||||
+import Data.Binary (put, get)
|
|
||||||
+import Control.Applicative ((<$>), (<*>))
|
|
||||||
+#endif
|
|
||||||
|
|
||||||
-- | The beta distribution
|
|
||||||
data BetaDistribution = BD
|
|
||||||
@@ -36,7 +40,11 @@
|
|
||||||
-- ^ Beta shape parameter
|
|
||||||
} deriving (Eq, Read, Show, Typeable, Data, Generic)
|
|
||||||
|
|
||||||
-instance Binary BetaDistribution
|
|
||||||
+instance Binary BetaDistribution where
|
|
||||||
+#if !MIN_VERSION_binary(0, 6, 0)
|
|
||||||
+ put (BD x y) = put x >> put y
|
|
||||||
+ get = BD <$> get <*> get
|
|
||||||
+#endif
|
|
||||||
|
|
||||||
-- | Create beta distribution. Both shape parameters must be positive.
|
|
||||||
betaDistr :: Double -- ^ Shape parameter alpha
|
|
||||||
diff -ru orig/Statistics/Distribution/Binomial.hs new/Statistics/Distribution/Binomial.hs
|
|
||||||
--- orig/Statistics/Distribution/Binomial.hs 2014-04-14 09:04:31.421509375 +0300
|
|
||||||
+++ new/Statistics/Distribution/Binomial.hs 2014-04-14 09:04:31.000000000 +0300
|
|
||||||
@@ -1,4 +1,4 @@
|
|
||||||
-{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
|
|
||||||
+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, CPP #-}
|
|
||||||
-- |
|
|
||||||
-- Module : Statistics.Distribution.Binomial
|
|
||||||
-- Copyright : (c) 2009 Bryan O'Sullivan
|
|
||||||
@@ -30,6 +30,10 @@
|
|
||||||
import qualified Statistics.Distribution.Poisson.Internal as I
|
|
||||||
import Numeric.SpecFunctions (choose,incompleteBeta)
|
|
||||||
import Numeric.MathFunctions.Constants (m_epsilon)
|
|
||||||
+#if !MIN_VERSION_binary(0, 6, 0)
|
|
||||||
+import Data.Binary (put, get)
|
|
||||||
+import Control.Applicative ((<$>), (<*>))
|
|
||||||
+#endif
|
|
||||||
|
|
||||||
|
|
||||||
-- | The binomial distribution.
|
|
||||||
@@ -40,7 +44,11 @@
|
|
||||||
-- ^ Probability.
|
|
||||||
} deriving (Eq, Read, Show, Typeable, Data, Generic)
|
|
||||||
|
|
||||||
-instance Binary BinomialDistribution
|
|
||||||
+instance Binary BinomialDistribution where
|
|
||||||
+#if !MIN_VERSION_binary(0, 6, 0)
|
|
||||||
+ put (BD x y) = put x >> put y
|
|
||||||
+ get = BD <$> get <*> get
|
|
||||||
+#endif
|
|
||||||
|
|
||||||
instance D.Distribution BinomialDistribution where
|
|
||||||
cumulative = cumulative
|
|
||||||
diff -ru orig/Statistics/Distribution/CauchyLorentz.hs new/Statistics/Distribution/CauchyLorentz.hs
|
|
||||||
--- orig/Statistics/Distribution/CauchyLorentz.hs 2014-04-14 09:04:31.421509375 +0300
|
|
||||||
+++ new/Statistics/Distribution/CauchyLorentz.hs 2014-04-14 09:04:31.000000000 +0300
|
|
||||||
@@ -1,4 +1,4 @@
|
|
||||||
-{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
|
|
||||||
+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, CPP #-}
|
|
||||||
-- |
|
|
||||||
-- Module : Statistics.Distribution.CauchyLorentz
|
|
||||||
-- Copyright : (c) 2011 Aleksey Khudyakov
|
|
||||||
@@ -25,6 +25,10 @@
|
|
||||||
import Data.Data (Data, Typeable)
|
|
||||||
import GHC.Generics (Generic)
|
|
||||||
import qualified Statistics.Distribution as D
|
|
||||||
+#if !MIN_VERSION_binary(0, 6, 0)
|
|
||||||
+import Data.Binary (put, get)
|
|
||||||
+import Control.Applicative ((<$>), (<*>))
|
|
||||||
+#endif
|
|
||||||
|
|
||||||
-- | Cauchy-Lorentz distribution.
|
|
||||||
data CauchyDistribution = CD {
|
|
||||||
@@ -39,7 +43,11 @@
|
|
||||||
}
|
|
||||||
deriving (Eq, Show, Read, Typeable, Data, Generic)
|
|
||||||
|
|
||||||
-instance Binary CauchyDistribution
|
|
||||||
+instance Binary CauchyDistribution where
|
|
||||||
+#if !MIN_VERSION_binary(0, 6, 0)
|
|
||||||
+ put (CD x y) = put x >> put y
|
|
||||||
+ get = CD <$> get <*> get
|
|
||||||
+#endif
|
|
||||||
|
|
||||||
-- | Cauchy distribution
|
|
||||||
cauchyDistribution :: Double -- ^ Central point
|
|
||||||
diff -ru orig/Statistics/Distribution/ChiSquared.hs new/Statistics/Distribution/ChiSquared.hs
|
|
||||||
--- orig/Statistics/Distribution/ChiSquared.hs 2014-04-14 09:04:31.421509375 +0300
|
|
||||||
+++ new/Statistics/Distribution/ChiSquared.hs 2014-04-14 09:04:31.000000000 +0300
|
|
||||||
@@ -1,4 +1,4 @@
|
|
||||||
-{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
|
|
||||||
+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, CPP #-}
|
|
||||||
-- |
|
|
||||||
-- Module : Statistics.Distribution.ChiSquared
|
|
||||||
-- Copyright : (c) 2010 Alexey Khudyakov
|
|
||||||
@@ -26,13 +26,20 @@
|
|
||||||
|
|
||||||
import qualified Statistics.Distribution as D
|
|
||||||
import qualified System.Random.MWC.Distributions as MWC
|
|
||||||
+#if !MIN_VERSION_binary(0, 6, 0)
|
|
||||||
+import Data.Binary (put, get)
|
|
||||||
+#endif
|
|
||||||
|
|
||||||
|
|
||||||
-- | Chi-squared distribution
|
|
||||||
newtype ChiSquared = ChiSquared Int
|
|
||||||
deriving (Eq, Read, Show, Typeable, Data, Generic)
|
|
||||||
|
|
||||||
-instance Binary ChiSquared
|
|
||||||
+instance Binary ChiSquared where
|
|
||||||
+#if !MIN_VERSION_binary(0, 6, 0)
|
|
||||||
+ get = fmap ChiSquared get
|
|
||||||
+ put (ChiSquared x) = put x
|
|
||||||
+#endif
|
|
||||||
|
|
||||||
-- | Get number of degrees of freedom
|
|
||||||
chiSquaredNDF :: ChiSquared -> Int
|
|
||||||
diff -ru orig/Statistics/Distribution/Exponential.hs new/Statistics/Distribution/Exponential.hs
|
|
||||||
--- orig/Statistics/Distribution/Exponential.hs 2014-04-14 09:04:31.421509375 +0300
|
|
||||||
+++ new/Statistics/Distribution/Exponential.hs 2014-04-14 09:04:31.000000000 +0300
|
|
||||||
@@ -1,4 +1,4 @@
|
|
||||||
-{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
|
|
||||||
+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, CPP #-}
|
|
||||||
-- |
|
|
||||||
-- Module : Statistics.Distribution.Exponential
|
|
||||||
-- Copyright : (c) 2009 Bryan O'Sullivan
|
|
||||||
@@ -31,13 +31,20 @@
|
|
||||||
import qualified Statistics.Sample as S
|
|
||||||
import qualified System.Random.MWC.Distributions as MWC
|
|
||||||
import Statistics.Types (Sample)
|
|
||||||
+#if !MIN_VERSION_binary(0, 6, 0)
|
|
||||||
+import Data.Binary (put, get)
|
|
||||||
+#endif
|
|
||||||
|
|
||||||
|
|
||||||
newtype ExponentialDistribution = ED {
|
|
||||||
edLambda :: Double
|
|
||||||
} deriving (Eq, Read, Show, Typeable, Data, Generic)
|
|
||||||
|
|
||||||
-instance Binary ExponentialDistribution
|
|
||||||
+instance Binary ExponentialDistribution where
|
|
||||||
+#if !MIN_VERSION_binary(0, 6, 0)
|
|
||||||
+ put = put . edLambda
|
|
||||||
+ get = fmap ED get
|
|
||||||
+#endif
|
|
||||||
|
|
||||||
instance D.Distribution ExponentialDistribution where
|
|
||||||
cumulative = cumulative
|
|
||||||
diff -ru orig/Statistics/Distribution/FDistribution.hs new/Statistics/Distribution/FDistribution.hs
|
|
||||||
--- orig/Statistics/Distribution/FDistribution.hs 2014-04-14 09:04:31.421509375 +0300
|
|
||||||
+++ new/Statistics/Distribution/FDistribution.hs 2014-04-14 09:04:31.000000000 +0300
|
|
||||||
@@ -1,4 +1,4 @@
|
|
||||||
-{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
|
|
||||||
+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, CPP #-}
|
|
||||||
-- |
|
|
||||||
-- Module : Statistics.Distribution.FDistribution
|
|
||||||
-- Copyright : (c) 2011 Aleksey Khudyakov
|
|
||||||
@@ -23,6 +23,10 @@
|
|
||||||
import qualified Statistics.Distribution as D
|
|
||||||
import Numeric.SpecFunctions (
|
|
||||||
logBeta, incompleteBeta, invIncompleteBeta, digamma)
|
|
||||||
+#if !MIN_VERSION_binary(0, 6, 0)
|
|
||||||
+import Data.Binary (put, get)
|
|
||||||
+import Control.Applicative ((<$>), (<*>))
|
|
||||||
+#endif
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
@@ -33,7 +37,11 @@
|
|
||||||
}
|
|
||||||
deriving (Eq, Show, Read, Typeable, Data, Generic)
|
|
||||||
|
|
||||||
-instance Binary FDistribution
|
|
||||||
+instance Binary FDistribution where
|
|
||||||
+#if !MIN_VERSION_binary(0, 6, 0)
|
|
||||||
+ get = F <$> get <*> get <*> get
|
|
||||||
+ put (F x y z) = put x >> put y >> put z
|
|
||||||
+#endif
|
|
||||||
|
|
||||||
fDistribution :: Int -> Int -> FDistribution
|
|
||||||
fDistribution n m
|
|
||||||
diff -ru orig/Statistics/Distribution/Gamma.hs new/Statistics/Distribution/Gamma.hs
|
|
||||||
--- orig/Statistics/Distribution/Gamma.hs 2014-04-14 09:04:31.421509375 +0300
|
|
||||||
+++ new/Statistics/Distribution/Gamma.hs 2014-04-14 09:04:31.000000000 +0300
|
|
||||||
@@ -1,4 +1,4 @@
|
|
||||||
-{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
|
|
||||||
+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, CPP #-}
|
|
||||||
-- |
|
|
||||||
-- Module : Statistics.Distribution.Gamma
|
|
||||||
-- Copyright : (c) 2009, 2011 Bryan O'Sullivan
|
|
||||||
@@ -34,6 +34,10 @@
|
|
||||||
import Statistics.Distribution.Poisson.Internal as Poisson
|
|
||||||
import qualified Statistics.Distribution as D
|
|
||||||
import qualified System.Random.MWC.Distributions as MWC
|
|
||||||
+#if !MIN_VERSION_binary(0, 6, 0)
|
|
||||||
+import Data.Binary (put, get)
|
|
||||||
+import Control.Applicative ((<$>), (<*>))
|
|
||||||
+#endif
|
|
||||||
|
|
||||||
-- | The gamma distribution.
|
|
||||||
data GammaDistribution = GD {
|
|
||||||
@@ -41,7 +45,11 @@
|
|
||||||
, gdScale :: {-# UNPACK #-} !Double -- ^ Scale parameter, ϑ.
|
|
||||||
} deriving (Eq, Read, Show, Typeable, Data, Generic)
|
|
||||||
|
|
||||||
-instance Binary GammaDistribution
|
|
||||||
+instance Binary GammaDistribution where
|
|
||||||
+#if !MIN_VERSION_binary(0, 6, 0)
|
|
||||||
+ put (GD x y) = put x >> put y
|
|
||||||
+ get = GD <$> get <*> get
|
|
||||||
+#endif
|
|
||||||
|
|
||||||
-- | Create gamma distribution. Both shape and scale parameters must
|
|
||||||
-- be positive.
|
|
||||||
diff -ru orig/Statistics/Distribution/Geometric.hs new/Statistics/Distribution/Geometric.hs
|
|
||||||
--- orig/Statistics/Distribution/Geometric.hs 2014-04-14 09:04:31.421509375 +0300
|
|
||||||
+++ new/Statistics/Distribution/Geometric.hs 2014-04-14 09:04:31.000000000 +0300
|
|
||||||
@@ -1,4 +1,4 @@
|
|
||||||
-{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
|
|
||||||
+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, CPP #-}
|
|
||||||
-- |
|
|
||||||
-- Module : Statistics.Distribution.Geometric
|
|
||||||
-- Copyright : (c) 2009 Bryan O'Sullivan
|
|
||||||
@@ -37,6 +37,10 @@
|
|
||||||
import Numeric.MathFunctions.Constants(m_pos_inf,m_neg_inf)
|
|
||||||
import qualified Statistics.Distribution as D
|
|
||||||
import qualified System.Random.MWC.Distributions as MWC
|
|
||||||
+#if !MIN_VERSION_binary(0, 6, 0)
|
|
||||||
+import Data.Binary (put, get)
|
|
||||||
+import Control.Applicative ((<$>))
|
|
||||||
+#endif
|
|
||||||
|
|
||||||
----------------------------------------------------------------
|
|
||||||
-- Distribution over [1..]
|
|
||||||
@@ -45,7 +49,11 @@
|
|
||||||
gdSuccess :: Double
|
|
||||||
} deriving (Eq, Read, Show, Typeable, Data, Generic)
|
|
||||||
|
|
||||||
-instance Binary GeometricDistribution
|
|
||||||
+instance Binary GeometricDistribution where
|
|
||||||
+#if !MIN_VERSION_binary(0, 6, 0)
|
|
||||||
+ get = GD <$> get
|
|
||||||
+ put (GD x) = put x
|
|
||||||
+#endif
|
|
||||||
|
|
||||||
instance D.Distribution GeometricDistribution where
|
|
||||||
cumulative = cumulative
|
|
||||||
@@ -115,7 +123,11 @@
|
|
||||||
gdSuccess0 :: Double
|
|
||||||
} deriving (Eq, Read, Show, Typeable, Data, Generic)
|
|
||||||
|
|
||||||
-instance Binary GeometricDistribution0
|
|
||||||
+instance Binary GeometricDistribution0 where
|
|
||||||
+#if !MIN_VERSION_binary(0, 6, 0)
|
|
||||||
+ get = GD0 <$> get
|
|
||||||
+ put (GD0 x) = put x
|
|
||||||
+#endif
|
|
||||||
|
|
||||||
instance D.Distribution GeometricDistribution0 where
|
|
||||||
cumulative (GD0 s) x = cumulative (GD s) (x + 1)
|
|
||||||
diff -ru orig/Statistics/Distribution/Hypergeometric.hs new/Statistics/Distribution/Hypergeometric.hs
|
|
||||||
--- orig/Statistics/Distribution/Hypergeometric.hs 2014-04-14 09:04:31.421509375 +0300
|
|
||||||
+++ new/Statistics/Distribution/Hypergeometric.hs 2014-04-14 09:04:31.000000000 +0300
|
|
||||||
@@ -1,4 +1,4 @@
|
|
||||||
-{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
|
|
||||||
+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, CPP #-}
|
|
||||||
-- |
|
|
||||||
-- Module : Statistics.Distribution.Hypergeometric
|
|
||||||
-- Copyright : (c) 2009 Bryan O'Sullivan
|
|
||||||
@@ -33,6 +33,10 @@
|
|
||||||
import Numeric.MathFunctions.Constants (m_epsilon)
|
|
||||||
import Numeric.SpecFunctions (choose)
|
|
||||||
import qualified Statistics.Distribution as D
|
|
||||||
+#if !MIN_VERSION_binary(0, 6, 0)
|
|
||||||
+import Data.Binary (put, get)
|
|
||||||
+import Control.Applicative ((<$>), (<*>))
|
|
||||||
+#endif
|
|
||||||
|
|
||||||
data HypergeometricDistribution = HD {
|
|
||||||
hdM :: {-# UNPACK #-} !Int
|
|
||||||
@@ -40,7 +44,11 @@
|
|
||||||
, hdK :: {-# UNPACK #-} !Int
|
|
||||||
} deriving (Eq, Read, Show, Typeable, Data, Generic)
|
|
||||||
|
|
||||||
-instance Binary HypergeometricDistribution
|
|
||||||
+instance Binary HypergeometricDistribution where
|
|
||||||
+#if !MIN_VERSION_binary(0, 6, 0)
|
|
||||||
+ get = HD <$> get <*> get <*> get
|
|
||||||
+ put (HD x y z) = put x >> put y >> put z
|
|
||||||
+#endif
|
|
||||||
|
|
||||||
instance D.Distribution HypergeometricDistribution where
|
|
||||||
cumulative = cumulative
|
|
||||||
diff -ru orig/Statistics/Distribution/Normal.hs new/Statistics/Distribution/Normal.hs
|
|
||||||
--- orig/Statistics/Distribution/Normal.hs 2014-04-14 09:04:31.421509375 +0300
|
|
||||||
+++ new/Statistics/Distribution/Normal.hs 2014-04-14 09:04:31.000000000 +0300
|
|
||||||
@@ -1,4 +1,4 @@
|
|
||||||
-{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric #-}
|
|
||||||
+{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, CPP #-}
|
|
||||||
-- |
|
|
||||||
-- Module : Statistics.Distribution.Normal
|
|
||||||
-- Copyright : (c) 2009 Bryan O'Sullivan
|
|
||||||
@@ -28,6 +28,8 @@
|
|
||||||
import qualified Statistics.Distribution as D
|
|
||||||
import qualified Statistics.Sample as S
|
|
||||||
import qualified System.Random.MWC.Distributions as MWC
|
|
||||||
+import Data.Binary (put, get)
|
|
||||||
+import Control.Applicative ((<$>), (<*>))
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
@@ -39,7 +41,9 @@
|
|
||||||
, ndCdfDenom :: {-# UNPACK #-} !Double
|
|
||||||
} deriving (Eq, Read, Show, Typeable, Data, Generic)
|
|
||||||
|
|
||||||
-instance Binary NormalDistribution
|
|
||||||
+instance Binary NormalDistribution where
|
|
||||||
+ put (ND w x y z) = put w >> put x >> put y >> put z
|
|
||||||
+ get = ND <$> get <*> get <*> get <*> get
|
|
||||||
|
|
||||||
instance D.Distribution NormalDistribution where
|
|
||||||
cumulative = cumulative
|
|
||||||
diff -ru orig/Statistics/Distribution/Poisson/Internal.hs new/Statistics/Distribution/Poisson/Internal.hs
|
|
||||||
--- orig/Statistics/Distribution/Poisson/Internal.hs 2014-04-14 09:04:31.421509375 +0300
|
|
||||||
+++ new/Statistics/Distribution/Poisson/Internal.hs 2014-04-14 09:04:31.000000000 +0300
|
|
||||||
@@ -36,8 +36,8 @@
|
|
||||||
-- | Compute entropy using Theorem 1 from "Sharp Bounds on the Entropy
|
|
||||||
-- of the Poisson Law". This function is unused because 'directEntorpy'
|
|
||||||
-- is just as accurate and is faster by about a factor of 4.
|
|
||||||
-alyThm1 :: Double -> Double
|
|
||||||
-alyThm1 lambda =
|
|
||||||
+_alyThm1 :: Double -> Double
|
|
||||||
+_alyThm1 lambda =
|
|
||||||
sum (takeWhile (\x -> abs x >= m_epsilon * lll) alySeries) + lll
|
|
||||||
where lll = lambda * (1 - log lambda)
|
|
||||||
alySeries =
|
|
||||||
@@ -175,4 +175,4 @@
|
|
||||||
| lambda <= 18 = alyThm2 lambda upperCoefficients6 lowerCoefficients6
|
|
||||||
| lambda <= 24 = alyThm2 lambda upperCoefficients8 lowerCoefficients8
|
|
||||||
| lambda <= 30 = alyThm2 lambda upperCoefficients10 lowerCoefficients10
|
|
||||||
- | otherwise = alyThm2 lambda upperCoefficients12 lowerCoefficients12
|
|
||||||
\ No newline at end of file
|
|
||||||
+ | otherwise = alyThm2 lambda upperCoefficients12 lowerCoefficients12
|
|
||||||
diff -ru orig/Statistics/Distribution/Poisson.hs new/Statistics/Distribution/Poisson.hs
|
|
||||||
--- orig/Statistics/Distribution/Poisson.hs 2014-04-14 09:04:31.421509375 +0300
|
|
||||||
+++ new/Statistics/Distribution/Poisson.hs 2014-04-14 09:04:31.000000000 +0300
|
|
||||||
@@ -1,4 +1,4 @@
|
|
||||||
-{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
|
|
||||||
+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, CPP #-}
|
|
||||||
-- |
|
|
||||||
-- Module : Statistics.Distribution.Poisson
|
|
||||||
-- Copyright : (c) 2009, 2011 Bryan O'Sullivan
|
|
||||||
@@ -31,13 +31,20 @@
|
|
||||||
import qualified Statistics.Distribution.Poisson.Internal as I
|
|
||||||
import Numeric.SpecFunctions (incompleteGamma,logFactorial)
|
|
||||||
import Numeric.MathFunctions.Constants (m_neg_inf)
|
|
||||||
+#if !MIN_VERSION_binary(0, 6, 0)
|
|
||||||
+import Data.Binary (put, get)
|
|
||||||
+#endif
|
|
||||||
|
|
||||||
|
|
||||||
newtype PoissonDistribution = PD {
|
|
||||||
poissonLambda :: Double
|
|
||||||
} deriving (Eq, Read, Show, Typeable, Data, Generic)
|
|
||||||
|
|
||||||
-instance Binary PoissonDistribution
|
|
||||||
+instance Binary PoissonDistribution where
|
|
||||||
+#if !MIN_VERSION_binary(0, 6, 0)
|
|
||||||
+ get = fmap PD get
|
|
||||||
+ put = put . poissonLambda
|
|
||||||
+#endif
|
|
||||||
|
|
||||||
instance D.Distribution PoissonDistribution where
|
|
||||||
cumulative (PD lambda) x
|
|
||||||
@@ -78,8 +85,9 @@
|
|
||||||
poisson :: Double -> PoissonDistribution
|
|
||||||
poisson l
|
|
||||||
| l >= 0 = PD l
|
|
||||||
- | otherwise = error $ "Statistics.Distribution.Poisson.poisson:\
|
|
||||||
- \ lambda must be non-negative. Got " ++ show l
|
|
||||||
+ | otherwise = error $
|
|
||||||
+ "Statistics.Distribution.Poisson.poisson: lambda must be non-negative. Got "
|
|
||||||
+ ++ show l
|
|
||||||
{-# INLINE poisson #-}
|
|
||||||
|
|
||||||
-- $references
|
|
||||||
diff -ru orig/Statistics/Distribution/StudentT.hs new/Statistics/Distribution/StudentT.hs
|
|
||||||
--- orig/Statistics/Distribution/StudentT.hs 2014-04-14 09:04:31.421509375 +0300
|
|
||||||
+++ new/Statistics/Distribution/StudentT.hs 2014-04-14 09:04:31.000000000 +0300
|
|
||||||
@@ -1,4 +1,4 @@
|
|
||||||
-{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
|
|
||||||
+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, CPP #-}
|
|
||||||
-- |
|
|
||||||
-- Module : Statistics.Distribution.StudentT
|
|
||||||
-- Copyright : (c) 2011 Aleksey Khudyakov
|
|
||||||
@@ -23,12 +23,19 @@
|
|
||||||
import Statistics.Distribution.Transform (LinearTransform (..))
|
|
||||||
import Numeric.SpecFunctions (
|
|
||||||
logBeta, incompleteBeta, invIncompleteBeta, digamma)
|
|
||||||
+#if !MIN_VERSION_binary(0, 6, 0)
|
|
||||||
+import Data.Binary (put, get)
|
|
||||||
+#endif
|
|
||||||
|
|
||||||
-- | Student-T distribution
|
|
||||||
newtype StudentT = StudentT { studentTndf :: Double }
|
|
||||||
deriving (Eq, Show, Read, Typeable, Data, Generic)
|
|
||||||
|
|
||||||
-instance Binary StudentT
|
|
||||||
+instance Binary StudentT where
|
|
||||||
+#if !MIN_VERSION_binary(0, 6, 0)
|
|
||||||
+ put = put . studentTndf
|
|
||||||
+ get = fmap StudentT get
|
|
||||||
+#endif
|
|
||||||
|
|
||||||
-- | Create Student-T distribution. Number of parameters must be positive.
|
|
||||||
studentT :: Double -> StudentT
|
|
||||||
diff -ru orig/Statistics/Distribution/Transform.hs new/Statistics/Distribution/Transform.hs
|
|
||||||
--- orig/Statistics/Distribution/Transform.hs 2014-04-14 09:04:31.421509375 +0300
|
|
||||||
+++ new/Statistics/Distribution/Transform.hs 2014-04-14 09:04:31.000000000 +0300
|
|
||||||
@@ -1,5 +1,5 @@
|
|
||||||
{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, FlexibleContexts,
|
|
||||||
- FlexibleInstances, UndecidableInstances #-}
|
|
||||||
+ FlexibleInstances, UndecidableInstances, CPP #-}
|
|
||||||
-- |
|
|
||||||
-- Module : Statistics.Distribution.Transform
|
|
||||||
-- Copyright : (c) 2013 John McDonnell;
|
|
||||||
@@ -21,6 +21,10 @@
|
|
||||||
import GHC.Generics (Generic)
|
|
||||||
import Data.Functor ((<$>))
|
|
||||||
import qualified Statistics.Distribution as D
|
|
||||||
+#if !MIN_VERSION_binary(0, 6, 0)
|
|
||||||
+import Data.Binary (put, get)
|
|
||||||
+import Control.Applicative ((<*>))
|
|
||||||
+#endif
|
|
||||||
|
|
||||||
-- | Linear transformation applied to distribution.
|
|
||||||
--
|
|
||||||
@@ -35,7 +39,11 @@
|
|
||||||
-- ^ Distribution being transformed.
|
|
||||||
} deriving (Eq, Show, Read, Typeable, Data, Generic)
|
|
||||||
|
|
||||||
-instance (Binary d) => Binary (LinearTransform d)
|
|
||||||
+instance (Binary d) => Binary (LinearTransform d) where
|
|
||||||
+#if !MIN_VERSION_binary(0, 6, 0)
|
|
||||||
+ get = LinearTransform <$> get <*> get <*> get
|
|
||||||
+ put (LinearTransform x y z) = put x >> put y >> put z
|
|
||||||
+#endif
|
|
||||||
|
|
||||||
-- | Apply linear transformation to distribution.
|
|
||||||
scaleAround :: Double -- ^ Fixed point
|
|
||||||
diff -ru orig/Statistics/Distribution/Uniform.hs new/Statistics/Distribution/Uniform.hs
|
|
||||||
--- orig/Statistics/Distribution/Uniform.hs 2014-04-14 09:04:31.421509375 +0300
|
|
||||||
+++ new/Statistics/Distribution/Uniform.hs 2014-04-14 09:04:31.000000000 +0300
|
|
||||||
@@ -1,4 +1,4 @@
|
|
||||||
-{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
|
|
||||||
+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, CPP #-}
|
|
||||||
-- |
|
|
||||||
-- Module : Statistics.Distribution.Uniform
|
|
||||||
-- Copyright : (c) 2011 Aleksey Khudyakov
|
|
||||||
@@ -24,6 +24,10 @@
|
|
||||||
import GHC.Generics (Generic)
|
|
||||||
import qualified Statistics.Distribution as D
|
|
||||||
import qualified System.Random.MWC as MWC
|
|
||||||
+#if !MIN_VERSION_binary(0, 6, 0)
|
|
||||||
+import Data.Binary (put, get)
|
|
||||||
+import Control.Applicative ((<$>), (<*>))
|
|
||||||
+#endif
|
|
||||||
|
|
||||||
|
|
||||||
-- | Uniform distribution from A to B
|
|
||||||
@@ -32,7 +36,11 @@
|
|
||||||
, uniformB :: {-# UNPACK #-} !Double -- ^ Upper boundary of distribution
|
|
||||||
} deriving (Eq, Read, Show, Typeable, Data, Generic)
|
|
||||||
|
|
||||||
-instance Binary UniformDistribution
|
|
||||||
+instance Binary UniformDistribution where
|
|
||||||
+#if !MIN_VERSION_binary(0, 6, 0)
|
|
||||||
+ put (UniformDistribution x y) = put x >> put y
|
|
||||||
+ get = UniformDistribution <$> get <*> get
|
|
||||||
+#endif
|
|
||||||
|
|
||||||
-- | Create uniform distribution.
|
|
||||||
uniformDistr :: Double -> Double -> UniformDistribution
|
|
||||||
diff -ru orig/Statistics/Math/RootFinding.hs new/Statistics/Math/RootFinding.hs
|
|
||||||
--- orig/Statistics/Math/RootFinding.hs 2014-04-14 09:04:31.421509375 +0300
|
|
||||||
+++ new/Statistics/Math/RootFinding.hs 2014-04-14 09:04:31.000000000 +0300
|
|
||||||
@@ -1,4 +1,4 @@
|
|
||||||
-{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric #-}
|
|
||||||
+{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, CPP #-}
|
|
||||||
|
|
||||||
-- |
|
|
||||||
-- Module : Statistics.Math.RootFinding
|
|
||||||
@@ -27,6 +27,11 @@
|
|
||||||
import Control.Monad (MonadPlus(..), ap)
|
|
||||||
import Data.Data (Data, Typeable)
|
|
||||||
import GHC.Generics (Generic)
|
|
||||||
+#if !MIN_VERSION_binary(0, 6, 0)
|
|
||||||
+import Data.Binary (put, get)
|
|
||||||
+import Data.Binary.Put (putWord8)
|
|
||||||
+import Data.Binary.Get (getWord8)
|
|
||||||
+#endif
|
|
||||||
|
|
||||||
|
|
||||||
-- | The result of searching for a root of a mathematical function.
|
|
||||||
@@ -40,7 +45,20 @@
|
|
||||||
-- ^ A root was successfully found.
|
|
||||||
deriving (Eq, Read, Show, Typeable, Data, Generic)
|
|
||||||
|
|
||||||
-instance (Binary a) => Binary (Root a)
|
|
||||||
+instance (Binary a) => Binary (Root a) where
|
|
||||||
+#if !MIN_VERSION_binary(0, 6, 0)
|
|
||||||
+ put NotBracketed = putWord8 0
|
|
||||||
+ put SearchFailed = putWord8 1
|
|
||||||
+ put (Root a) = putWord8 2 >> put a
|
|
||||||
+
|
|
||||||
+ get = do
|
|
||||||
+ i <- getWord8
|
|
||||||
+ case i of
|
|
||||||
+ 0 -> return NotBracketed
|
|
||||||
+ 1 -> return SearchFailed
|
|
||||||
+ 2 -> fmap Root get
|
|
||||||
+ _ -> fail $ "Root.get: Invalid value: " ++ show i
|
|
||||||
+#endif
|
|
||||||
|
|
||||||
instance Functor Root where
|
|
||||||
fmap _ NotBracketed = NotBracketed
|
|
||||||
diff -ru orig/Statistics/Resampling/Bootstrap.hs new/Statistics/Resampling/Bootstrap.hs
|
|
||||||
--- orig/Statistics/Resampling/Bootstrap.hs 2014-04-14 09:04:31.421509375 +0300
|
|
||||||
+++ new/Statistics/Resampling/Bootstrap.hs 2014-04-14 09:04:31.000000000 +0300
|
|
||||||
@@ -1,5 +1,5 @@
|
|
||||||
{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, OverloadedStrings,
|
|
||||||
- RecordWildCards #-}
|
|
||||||
+ RecordWildCards, CPP #-}
|
|
||||||
|
|
||||||
-- |
|
|
||||||
-- Module : Statistics.Resampling.Bootstrap
|
|
||||||
@@ -35,6 +35,10 @@
|
|
||||||
import Statistics.Sample (mean)
|
|
||||||
import Statistics.Types (Estimator, Sample)
|
|
||||||
import qualified Data.Vector.Unboxed as U
|
|
||||||
+#if !MIN_VERSION_binary(0, 6, 0)
|
|
||||||
+import Data.Binary (put, get)
|
|
||||||
+import Control.Applicative ((<$>), (<*>))
|
|
||||||
+#endif
|
|
||||||
|
|
||||||
-- | A point and interval estimate computed via an 'Estimator'.
|
|
||||||
data Estimate = Estimate {
|
|
||||||
@@ -50,7 +54,11 @@
|
|
||||||
-- ^ Confidence level of the confidence intervals.
|
|
||||||
} deriving (Eq, Read, Show, Typeable, Data, Generic)
|
|
||||||
|
|
||||||
-instance Binary Estimate
|
|
||||||
+instance Binary Estimate where
|
|
||||||
+#if !MIN_VERSION_binary(0, 6, 0)
|
|
||||||
+ put (Estimate w x y z) = put w >> put x >> put y >> put z
|
|
||||||
+ get = Estimate <$> get <*> get <*> get <*> get
|
|
||||||
+#endif
|
|
||||||
instance NFData Estimate
|
|
||||||
|
|
||||||
-- | Multiply the point, lower bound, and upper bound in an 'Estimate'
|
|
||||||
diff -ru orig/Statistics/Resampling.hs new/Statistics/Resampling.hs
|
|
||||||
--- orig/Statistics/Resampling.hs 2014-04-14 09:04:31.421509375 +0300
|
|
||||||
+++ new/Statistics/Resampling.hs 2014-04-14 09:04:31.000000000 +0300
|
|
||||||
@@ -1,4 +1,4 @@
|
|
||||||
-{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric #-}
|
|
||||||
+{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, CPP #-}
|
|
||||||
|
|
||||||
-- |
|
|
||||||
-- Module : Statistics.Resampling
|
|
||||||
@@ -42,7 +42,11 @@
|
|
||||||
fromResample :: U.Vector Double
|
|
||||||
} deriving (Eq, Read, Show, Typeable, Data, Generic)
|
|
||||||
|
|
||||||
-instance Binary Resample
|
|
||||||
+instance Binary Resample where
|
|
||||||
+#if !MIN_VERSION_binary(0, 6, 0)
|
|
||||||
+ put = put . fromResample
|
|
||||||
+ get = fmap Resample get
|
|
||||||
+#endif
|
|
||||||
|
|
||||||
-- | /O(e*r*s)/ Resample a data set repeatedly, with replacement,
|
|
||||||
-- computing each estimate over the resampled data.
|
|
||||||
diff -ru orig/Statistics/Sample/KernelDensity/Simple.hs new/Statistics/Sample/KernelDensity/Simple.hs
|
|
||||||
--- orig/Statistics/Sample/KernelDensity/Simple.hs 2014-04-14 09:04:31.425509375 +0300
|
|
||||||
+++ new/Statistics/Sample/KernelDensity/Simple.hs 2014-04-14 09:04:31.000000000 +0300
|
|
||||||
@@ -1,4 +1,4 @@
|
|
||||||
-{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, FlexibleContexts #-}
|
|
||||||
+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, FlexibleContexts, CPP #-}
|
|
||||||
-- |
|
|
||||||
-- Module : Statistics.Sample.KernelDensity.Simple
|
|
||||||
-- Copyright : (c) 2009 Bryan O'Sullivan
|
|
||||||
@@ -61,7 +61,11 @@
|
|
||||||
fromPoints :: U.Vector Double
|
|
||||||
} deriving (Eq, Read, Show, Typeable, Data, Generic)
|
|
||||||
|
|
||||||
-instance Binary Points
|
|
||||||
+instance Binary Points where
|
|
||||||
+#if !MIN_VERSION_binary(0, 6, 0)
|
|
||||||
+ get = fmap Points get
|
|
||||||
+ put = put . fromPoints
|
|
||||||
+#endif
|
|
||||||
|
|
||||||
-- | Bandwidth estimator for an Epanechnikov kernel.
|
|
||||||
epanechnikovBW :: Double -> Bandwidth
|
|
||||||
diff -ru orig/Statistics/Sample/Powers.hs new/Statistics/Sample/Powers.hs
|
|
||||||
--- orig/Statistics/Sample/Powers.hs 2014-04-14 09:04:31.421509375 +0300
|
|
||||||
+++ new/Statistics/Sample/Powers.hs 2014-04-14 09:04:31.000000000 +0300
|
|
||||||
@@ -1,5 +1,5 @@
|
|
||||||
{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric,
|
|
||||||
- FlexibleContexts #-}
|
|
||||||
+ FlexibleContexts, CPP #-}
|
|
||||||
-- |
|
|
||||||
-- Module : Statistics.Sample.Powers
|
|
||||||
-- Copyright : (c) 2009, 2010 Bryan O'Sullivan
|
|
||||||
@@ -65,7 +65,11 @@
|
|
||||||
newtype Powers = Powers (U.Vector Double)
|
|
||||||
deriving (Eq, Read, Show, Typeable, Data, Generic)
|
|
||||||
|
|
||||||
-instance Binary Powers
|
|
||||||
+instance Binary Powers where
|
|
||||||
+#if !MIN_VERSION_binary(0, 6, 0)
|
|
||||||
+ put (Powers v) = put v
|
|
||||||
+ get = fmap Powers get
|
|
||||||
+#endif
|
|
||||||
|
|
||||||
-- | O(/n/) Collect the /n/ simple powers of a sample.
|
|
||||||
--
|
|
||||||
diff -ru orig/statistics.cabal new/statistics.cabal
|
|
||||||
--- orig/statistics.cabal 2014-04-14 09:04:31.429509375 +0300
|
|
||||||
+++ new/statistics.cabal 2014-04-14 09:04:31.000000000 +0300
|
|
||||||
@@ -90,7 +90,7 @@
|
|
||||||
Statistics.Test.Internal
|
|
||||||
build-depends:
|
|
||||||
base < 5,
|
|
||||||
- binary >= 0.6.3.0,
|
|
||||||
+ binary >= 0.5.1.0,
|
|
||||||
deepseq >= 1.1.0.2,
|
|
||||||
erf,
|
|
||||||
monad-par >= 0.3.4,
|
|
||||||
diff -ru orig/tests/Tests/Distribution.hs new/tests/Tests/Distribution.hs
|
|
||||||
--- orig/tests/Tests/Distribution.hs 2014-04-14 09:04:31.425509375 +0300
|
|
||||||
+++ new/tests/Tests/Distribution.hs 2014-04-14 09:04:31.000000000 +0300
|
|
||||||
@@ -188,7 +188,7 @@
|
|
||||||
|
|
||||||
-- Quantile is inverse of CDF
|
|
||||||
quantileIsInvCDF :: (Param d, ContDistr d) => T d -> d -> Double -> Property
|
|
||||||
-quantileIsInvCDF _ d (snd . properFraction -> p) =
|
|
||||||
+quantileIsInvCDF _ d ((snd :: (Int, y) -> y) . properFraction -> p) =
|
|
||||||
p > 0 && p < 1 ==> ( printTestCase (printf "Quantile = %g" q )
|
|
||||||
$ printTestCase (printf "Probability = %g" p )
|
|
||||||
$ printTestCase (printf "Probability' = %g" p')
|
|
||||||
@@ -203,8 +203,8 @@
|
|
||||||
quantileShouldFail :: (ContDistr d) => T d -> d -> Double -> Property
|
|
||||||
quantileShouldFail _ d p =
|
|
||||||
p < 0 || p > 1 ==> QC.monadicIO $ do r <- QC.run $ catch
|
|
||||||
- (do { return $! quantile d p; return False })
|
|
||||||
- (\(e :: SomeException) -> return True)
|
|
||||||
+ (do { _ <- return $! quantile d p; return False })
|
|
||||||
+ (\(_e :: SomeException) -> return True)
|
|
||||||
QC.assert r
|
|
||||||
|
|
||||||
|
|
||||||
diff -ru orig/tests/Tests/Function.hs new/tests/Tests/Function.hs
|
|
||||||
--- orig/tests/Tests/Function.hs 2014-04-14 09:04:31.425509375 +0300
|
|
||||||
+++ new/tests/Tests/Function.hs 2014-04-14 09:04:31.000000000 +0300
|
|
||||||
@@ -1,7 +1,6 @@
|
|
||||||
module Tests.Function ( tests ) where
|
|
||||||
|
|
||||||
import qualified Data.Vector.Unboxed as U
|
|
||||||
-import Data.Vector.Unboxed ((!))
|
|
||||||
|
|
||||||
import Test.QuickCheck
|
|
||||||
import Test.Framework
|
|
||||||
@@ -29,5 +28,5 @@
|
|
||||||
p_nextHighestPowerOfTwo
|
|
||||||
= all (\(good, is) -> all ((==good) . nextHighestPowerOfTwo) is) lists
|
|
||||||
where
|
|
||||||
- pows = [1 .. 17]
|
|
||||||
+ pows = [1 .. 17 :: Int]
|
|
||||||
lists = [ (2^m, [2^n+1 .. 2^m]) | (n,m) <- pows `zip` tail pows ]
|
|
||||||
diff -ru orig/tests/Tests/Transform.hs new/tests/Tests/Transform.hs
|
|
||||||
--- orig/tests/Tests/Transform.hs 2014-04-14 09:04:31.425509375 +0300
|
|
||||||
+++ new/tests/Tests/Transform.hs 2014-04-14 09:04:31.000000000 +0300
|
|
||||||
@@ -15,7 +15,7 @@
|
|
||||||
import Test.Framework (Test, testGroup)
|
|
||||||
import Test.Framework.Providers.QuickCheck2 (testProperty)
|
|
||||||
import Test.QuickCheck (Positive(..),Property,Arbitrary(..),Gen,choose,vectorOf,
|
|
||||||
- printTestCase, quickCheck)
|
|
||||||
+ printTestCase)
|
|
||||||
|
|
||||||
import Text.Printf
|
|
||||||
|
|
||||||
@ -1,16 +0,0 @@
|
|||||||
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
|
|
||||||
@ -1,201 +0,0 @@
|
|||||||
diff -ruN orig/Data/Conduit/TMChan.hs new/Data/Conduit/TMChan.hs
|
|
||||||
--- orig/Data/Conduit/TMChan.hs 2014-08-27 18:36:44.141176333 +0300
|
|
||||||
+++ new/Data/Conduit/TMChan.hs 2014-08-27 18:36:43.000000000 +0300
|
|
||||||
@@ -63,22 +63,23 @@
|
|
||||||
import Control.Concurrent.STM.TMChan
|
|
||||||
|
|
||||||
import Data.Conduit
|
|
||||||
-import Data.Conduit.Internal (Pipe (..), ConduitM (..))
|
|
||||||
+import qualified Data.Conduit.List as CL
|
|
||||||
|
|
||||||
-chanSource
|
|
||||||
+chanSource
|
|
||||||
:: MonadIO m
|
|
||||||
=> chan -- ^ The channel.
|
|
||||||
-> (chan -> STM (Maybe a)) -- ^ The 'read' function.
|
|
||||||
-> (chan -> STM ()) -- ^ The 'close' function.
|
|
||||||
-> Source m a
|
|
||||||
-chanSource ch reader closer = ConduitM src
|
|
||||||
- where
|
|
||||||
- src = PipeM pull
|
|
||||||
- pull = do a <- liftSTM $ reader ch
|
|
||||||
- case a of
|
|
||||||
- Just x -> return $ HaveOutput src close x
|
|
||||||
- Nothing -> return $ Done ()
|
|
||||||
- close = liftSTM $ closer ch
|
|
||||||
+chanSource ch reader closer =
|
|
||||||
+ loop
|
|
||||||
+ where
|
|
||||||
+ loop = do
|
|
||||||
+ a <- liftSTM $ reader ch
|
|
||||||
+ case a of
|
|
||||||
+ Just x -> yieldOr x close >> loop
|
|
||||||
+ Nothing -> return ()
|
|
||||||
+ close = liftSTM $ closer ch
|
|
||||||
{-# INLINE chanSource #-}
|
|
||||||
|
|
||||||
chanSink
|
|
||||||
@@ -87,13 +88,9 @@
|
|
||||||
-> (chan -> a -> STM ()) -- ^ The 'write' function.
|
|
||||||
-> (chan -> STM ()) -- ^ The 'close' function.
|
|
||||||
-> Sink a m ()
|
|
||||||
-chanSink ch writer closer = ConduitM sink
|
|
||||||
- where
|
|
||||||
- sink = NeedInput push close
|
|
||||||
-
|
|
||||||
- push input = PipeM ((liftIO . atomically $ writer ch input)
|
|
||||||
- >> (return $ NeedInput push close))
|
|
||||||
- close = const . liftSTM $ closer ch
|
|
||||||
+chanSink ch writer closer = do
|
|
||||||
+ CL.mapM_ $ liftIO . atomically . writer ch
|
|
||||||
+ liftSTM $ closer ch
|
|
||||||
{-# INLINE chanSink #-}
|
|
||||||
|
|
||||||
-- | A simple wrapper around a TBMChan. As data is pushed into the channel, the
|
|
||||||
diff -ruN orig/Data/Conduit/TQueue.hs new/Data/Conduit/TQueue.hs
|
|
||||||
--- orig/Data/Conduit/TQueue.hs 2014-08-27 18:36:44.141176333 +0300
|
|
||||||
+++ new/Data/Conduit/TQueue.hs 2014-08-27 18:36:43.000000000 +0300
|
|
||||||
@@ -58,46 +58,28 @@
|
|
||||||
import Control.Monad
|
|
||||||
import Control.Monad.IO.Class
|
|
||||||
import Data.Conduit
|
|
||||||
-import Data.Conduit.Internal
|
|
||||||
+import qualified Data.Conduit.List as CL
|
|
||||||
|
|
||||||
-- | A simple wrapper around a "TQueue". As data is pushed into the queue, the
|
|
||||||
-- source will read it and pass it down the conduit pipeline.
|
|
||||||
sourceTQueue :: MonadIO m => TQueue a -> Source m a
|
|
||||||
-sourceTQueue q = ConduitM src
|
|
||||||
- where src = PipeM pull
|
|
||||||
- pull = do x <- liftSTM $ readTQueue q
|
|
||||||
- return $ HaveOutput src close x
|
|
||||||
- close = return ()
|
|
||||||
+sourceTQueue q = forever $ liftSTM (readTQueue q) >>= yield
|
|
||||||
|
|
||||||
-- | A simple wrapper around a "TQueue". As data is pushed into this sink, it
|
|
||||||
-- will magically begin to appear in the queue.
|
|
||||||
sinkTQueue :: MonadIO m => TQueue a -> Sink a m ()
|
|
||||||
-sinkTQueue q = ConduitM src
|
|
||||||
- where src = sink
|
|
||||||
- sink = NeedInput push close
|
|
||||||
- push input = PipeM ((liftSTM $ writeTQueue q input)
|
|
||||||
- >> (return $ NeedInput push close))
|
|
||||||
- close _ = return ()
|
|
||||||
+sinkTQueue q = CL.mapM_ (liftSTM . writeTQueue q)
|
|
||||||
|
|
||||||
-- | A simple wrapper around a "TBQueue". As data is pushed into the queue, the
|
|
||||||
-- source will read it and pass it down the conduit pipeline.
|
|
||||||
sourceTBQueue :: MonadIO m => TBQueue a -> Source m a
|
|
||||||
-sourceTBQueue q = ConduitM src
|
|
||||||
- where src = PipeM pull
|
|
||||||
- pull = do x <- liftSTM $ readTBQueue q
|
|
||||||
- return $ HaveOutput src close x
|
|
||||||
- close = return ()
|
|
||||||
+sourceTBQueue q = forever $ liftSTM (readTBQueue q) >>= yield
|
|
||||||
|
|
||||||
-- | A simple wrapper around a "TBQueue". As data is pushed into this sink, it
|
|
||||||
-- will magically begin to appear in the queue. Boolean argument is used
|
|
||||||
-- to specify if queue should be closed when the sink is closed.
|
|
||||||
sinkTBQueue :: MonadIO m => TBQueue a -> Sink a m ()
|
|
||||||
-sinkTBQueue q = ConduitM src
|
|
||||||
- where src = sink
|
|
||||||
- sink = NeedInput push close
|
|
||||||
- push input = PipeM ((liftSTM $ writeTBQueue q input)
|
|
||||||
- >> (return $ NeedInput push close))
|
|
||||||
- close _ = return ()
|
|
||||||
+sinkTBQueue q = CL.mapM_ (liftSTM . writeTBQueue q)
|
|
||||||
|
|
||||||
-- | A convenience wrapper for creating a source and sink TBQueue of the given
|
|
||||||
-- size at once, without exposing the underlying queue.
|
|
||||||
@@ -109,14 +91,15 @@
|
|
||||||
-- source will read it and pass it down the conduit pipeline. When the
|
|
||||||
-- queue is closed, the source will close also.
|
|
||||||
sourceTMQueue :: MonadIO m => TMQueue a -> Source m a
|
|
||||||
-sourceTMQueue q = ConduitM src
|
|
||||||
- where src = PipeM pull
|
|
||||||
- pull = do mx <- liftSTM $ readTMQueue q
|
|
||||||
- case mx of
|
|
||||||
- Nothing -> return $ Done ()
|
|
||||||
- Just x -> return $ HaveOutput src close x
|
|
||||||
- close = do liftSTM $ closeTMQueue q
|
|
||||||
- return ()
|
|
||||||
+sourceTMQueue q =
|
|
||||||
+ loop
|
|
||||||
+ where
|
|
||||||
+ loop = do
|
|
||||||
+ mx <- liftSTM $ readTMQueue q
|
|
||||||
+ case mx of
|
|
||||||
+ Nothing -> return ()
|
|
||||||
+ Just x -> yieldOr x close >> loop
|
|
||||||
+ close = liftSTM $ closeTMQueue q
|
|
||||||
|
|
||||||
-- | A simple wrapper around a "TMQueue". As data is pushed into this sink, it
|
|
||||||
-- will magically begin to appear in the queue.
|
|
||||||
@@ -124,26 +107,23 @@
|
|
||||||
=> TMQueue a
|
|
||||||
-> Bool -- ^ Should the queue be closed when the sink is closed?
|
|
||||||
-> Sink a m ()
|
|
||||||
-sinkTMQueue q shouldClose = ConduitM src
|
|
||||||
- where src = sink
|
|
||||||
- sink = NeedInput push close
|
|
||||||
- push input = PipeM ((liftSTM $ writeTMQueue q input)
|
|
||||||
- >> (return $ NeedInput push close))
|
|
||||||
- close _ = do when shouldClose (liftSTM $ closeTMQueue q)
|
|
||||||
- return ()
|
|
||||||
+sinkTMQueue q shouldClose = do
|
|
||||||
+ CL.mapM_ (liftSTM . writeTMQueue q)
|
|
||||||
+ when shouldClose (liftSTM $ closeTMQueue q)
|
|
||||||
|
|
||||||
-- | A simple wrapper around a "TBMQueue". As data is pushed into the queue, the
|
|
||||||
-- source will read it and pass it down the conduit pipeline. When the
|
|
||||||
-- queue is closed, the source will close also.
|
|
||||||
sourceTBMQueue :: MonadIO m => TBMQueue a -> Source m a
|
|
||||||
-sourceTBMQueue q = ConduitM src
|
|
||||||
- where src = PipeM pull
|
|
||||||
- pull = do mx <- liftSTM $ readTBMQueue q
|
|
||||||
- case mx of
|
|
||||||
- Nothing -> return $ Done ()
|
|
||||||
- Just x -> return $ HaveOutput src close x
|
|
||||||
- close = do liftSTM $ closeTBMQueue q
|
|
||||||
- return ()
|
|
||||||
+sourceTBMQueue q =
|
|
||||||
+ loop
|
|
||||||
+ where
|
|
||||||
+ loop = do
|
|
||||||
+ mx <- liftSTM $ readTBMQueue q
|
|
||||||
+ case mx of
|
|
||||||
+ Nothing -> return ()
|
|
||||||
+ Just x -> yieldOr x close >> loop
|
|
||||||
+ close = liftSTM $ closeTBMQueue q
|
|
||||||
|
|
||||||
-- | A simple wrapper around a "TBMQueue". As data is pushed into this sink, it
|
|
||||||
-- will magically begin to appear in the queue.
|
|
||||||
@@ -151,13 +131,9 @@
|
|
||||||
=> TBMQueue a
|
|
||||||
-> Bool -- ^ Should the queue be closed when the sink is closed?
|
|
||||||
-> Sink a m ()
|
|
||||||
-sinkTBMQueue q shouldClose = ConduitM src
|
|
||||||
- where src = sink
|
|
||||||
- sink = NeedInput push close
|
|
||||||
- push input = PipeM ((liftSTM $ writeTBMQueue q input)
|
|
||||||
- >> (return $ NeedInput push close))
|
|
||||||
- close _ = do when shouldClose (liftSTM $ closeTBMQueue q)
|
|
||||||
- return ()
|
|
||||||
+sinkTBMQueue q shouldClose = do
|
|
||||||
+ CL.mapM_ (liftSTM . writeTBMQueue q)
|
|
||||||
+ when shouldClose (liftSTM $ closeTBMQueue q)
|
|
||||||
|
|
||||||
|
|
||||||
liftSTM :: forall (m :: * -> *) a. MonadIO m => STM a -> m a
|
|
||||||
diff -ruN orig/stm-conduit.cabal new/stm-conduit.cabal
|
|
||||||
--- orig/stm-conduit.cabal 2014-08-27 18:36:44.145176333 +0300
|
|
||||||
+++ new/stm-conduit.cabal 2014-08-27 18:36:43.000000000 +0300
|
|
||||||
@@ -29,7 +29,7 @@
|
|
||||||
, stm-chans >= 2.0 && < 3.1
|
|
||||||
, cereal >= 0.4.0.1
|
|
||||||
, cereal-conduit >= 0.7.2
|
|
||||||
- , conduit >= 1.0 && < 1.2
|
|
||||||
+ , conduit >= 1.0 && < 1.3
|
|
||||||
, conduit-extra >= 1.0 && < 1.2
|
|
||||||
, directory >= 1.1
|
|
||||||
, resourcet >= 0.3 && < 1.2
|
|
||||||
@ -1,12 +0,0 @@
|
|||||||
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
|
|
||||||
@ -1,39 +0,0 @@
|
|||||||
diff -ru orig/System/IO/Temp.hs new/System/IO/Temp.hs
|
|
||||||
--- orig/System/IO/Temp.hs 2014-05-11 15:04:23.887266736 +0300
|
|
||||||
+++ new/System/IO/Temp.hs 2014-05-11 15:04:23.000000000 +0300
|
|
||||||
@@ -24,7 +24,7 @@
|
|
||||||
--
|
|
||||||
-- Behaves exactly the same as 'withTempFile', except that the parent temporary directory
|
|
||||||
-- will be that returned by 'getTemporaryDirectory'.
|
|
||||||
-withSystemTempFile :: (MonadIO m, MonadCatch m) =>
|
|
||||||
+withSystemTempFile :: (MonadIO m, MonadMask m) =>
|
|
||||||
String -- ^ File name template. See 'openTempFile'.
|
|
||||||
-> (FilePath -> Handle -> m a) -- ^ Callback that can use the file
|
|
||||||
-> m a
|
|
||||||
@@ -34,7 +34,7 @@
|
|
||||||
--
|
|
||||||
-- Behaves exactly the same as 'withTempDirectory', except that the parent temporary directory
|
|
||||||
-- will be that returned by 'getTemporaryDirectory'.
|
|
||||||
-withSystemTempDirectory :: (MonadIO m, MonadCatch m) =>
|
|
||||||
+withSystemTempDirectory :: (MonadIO m, MonadMask m) =>
|
|
||||||
String -- ^ Directory name template. See 'openTempFile'.
|
|
||||||
-> (FilePath -> m a) -- ^ Callback that can use the directory
|
|
||||||
-> m a
|
|
||||||
@@ -50,7 +50,7 @@
|
|
||||||
--
|
|
||||||
-- The @tmpFlie@ will be file in the given directory, e.g.
|
|
||||||
-- @src/sdist.342@.
|
|
||||||
-withTempFile :: (MonadIO m, MonadCatch m) =>
|
|
||||||
+withTempFile :: (MonadIO m, MonadMask m) =>
|
|
||||||
FilePath -- ^ Temp dir to create the file in
|
|
||||||
-> String -- ^ File name template. See 'openTempFile'.
|
|
||||||
-> (FilePath -> Handle -> m a) -- ^ Callback that can use the file
|
|
||||||
@@ -70,7 +70,7 @@
|
|
||||||
--
|
|
||||||
-- The @tmpDir@ will be a new subdirectory of the given directory, e.g.
|
|
||||||
-- @src/sdist.342@.
|
|
||||||
-withTempDirectory :: (MonadCatch m, MonadIO m) =>
|
|
||||||
+withTempDirectory :: (MonadMask m, MonadIO m) =>
|
|
||||||
FilePath -- ^ Temp directory to create the directory in
|
|
||||||
-> String -- ^ Directory name template. See 'openTempFile'.
|
|
||||||
-> (FilePath -> m a) -- ^ Callback that can use the directory
|
|
||||||
@ -1,20 +0,0 @@
|
|||||||
diff -ruN orig/Test/Run.hs new/Test/Run.hs
|
|
||||||
--- orig/Test/Run.hs 2014-08-19 09:57:25.537902164 +0300
|
|
||||||
+++ new/Test/Run.hs 2014-08-19 09:57:25.000000000 +0300
|
|
||||||
@@ -27,6 +27,7 @@
|
|
||||||
import Language.Haskell.TH.Desugar.Expand
|
|
||||||
import Language.Haskell.TH.Desugar.Sweeten
|
|
||||||
import Language.Haskell.TH
|
|
||||||
+import Language.Haskell.TH.Syntax (qRunIO)
|
|
||||||
|
|
||||||
import Control.Monad
|
|
||||||
|
|
||||||
@@ -121,7 +122,7 @@
|
|
||||||
case (resK, lhs) of
|
|
||||||
(DStarK, [DVarT _]) -> [| True |]
|
|
||||||
_ -> do
|
|
||||||
- runIO $ do
|
|
||||||
+ qRunIO $ do
|
|
||||||
putStrLn "Failed bug8884 test:"
|
|
||||||
putStrLn $ show dinfo
|
|
||||||
[| False |] )
|
|
||||||
@ -1,47 +0,0 @@
|
|||||||
diff -ru orig/src/Graphics/UI/Threepenny/Internal/Driver.hs new/src/Graphics/UI/Threepenny/Internal/Driver.hs
|
|
||||||
--- orig/src/Graphics/UI/Threepenny/Internal/Driver.hs 2014-03-13 10:29:00.049732639 +0200
|
|
||||||
+++ new/src/Graphics/UI/Threepenny/Internal/Driver.hs 2014-03-13 10:28:59.000000000 +0200
|
|
||||||
@@ -248,7 +248,7 @@
|
|
||||||
signal Session{..} = do
|
|
||||||
input <- getParam "signal"
|
|
||||||
let err = error $ "Unable to parse " ++ show input
|
|
||||||
- case JSON.decode . LBS.fromStrict =<< input of
|
|
||||||
+ case JSON.decode . LBS.fromChunks . return =<< input of
|
|
||||||
Just signal -> liftIO $ writeChan sSignals signal
|
|
||||||
Nothing -> err
|
|
||||||
|
|
||||||
diff -ru orig/src/Graphics/UI/Threepenny/Internal/Types.hs new/src/Graphics/UI/Threepenny/Internal/Types.hs
|
|
||||||
--- orig/src/Graphics/UI/Threepenny/Internal/Types.hs 2014-03-13 10:29:00.049732639 +0200
|
|
||||||
+++ new/src/Graphics/UI/Threepenny/Internal/Types.hs 2014-03-13 10:28:59.000000000 +0200
|
|
||||||
@@ -17,6 +17,7 @@
|
|
||||||
import Data.Map (Map)
|
|
||||||
import Data.String (fromString)
|
|
||||||
import Data.Time
|
|
||||||
+import Data.Text.Encoding (encodeUtf8, decodeUtf8)
|
|
||||||
|
|
||||||
import Network.URI
|
|
||||||
import Data.Data
|
|
||||||
@@ -62,9 +63,9 @@
|
|
||||||
|
|
||||||
-- Marshalling ElementId
|
|
||||||
instance ToJSON ElementId where
|
|
||||||
- toJSON (ElementId o) = toJSON o
|
|
||||||
+ toJSON (ElementId o) = toJSON $ decodeUtf8 o
|
|
||||||
instance FromJSON ElementId where
|
|
||||||
- parseJSON (Object v) = ElementId <$> v .: "Element"
|
|
||||||
+ parseJSON (Object v) = (ElementId . encodeUtf8) <$> v .: "Element"
|
|
||||||
parseJSON _ = mzero
|
|
||||||
|
|
||||||
|
|
||||||
diff -ru orig/threepenny-gui.cabal new/threepenny-gui.cabal
|
|
||||||
--- orig/threepenny-gui.cabal 2014-03-13 10:29:00.057732639 +0200
|
|
||||||
+++ new/threepenny-gui.cabal 2014-03-13 10:28:59.000000000 +0200
|
|
||||||
@@ -92,7 +92,7 @@
|
|
||||||
cpp-options: -DREBUG
|
|
||||||
ghc-options: -O2
|
|
||||||
build-depends: base >= 4 && < 5
|
|
||||||
- ,aeson == 0.6.*
|
|
||||||
+ ,aeson >= 0.6
|
|
||||||
,attoparsec-enumerator == 0.3.*
|
|
||||||
,bytestring >= 0.9.2 && < 0.11
|
|
||||||
,containers >= 0.4.2 && < 0.6
|
|
||||||
@ -1,50 +0,0 @@
|
|||||||
Only in orig: 0.2
|
|
||||||
diff -ru orig/transformers-compat.cabal new/transformers-compat.cabal
|
|
||||||
--- orig/transformers-compat.cabal 2014-06-20 06:30:48.534077053 +0300
|
|
||||||
+++ new/transformers-compat.cabal 2014-06-20 06:30:48.000000000 +0300
|
|
||||||
@@ -38,17 +38,6 @@
|
|
||||||
type: git
|
|
||||||
location: git://github.com/ekmett/transformers-compat.git
|
|
||||||
|
|
||||||
-flag two
|
|
||||||
- default: False
|
|
||||||
- description: Use transformers 0.2. This must be selected manually and should
|
|
||||||
- probably only be used on older GHCs around 7.0.x.
|
|
||||||
- manual: True
|
|
||||||
-
|
|
||||||
-flag three
|
|
||||||
- default: False
|
|
||||||
- manual: True
|
|
||||||
- description: Use transformers 0.3. This should toggle on/off automatically.
|
|
||||||
-
|
|
||||||
library
|
|
||||||
build-depends:
|
|
||||||
base >= 4.3 && < 5
|
|
||||||
@@ -56,24 +45,10 @@
|
|
||||||
other-modules:
|
|
||||||
Paths_transformers_compat
|
|
||||||
|
|
||||||
- if flag(three)
|
|
||||||
- hs-source-dirs: 0.3
|
|
||||||
- build-depends: transformers >= 0.3 && < 0.4
|
|
||||||
- else
|
|
||||||
- if flag(two)
|
|
||||||
- hs-source-dirs: 0.2 0.3
|
|
||||||
- build-depends: transformers >= 0.2 && < 0.3
|
|
||||||
- else
|
|
||||||
- build-depends: transformers >= 0.4.1 && < 0.5
|
|
||||||
-
|
|
||||||
- if flag(two)
|
|
||||||
- exposed-modules:
|
|
||||||
- Control.Applicative.Backwards
|
|
||||||
- Control.Applicative.Lift
|
|
||||||
- Data.Functor.Reverse
|
|
||||||
+ hs-source-dirs: 0.3
|
|
||||||
+ build-depends: transformers >= 0.3 && < 0.4
|
|
||||||
|
|
||||||
- if flag(two) || flag(three)
|
|
||||||
- exposed-modules:
|
|
||||||
+ exposed-modules:
|
|
||||||
Control.Monad.Trans.Except
|
|
||||||
Control.Monad.Signatures
|
|
||||||
Data.Functor.Classes
|
|
||||||
@ -1,100 +0,0 @@
|
|||||||
diff -ru orig/Data/Unique/Id.hs new/Data/Unique/Id.hs
|
|
||||||
--- orig/Data/Unique/Id.hs 2014-04-14 09:11:35.637516354 +0300
|
|
||||||
+++ new/Data/Unique/Id.hs 2014-04-14 09:11:35.000000000 +0300
|
|
||||||
@@ -1,3 +1,4 @@
|
|
||||||
+{-# LANGUAGE CPP #-}
|
|
||||||
{-# LANGUAGE MagicHash #-}
|
|
||||||
|
|
||||||
-- | This module provides splittable supplies for unique identifiers.
|
|
||||||
@@ -13,6 +14,86 @@
|
|
||||||
|
|
||||||
) where
|
|
||||||
|
|
||||||
+#if MIN_VERSION_base(4,7,0)
|
|
||||||
+
|
|
||||||
+import GHC.Exts
|
|
||||||
+import GHC.IO ( unsafeDupableInterleaveIO )
|
|
||||||
+
|
|
||||||
+import Data.IORef
|
|
||||||
+import System.IO.Unsafe ( unsafePerformIO )
|
|
||||||
+
|
|
||||||
+-- | Unique identifiers are of type 'Id' and can be hashed to an 'Int'
|
|
||||||
+-- usning the function 'hashedId'.
|
|
||||||
+newtype Id = Id { hashedId :: Int }
|
|
||||||
+
|
|
||||||
+-- | Supplies for unique identifiers are of type 'IdSupply' and can be
|
|
||||||
+-- split into two new supplies or yield a unique identifier.
|
|
||||||
+data IdSupply = IdSupply Int# IdSupply IdSupply
|
|
||||||
+
|
|
||||||
+-- | Generates a new supply of unique identifiers. The given character
|
|
||||||
+-- is prepended to generated numbers.
|
|
||||||
+initIdSupply :: Char -> IO IdSupply
|
|
||||||
+initIdSupply (C# c) =
|
|
||||||
+ case uncheckedIShiftL# (ord# c) (unboxedInt 24) of
|
|
||||||
+ mask ->
|
|
||||||
+ let mkSupply =
|
|
||||||
+ unsafeDupableInterleaveIO (
|
|
||||||
+ nextInt >>= \ (I# u) ->
|
|
||||||
+ mkSupply >>= \ l ->
|
|
||||||
+ mkSupply >>= \ r ->
|
|
||||||
+ return (IdSupply (word2Int# (or# (int2Word# mask) (int2Word# u))) l r))
|
|
||||||
+ in mkSupply
|
|
||||||
+
|
|
||||||
+-- | Splits a supply of unique identifiers to yield two of them.
|
|
||||||
+splitIdSupply :: IdSupply -> (IdSupply,IdSupply)
|
|
||||||
+splitIdSupply (IdSupply _ l r) = (l,r)
|
|
||||||
+
|
|
||||||
+-- | Splits a supply of unique identifiers to yield an infinite list of them.
|
|
||||||
+splitIdSupplyL :: IdSupply -> [IdSupply]
|
|
||||||
+splitIdSupplyL ids = ids1 : splitIdSupplyL ids2
|
|
||||||
+ where
|
|
||||||
+ (ids1, ids2) = splitIdSupply ids
|
|
||||||
+
|
|
||||||
+-- | Yields the unique identifier from a supply.
|
|
||||||
+idFromSupply :: IdSupply -> Id
|
|
||||||
+idFromSupply (IdSupply n _ _) = Id (I# n)
|
|
||||||
+
|
|
||||||
+instance Eq Id where Id (I# x) == Id (I# y) = I# (x ==# y) /= 0
|
|
||||||
+
|
|
||||||
+instance Ord Id
|
|
||||||
+ where
|
|
||||||
+ Id (I# x) < Id (I# y) = I# (x <# y) /= 0
|
|
||||||
+ Id (I# x) <= Id (I# y) = I# (x <=# y) /= 0
|
|
||||||
+
|
|
||||||
+ compare (Id (I# x)) (Id (I# y)) =
|
|
||||||
+ if I# (x ==# y) /= 0 then EQ else if I# (x <# y) /= 0 then LT else GT
|
|
||||||
+
|
|
||||||
+instance Show Id
|
|
||||||
+ where
|
|
||||||
+ showsPrec _ i s = case unpackId i of (c,n) -> c:show n++s
|
|
||||||
+
|
|
||||||
+
|
|
||||||
+
|
|
||||||
+
|
|
||||||
+unboxedInt :: Int -> Int#
|
|
||||||
+unboxedInt (I# x) = x
|
|
||||||
+
|
|
||||||
+global :: IORef Int
|
|
||||||
+global = unsafePerformIO (newIORef 0)
|
|
||||||
+
|
|
||||||
+nextInt :: IO Int
|
|
||||||
+nextInt = do
|
|
||||||
+ n <- readIORef global
|
|
||||||
+ writeIORef global (succ n)
|
|
||||||
+ return n
|
|
||||||
+
|
|
||||||
+unpackId :: Id -> (Char,Int)
|
|
||||||
+unpackId (Id (I# i)) =
|
|
||||||
+ let tag = C# (chr# (uncheckedIShiftRL# i (unboxedInt 24)))
|
|
||||||
+ num = I# (word2Int# (and# (int2Word# i)
|
|
||||||
+ (int2Word# (unboxedInt 16777215))))
|
|
||||||
+ in (tag, num)
|
|
||||||
+#else
|
|
||||||
import GHC.Exts
|
|
||||||
import GHC.IOBase ( unsafeDupableInterleaveIO )
|
|
||||||
|
|
||||||
@@ -90,3 +171,4 @@
|
|
||||||
num = I# (word2Int# (and# (int2Word# i)
|
|
||||||
(int2Word# (unboxedInt 16777215))))
|
|
||||||
in (tag, num)
|
|
||||||
+#endif
|
|
||||||
@ -1,21 +0,0 @@
|
|||||||
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,
|
|
||||||
@ -1,77 +0,0 @@
|
|||||||
diff -ru orig/demo/clientside.hs new/demo/clientside.hs
|
|
||||||
--- orig/demo/clientside.hs 2014-03-30 12:27:40.941431437 +0300
|
|
||||||
+++ new/demo/clientside.hs 2014-03-30 12:27:40.000000000 +0300
|
|
||||||
@@ -27,7 +27,7 @@
|
|
||||||
|
|
||||||
|
|
||||||
instance Yesod Test where
|
|
||||||
- approot = ApprootStatic "http://dev.whonodes.org:3000"
|
|
||||||
+ approot = FIXME -- FIXME: Put your approot here
|
|
||||||
|
|
||||||
instance RenderMessage Test FormMessage where
|
|
||||||
renderMessage _ _ = englishFormMessage
|
|
||||||
diff -ru orig/src/Yesod/Auth/Facebook/ClientSide.hs new/src/Yesod/Auth/Facebook/ClientSide.hs
|
|
||||||
--- orig/src/Yesod/Auth/Facebook/ClientSide.hs 2014-03-30 12:27:40.941431437 +0300
|
|
||||||
+++ new/src/Yesod/Auth/Facebook/ClientSide.hs 2014-03-30 12:27:40.000000000 +0300
|
|
||||||
@@ -364,7 +364,7 @@
|
|
||||||
AuthPlugin "fbcs" dispatch login
|
|
||||||
where
|
|
||||||
dispatch :: YesodAuthFbClientSide site =>
|
|
||||||
- Text -> [Text] -> HandlerT Auth (HandlerT site IO) ()
|
|
||||||
+ Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent
|
|
||||||
-- Login route used when successfully logging in. Called via
|
|
||||||
-- AJAX by JavaScript code on 'facebookJSSDK'.
|
|
||||||
dispatch "GET" ["login"] = do
|
|
||||||
@@ -372,7 +372,7 @@
|
|
||||||
when (redirectToReferer y) (lift setUltDestReferer)
|
|
||||||
etoken <- lift getUserAccessTokenFromFbCookie
|
|
||||||
case etoken of
|
|
||||||
- Right token -> lift $ setCreds True (createCreds token)
|
|
||||||
+ Right token -> lift $ setCredsRedirect (createCreds token)
|
|
||||||
Left msg -> fail msg
|
|
||||||
|
|
||||||
-- Login routes used to forcefully require the user to login.
|
|
||||||
@@ -406,7 +406,7 @@
|
|
||||||
token <- lift $
|
|
||||||
YF.runYesodFbT $
|
|
||||||
FB.getUserAccessTokenStep2 proceedUrl query'
|
|
||||||
- lift $ setCreds True (createCreds token)
|
|
||||||
+ lift $ setCredsRedirect (createCreds token)
|
|
||||||
|
|
||||||
-- Everything else gives 404
|
|
||||||
dispatch _ _ = notFound
|
|
||||||
diff -ru orig/src/Yesod/Auth/Facebook/ServerSide.hs new/src/Yesod/Auth/Facebook/ServerSide.hs
|
|
||||||
--- orig/src/Yesod/Auth/Facebook/ServerSide.hs 2014-03-30 12:27:40.941431437 +0300
|
|
||||||
+++ new/src/Yesod/Auth/Facebook/ServerSide.hs 2014-03-30 12:27:40.000000000 +0300
|
|
||||||
@@ -56,7 +56,7 @@
|
|
||||||
proceedR = PluginR "fb" ["proceed"]
|
|
||||||
|
|
||||||
dispatch :: (YesodAuth site, YF.YesodFacebook site) =>
|
|
||||||
- Text -> [Text] -> HandlerT Auth (HandlerT site IO) ()
|
|
||||||
+ Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent
|
|
||||||
-- Redirect the user to Facebook.
|
|
||||||
dispatch "GET" ["login"] = do
|
|
||||||
ur <- getUrlRender
|
|
||||||
@@ -73,7 +73,7 @@
|
|
||||||
lift $ do
|
|
||||||
token <- YF.runYesodFbT $ FB.getUserAccessTokenStep2 proceedUrl query'
|
|
||||||
setUserAccessToken token
|
|
||||||
- setCreds True (createCreds token)
|
|
||||||
+ setCredsRedirect (createCreds token)
|
|
||||||
-- Logout the user from our site and from Facebook.
|
|
||||||
dispatch "GET" ["logout"] = do
|
|
||||||
y <- lift getYesod
|
|
||||||
diff -ru orig/yesod-auth-fb.cabal new/yesod-auth-fb.cabal
|
|
||||||
--- orig/yesod-auth-fb.cabal 2014-03-30 12:27:40.945431436 +0300
|
|
||||||
+++ new/yesod-auth-fb.cabal 2014-03-30 12:27:40.000000000 +0300
|
|
||||||
@@ -43,8 +43,9 @@
|
|
||||||
Build-depends: base >= 4.3 && < 5
|
|
||||||
, lifted-base >= 0.1 && < 0.3
|
|
||||||
, yesod-core == 1.2.*
|
|
||||||
- , yesod-auth == 1.2.*
|
|
||||||
+ , yesod-auth == 1.3.*
|
|
||||||
, hamlet
|
|
||||||
+ , shakespeare
|
|
||||||
, shakespeare-js >= 1.0.2
|
|
||||||
, wai
|
|
||||||
, http-conduit >= 1.9
|
|
||||||
@ -1,26 +0,0 @@
|
|||||||
diff -ru orig/Yesod/Auth/OAuth.hs new/Yesod/Auth/OAuth.hs
|
|
||||||
--- orig/Yesod/Auth/OAuth.hs 2014-03-30 12:34:43.941422434 +0300
|
|
||||||
+++ new/Yesod/Auth/OAuth.hs 2014-03-30 12:34:43.000000000 +0300
|
|
||||||
@@ -72,7 +72,7 @@
|
|
||||||
master <- getYesod
|
|
||||||
accTok <- getAccessToken oauth reqTok (authHttpManager master)
|
|
||||||
creds <- liftIO $ mkCreds accTok
|
|
||||||
- setCreds True creds
|
|
||||||
+ setCredsRedirect creds
|
|
||||||
dispatch _ _ = notFound
|
|
||||||
login tm = do
|
|
||||||
render <- getUrlRender
|
|
||||||
diff -ru orig/yesod-auth-oauth.cabal new/yesod-auth-oauth.cabal
|
|
||||||
--- orig/yesod-auth-oauth.cabal 2014-03-30 12:34:43.941422434 +0300
|
|
||||||
+++ new/yesod-auth-oauth.cabal 2014-03-30 12:34:43.000000000 +0300
|
|
||||||
@@ -23,8 +23,8 @@
|
|
||||||
build-depends: authenticate-oauth >= 1.4 && < 1.5
|
|
||||||
, bytestring >= 0.9.1.4
|
|
||||||
, yesod-core >= 1.2 && < 1.3
|
|
||||||
- , yesod-auth >= 1.2 && < 1.3
|
|
||||||
- , text >= 0.7 && < 0.12
|
|
||||||
+ , yesod-auth >= 1.3 && < 1.4
|
|
||||||
+ , text >= 0.7 && < 1.2
|
|
||||||
, yesod-form >= 1.3 && < 1.4
|
|
||||||
, transformers >= 0.2.2 && < 0.4
|
|
||||||
, lifted-base >= 0.2 && < 0.3
|
|
||||||
Loading…
Reference in New Issue
Block a user