Hello community,
here is the log from the commit of package ghc-hackage-security for
openSUSE:Factory checked in at 2016-07-21 08:12:16
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/ghc-hackage-security (Old)
and /work/SRC/openSUSE:Factory/.ghc-hackage-security.new (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-hackage-security"
Changes:
--------
---
/work/SRC/openSUSE:Factory/ghc-hackage-security/ghc-hackage-security.changes
2016-06-07 23:47:25.000000000 +0200
+++
/work/SRC/openSUSE:Factory/.ghc-hackage-security.new/ghc-hackage-security.changes
2016-07-21 08:12:21.000000000 +0200
@@ -1,0 +2,5 @@
+Sun Jul 10 17:19:31 UTC 2016 - [email protected]
+
+- Update to version 0.5.2.1 revision 0 with cabal2obs.
+
+-------------------------------------------------------------------
Old:
----
hackage-security-0.5.1.0.tar.gz
New:
----
hackage-security-0.5.2.1.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ ghc-hackage-security.spec ++++++
--- /var/tmp/diff_new_pack.2adW7J/_old 2016-07-21 08:12:23.000000000 +0200
+++ /var/tmp/diff_new_pack.2adW7J/_new 2016-07-21 08:12:23.000000000 +0200
@@ -15,23 +15,18 @@
# Please submit bugfixes or comments via http://bugs.opensuse.org/
#
-%global pkg_name hackage-security
+%global pkg_name hackage-security
%bcond_with tests
-
Name: ghc-%{pkg_name}
-Version: 0.5.1.0
+Version: 0.5.2.1
Release: 0
Summary: Hackage security library
-Group: System/Libraries
-
License: BSD-3-Clause
+Group: System/Libraries
Url: https://hackage.haskell.org/package/%{pkg_name}
Source0:
https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{version}.tar.gz
-BuildRoot: %{_tmppath}/%{name}-%{version}-build
-
BuildRequires: ghc-Cabal-devel
-BuildRequires: ghc-rpm-macros
# Begin cabal-rpm deps:
BuildRequires: ghc-base16-bytestring-devel
BuildRequires: ghc-base64-bytestring-devel
@@ -46,11 +41,13 @@
BuildRequires: ghc-network-uri-devel
BuildRequires: ghc-parsec-devel
BuildRequires: ghc-pretty-devel
+BuildRequires: ghc-rpm-macros
BuildRequires: ghc-tar-devel
BuildRequires: ghc-template-haskell-devel
BuildRequires: ghc-time-devel
BuildRequires: ghc-transformers-devel
BuildRequires: ghc-zlib-devel
+BuildRoot: %{_tmppath}/%{name}-%{version}-build
%if %{with tests}
BuildRequires: ghc-HUnit-devel
BuildRequires: ghc-QuickCheck-devel
@@ -78,22 +75,18 @@
"Hackage.Security.Server" is the main entry point for servers (the typical
example being 'hackage-server').
-This is a beta release.
-
-
%package devel
Summary: Haskell %{pkg_name} library development files
Group: Development/Libraries/Other
+Requires: %{name} = %{version}-%{release}
Requires: ghc-compiler = %{ghc_version}
Requires(post): ghc-compiler = %{ghc_version}
Requires(postun): ghc-compiler = %{ghc_version}
-Requires: %{name} = %{version}-%{release}
%description devel
This package provides the Haskell %{pkg_name} library development
files.
-
%prep
%setup -q -n %{pkg_name}-%{version}
@@ -108,25 +101,22 @@
%check
%if %{with tests}
-%cabal test
+%{cabal} test
%endif
%post devel
%ghc_pkg_recache
-
%postun devel
%ghc_pkg_recache
-
%files -f %{name}.files
%defattr(-,root,root,-)
%doc LICENSE
-
%files devel -f %{name}-devel.files
%defattr(-,root,root,-)
-
+%doc ChangeLog.md
%changelog
++++++ hackage-security-0.5.1.0.tar.gz -> hackage-security-0.5.2.1.tar.gz ++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/hackage-security-0.5.1.0/ChangeLog.md
new/hackage-security-0.5.2.1/ChangeLog.md
--- old/hackage-security-0.5.1.0/ChangeLog.md 2016-04-23 05:48:47.000000000
+0200
+++ new/hackage-security-0.5.2.1/ChangeLog.md 2016-06-07 23:44:49.000000000
+0200
@@ -1,3 +1,20 @@
+0.5.2.1
+-------
+
+* Fix accidental breakage with GHC 8
+
+0.5.2.0
+-------
+
+* Change path handling to work on Windows (#162).
+* Add new MD5 hash type (#163). This is not for security (only SHA256 is
+ used for verification) but to provide as metadata to help with other
+ services like mirroring (e.g. HTTP & S3 use MD5 checksum headers).
+* Adjust reading of JSON maps to ignore unknown keys. This allows adding
+ e.g. new hash types in future without breaking existing clients.
+* Fix build warnings on GHC 8
+
+
0.5.1.0
-------
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/hackage-security-0.5.1.0/hackage-security.cabal
new/hackage-security-0.5.2.1/hackage-security.cabal
--- old/hackage-security-0.5.1.0/hackage-security.cabal 2016-04-23
05:48:47.000000000 +0200
+++ new/hackage-security-0.5.2.1/hackage-security.cabal 2016-06-07
23:44:49.000000000 +0200
@@ -1,5 +1,5 @@
name: hackage-security
-version: 0.5.1.0
+version: 0.5.2.1
synopsis: Hackage security library
description: The hackage security library provides both server and
client utilities for securing the Hackage package server
@@ -18,13 +18,11 @@
clients (the typical example being @cabal@), and
"Hackage.Security.Server" is the main entry point for
servers (the typical example being @hackage-server@).
- .
- This is a beta release.
license: BSD3
license-file: LICENSE
author: Edsko de Vries
maintainer: [email protected]
-copyright: Copyright 2015 Well-Typed LLP
+copyright: Copyright 2015-2016 Well-Typed LLP
category: Distribution
homepage: https://github.com/well-typed/hackage-security
bug-reports: https://github.com/well-typed/hackage-security/issues
@@ -214,9 +212,11 @@
test-suite TestSuite
type: exitcode-stdio-1.0
main-is: TestSuite.hs
- other-modules: TestSuite.InMemCache
+ other-modules: TestSuite.HttpMem
+ TestSuite.InMemCache
TestSuite.InMemRepo
TestSuite.InMemRepository
+ TestSuite.JSON
TestSuite.PrivateKeys
TestSuite.Util.StrictMVar
build-depends: base,
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/hackage-security-0.5.1.0/src/Hackage/Security/Client/Repository/Cache.hs
new/hackage-security-0.5.2.1/src/Hackage/Security/Client/Repository/Cache.hs
---
old/hackage-security-0.5.1.0/src/Hackage/Security/Client/Repository/Cache.hs
2016-04-23 05:48:47.000000000 +0200
+++
new/hackage-security-0.5.2.1/src/Hackage/Security/Client/Repository/Cache.hs
2016-06-07 23:44:49.000000000 +0200
@@ -62,7 +62,7 @@
-- update the uncompressed index incrementally (assuming the local files
-- have not been corrupted).
-- NOTE: This assumes we already updated the compressed file.
- unzipIndex :: typ ~ Binary => IO ()
+ unzipIndex :: IO ()
unzipIndex = do
createDirectoryIfMissing True (takeDirectory indexUn)
shouldTryIncremenal <- cachedIndexProbablyValid
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/hackage-security-0.5.1.0/src/Hackage/Security/Client/Repository/Remote.hs
new/hackage-security-0.5.2.1/src/Hackage/Security/Client/Repository/Remote.hs
---
old/hackage-security-0.5.1.0/src/Hackage/Security/Client/Repository/Remote.hs
2016-04-23 05:48:47.000000000 +0200
+++
new/hackage-security-0.5.2.1/src/Hackage/Security/Client/Repository/Remote.hs
2016-06-07 23:44:49.000000000 +0200
@@ -299,24 +299,25 @@
-- | Download method (downloading or updating)
data DownloadMethod :: * -> * -> * where
- -- | Download this file (we never attempt to update this type of file)
+ -- Download this file (we never attempt to update this type of file)
NeverUpdated :: {
neverUpdatedFormat :: HasFormat fs f
} -> DownloadMethod fs typ
- -- | Download this file (we cannot update this file right now)
+ -- Download this file (we cannot update this file right now)
CannotUpdate :: {
cannotUpdateFormat :: HasFormat fs f
, cannotUpdateReason :: UpdateFailure
} -> DownloadMethod fs Binary
- -- | Attempt an (incremental) update of this file
+ -- Attempt an (incremental) update of this file
Update :: {
updateFormat :: HasFormat fs f
, updateInfo :: Trusted FileInfo
, updateLocal :: Path Absolute
, updateTail :: Int54
} -> DownloadMethod fs Binary
+--TODO: ^^ older haddock doesn't support GADT doc comments :-(
pickDownloadMethod :: forall fs typ. RemoteConfig
-> AttemptNr
@@ -362,8 +363,7 @@
getFile cfg@RemoteConfig{..} attemptNr remoteFile method =
go method
where
- go :: Throws SomeRemoteError
- => DownloadMethod fs typ -> Verify (Some (HasFormat fs), RemoteTemp typ)
+ go :: DownloadMethod fs typ -> Verify (Some (HasFormat fs), RemoteTemp typ)
go NeverUpdated{..} = do
cfgLogger $ LogDownloading remoteFile
download neverUpdatedFormat
@@ -379,8 +379,7 @@
headers = httpRequestHeaders cfg attemptNr
-- Get any file from the server, without using incremental updates
- download :: Throws SomeRemoteError => HasFormat fs f
- -> Verify (Some (HasFormat fs), RemoteTemp typ)
+ download :: HasFormat fs f -> Verify (Some (HasFormat fs), RemoteTemp typ)
download format = do
(tempPath, h) <- openTempFile (Cache.cacheRoot cfgCache) (uriTemplate
uri)
liftIO $ do
@@ -598,15 +597,16 @@
wholeTemp :: Path Absolute
} -> RemoteTemp a
- -- | If we download only the delta, we record both the path to where the
+ -- If we download only the delta, we record both the path to where the
-- "old" file is stored and the path to the temp file containing the delta.
-- Then:
--
- -- * When we verify the file, we need both of these paths if we compute
+ -- When we verify the file, we need both of these paths if we compute
-- the hash from scratch, or only the path to the delta if we attempt
-- to compute the hash incrementally (TODO: incremental verification
-- not currently implemented).
- -- * When we copy a file over, we are additionally given a destination
+ --
+ -- When we copy a file over, we are additionally given a destination
-- path. In this case, we expect that destination path to be equal to
-- the path to the old file (and assert this to be the case).
DownloadedDelta :: {
@@ -614,6 +614,8 @@
, deltaExisting :: Path Absolute
, deltaSeek :: Int54 -- ^ How much of the existing file to keep
} -> RemoteTemp Binary
+--TODO: ^^ older haddock doesn't support GADT doc comments :-(
+-- and add the '*' bullet points back in
instance Pretty (RemoteTemp typ) where
pretty DownloadedWhole{..} = intercalate " " $ [
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/hackage-security-0.5.1.0/src/Hackage/Security/Client/Repository.hs
new/hackage-security-0.5.2.1/src/Hackage/Security/Client/Repository.hs
--- old/hackage-security-0.5.1.0/src/Hackage/Security/Client/Repository.hs
2016-04-23 05:48:47.000000000 +0200
+++ new/hackage-security-0.5.2.1/src/Hackage/Security/Client/Repository.hs
2016-06-07 23:44:49.000000000 +0200
@@ -403,17 +403,17 @@
-- | Is a particular remote file cached?
data IsCached :: * -> * where
- -- | This remote file should be cached, and we ask for it by name
+ -- This remote file should be cached, and we ask for it by name
CacheAs :: CachedFile -> IsCached Metadata
- -- | We don't cache this remote file
+ -- We don't cache this remote file
--
-- This doesn't mean a Repository should not feel free to cache the file
-- if desired, but it does mean the generic algorithms will never ask for
-- this file from the cache.
DontCache :: IsCached Binary
- -- | The index is somewhat special: it should be cached, but we never
+ -- The index is somewhat special: it should be cached, but we never
-- ask for it directly.
--
-- Instead, we will ask the Repository for files _from_ the index, which it
@@ -422,6 +422,7 @@
-- keep an index tarball index for quick access, others may scan the
tarball
-- linearly, etc.
CacheIndex :: IsCached Binary
+--TODO: ^^ older haddock doesn't support GADT doc comments :-(
deriving instance Eq (IsCached typ)
deriving instance Show (IsCached typ)
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/hackage-security-0.5.1.0/src/Hackage/Security/Client.hs
new/hackage-security-0.5.2.1/src/Hackage/Security/Client.hs
--- old/hackage-security-0.5.1.0/src/Hackage/Security/Client.hs 2016-04-23
05:48:47.000000000 +0200
+++ new/hackage-security-0.5.2.1/src/Hackage/Security/Client.hs 2016-06-07
23:44:49.000000000 +0200
@@ -110,8 +110,7 @@
-- root information and start over. However, in order to prevent DoS
attacks
-- we limit how often we go round this loop.
-- See als <https://github.com/theupdateframework/tuf/issues/287>.
- limitIterations :: (Throws VerificationError, Throws SomeRemoteError)
- => VerificationHistory -> IO HasUpdates
+ limitIterations :: VerificationHistory -> IO HasUpdates
limitIterations history | length history >= maxNumIterations =
throwChecked $ VerificationErrorLoop (reverse history)
limitIterations history = do
@@ -802,7 +801,9 @@
}
where
indexPath :: Tar.Entry -> IndexPath
- indexPath = rootPath . fromUnrootedFilePath . Tar.entryPath
+ indexPath = rootPath . fromUnrootedFilePath
+ . Tar.fromTarPathToPosixPath
+ . Tar.entryTarPath
indexFile :: IndexPath -> Maybe (Some IndexFile)
indexFile = indexFileFromPath repIndexLayout
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/hackage-security-0.5.1.0/src/Hackage/Security/Key.hs
new/hackage-security-0.5.2.1/src/Hackage/Security/Key.hs
--- old/hackage-security-0.5.1.0/src/Hackage/Security/Key.hs 2016-04-23
05:48:47.000000000 +0200
+++ new/hackage-security-0.5.2.1/src/Hackage/Security/Key.hs 2016-06-07
23:44:49.000000000 +0200
@@ -153,7 +153,7 @@
toObjectKey = return . keyIdString
instance Monad m => FromObjectKey m KeyId where
- fromObjectKey = return . KeyId
+ fromObjectKey = return . Just . KeyId
-- | Compute the key ID of a key
class HasKeyId key where
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/hackage-security-0.5.1.0/src/Hackage/Security/TUF/FileInfo.hs
new/hackage-security-0.5.2.1/src/Hackage/Security/TUF/FileInfo.hs
--- old/hackage-security-0.5.1.0/src/Hackage/Security/TUF/FileInfo.hs
2016-04-23 05:48:47.000000000 +0200
+++ new/hackage-security-0.5.2.1/src/Hackage/Security/TUF/FileInfo.hs
2016-06-07 23:44:49.000000000 +0200
@@ -29,6 +29,7 @@
-------------------------------------------------------------------------------}
data HashFn = HashFnSHA256
+ | HashFnMD5
deriving (Show, Eq, Ord)
-- | File information
@@ -87,10 +88,12 @@
instance Monad m => ToObjectKey m HashFn where
toObjectKey HashFnSHA256 = return "sha256"
+ toObjectKey HashFnMD5 = return "md5"
instance ReportSchemaErrors m => FromObjectKey m HashFn where
- fromObjectKey "sha256" = return HashFnSHA256
- fromObjectKey str = expected "valid hash function" (Just str)
+ fromObjectKey "sha256" = return (Just HashFnSHA256)
+ fromObjectKey "md5" = return (Just HashFnMD5)
+ fromObjectKey _ = return Nothing
instance Monad m => ToJSON m FileInfo where
toJSON FileInfo{..} = mkObject [
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/hackage-security-0.5.1.0/src/Hackage/Security/TUF/FileMap.hs
new/hackage-security-0.5.2.1/src/Hackage/Security/TUF/FileMap.hs
--- old/hackage-security-0.5.1.0/src/Hackage/Security/TUF/FileMap.hs
2016-04-23 05:48:47.000000000 +0200
+++ new/hackage-security-0.5.2.1/src/Hackage/Security/TUF/FileMap.hs
2016-06-07 23:44:49.000000000 +0200
@@ -127,8 +127,7 @@
instance ReportSchemaErrors m => FromObjectKey m TargetPath where
fromObjectKey ('<':'r':'e':'p':'o':'>':'/':path) =
- return . TargetPathRepo . rootPath . fromUnrootedFilePath $ path
+ return . Just . TargetPathRepo . rootPath . fromUnrootedFilePath $ path
fromObjectKey ('<':'i':'n':'d':'e':'x':'>':'/':path) =
- return . TargetPathIndex . rootPath . fromUnrootedFilePath $ path
- fromObjectKey str =
- expected "target path" (Just str)
+ return . Just . TargetPathIndex . rootPath . fromUnrootedFilePath $ path
+ fromObjectKey _str = return Nothing
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/hackage-security-0.5.1.0/src/Hackage/Security/TUF/Layout/Index.hs
new/hackage-security-0.5.2.1/src/Hackage/Security/TUF/Layout/Index.hs
--- old/hackage-security-0.5.1.0/src/Hackage/Security/TUF/Layout/Index.hs
2016-04-23 05:48:47.000000000 +0200
+++ new/hackage-security-0.5.2.1/src/Hackage/Security/TUF/Layout/Index.hs
2016-06-07 23:44:49.000000000 +0200
@@ -9,8 +9,6 @@
, indexLayoutPkgPrefs
) where
-import qualified System.FilePath as FP
-
import Distribution.Package
import Distribution.Text
@@ -45,14 +43,15 @@
-- the global preferred-versions file. But supporting legacy Hackage will
-- probably require more work anyway..
data IndexFile :: * -> * where
- -- | Package-specific metadata (@targets.json@)
+ -- Package-specific metadata (@targets.json@)
IndexPkgMetadata :: PackageIdentifier -> IndexFile (Signed Targets)
- -- | Cabal file for a package
+ -- Cabal file for a package
IndexPkgCabal :: PackageIdentifier -> IndexFile ()
- -- | Preferred versions a package
+ -- Preferred versions a package
IndexPkgPrefs :: PackageName -> IndexFile ()
+--TODO: ^^ older haddock doesn't support GADT doc comments :-(
deriving instance Show (IndexFile dec)
@@ -68,7 +67,7 @@
hackageIndexLayout :: IndexLayout
hackageIndexLayout = IndexLayout {
indexFileToPath = toPath
- , indexFileFromPath = fromPath . toUnrootedFilePath . unrootPath
+ , indexFileFromPath = fromPath
}
where
toPath :: IndexFile dec -> IndexPath
@@ -90,16 +89,16 @@
fromFragments :: [String] -> IndexPath
fromFragments = rootPath . joinFragments
- fromPath :: FilePath -> Maybe (Some IndexFile)
- fromPath fp = case FP.splitPath fp of
- [pkg, version, file] -> do
- pkgId <- simpleParse (init pkg ++ "-" ++ init version)
- case FP.takeExtension file of
+ fromPath :: IndexPath -> Maybe (Some IndexFile)
+ fromPath fp = case splitFragments (unrootPath fp) of
+ [pkg, version, _file] -> do
+ pkgId <- simpleParse (pkg ++ "-" ++ version)
+ case takeExtension fp of
".cabal" -> return $ Some $ IndexPkgCabal pkgId
".json" -> return $ Some $ IndexPkgMetadata pkgId
_otherwise -> Nothing
[pkg, "preferred-versions"] ->
- Some . IndexPkgPrefs <$> simpleParse (init pkg)
+ Some . IndexPkgPrefs <$> simpleParse pkg
_otherwise -> Nothing
{-------------------------------------------------------------------------------
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/hackage-security-0.5.1.0/src/Hackage/Security/TUF/Paths.hs
new/hackage-security-0.5.2.1/src/Hackage/Security/TUF/Paths.hs
--- old/hackage-security-0.5.1.0/src/Hackage/Security/TUF/Paths.hs
2016-04-23 05:48:47.000000000 +0200
+++ new/hackage-security-0.5.2.1/src/Hackage/Security/TUF/Paths.hs
2016-06-07 23:44:49.000000000 +0200
@@ -37,7 +37,7 @@
instance Pretty (Path RepoRoot) where
pretty (Path fp) = "<repo>/" ++ fp
-anchorRepoPathLocally :: FsRoot root => Path root -> RepoPath -> Path root
+anchorRepoPathLocally :: Path root -> RepoPath -> Path root
anchorRepoPathLocally localRoot repoPath = localRoot </> unrootPath repoPath
anchorRepoPathRemotely :: Path Web -> RepoPath -> Path Web
@@ -68,5 +68,5 @@
pretty (Path fp) = "<cache>/" ++ fp
-- | Anchor a cache path to the location of the cache
-anchorCachePath :: FsRoot root => Path root -> CachePath -> Path root
+anchorCachePath :: Path root -> CachePath -> Path root
anchorCachePath cacheRoot cachePath = cacheRoot </> unrootPath cachePath
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/hackage-security-0.5.1.0/src/Hackage/Security/TUF/Patterns.hs
new/hackage-security-0.5.2.1/src/Hackage/Security/TUF/Patterns.hs
--- old/hackage-security-0.5.1.0/src/Hackage/Security/TUF/Patterns.hs
2016-04-23 05:48:47.000000000 +0200
+++ new/hackage-security-0.5.2.1/src/Hackage/Security/TUF/Patterns.hs
2016-06-07 23:44:49.000000000 +0200
@@ -27,7 +27,7 @@
import Control.Monad.Except
import Language.Haskell.TH (Q, Exp)
-import System.FilePath
+import System.FilePath.Posix
import qualified Language.Haskell.TH.Syntax as TH
import Hackage.Security.JSON
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/hackage-security-0.5.1.0/src/Hackage/Security/Util/Checked.hs
new/hackage-security-0.5.2.1/src/Hackage/Security/Util/Checked.hs
--- old/hackage-security-0.5.1.0/src/Hackage/Security/Util/Checked.hs
2016-04-23 05:48:47.000000000 +0200
+++ new/hackage-security-0.5.2.1/src/Hackage/Security/Util/Checked.hs
2016-06-07 23:44:49.000000000 +0200
@@ -1,5 +1,8 @@
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-unused-binds #-}
+#if __GLASGOW_HASKELL__ >= 800
+{-# OPTIONS_GHC -Wno-redundant-constraints #-}
+#endif
#if __GLASGOW_HASKELL__ >= 708
{-# LANGUAGE RoleAnnotations #-}
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/hackage-security-0.5.1.0/src/Hackage/Security/Util/JSON.hs
new/hackage-security-0.5.2.1/src/Hackage/Security/Util/JSON.hs
--- old/hackage-security-0.5.1.0/src/Hackage/Security/Util/JSON.hs
2016-04-23 05:48:47.000000000 +0200
+++ new/hackage-security-0.5.2.1/src/Hackage/Security/Util/JSON.hs
2016-06-07 23:44:49.000000000 +0200
@@ -24,6 +24,7 @@
) where
import Control.Monad (liftM)
+import Data.Maybe (catMaybes)
import Data.Map (Map)
import Data.Time
import Text.JSON.Canonical
@@ -54,7 +55,7 @@
-- | Used in the 'FromJSON' instance for 'Map'
class FromObjectKey m a where
- fromObjectKey :: String -> m a
+ fromObjectKey :: String -> m (Maybe a)
-- | Monads in which we can report schema errors
class (Applicative m, Monad m) => ReportSchemaErrors m where
@@ -85,13 +86,13 @@
toObjectKey = return
instance Monad m => FromObjectKey m String where
- fromObjectKey = return
+ fromObjectKey = return . Just
instance Monad m => ToObjectKey m (Path root) where
toObjectKey (Path fp) = return fp
instance Monad m => FromObjectKey m (Path root) where
- fromObjectKey = liftM Path . fromObjectKey
+ fromObjectKey = liftM (fmap Path) . fromObjectKey
{-------------------------------------------------------------------------------
ToJSON and FromJSON instances
@@ -162,10 +163,13 @@
) => FromJSON m (Map k a) where
fromJSON enc = do
obj <- fromJSObject enc
- Map.fromList <$> mapM aux obj
+ Map.fromList . catMaybes <$> mapM aux obj
where
- aux :: (String, JSValue) -> m (k, a)
- aux (k, a) = (,) <$> fromObjectKey k <*> fromJSON a
+ aux :: (String, JSValue) -> m (Maybe (k, a))
+ aux (k, a) = knownKeys <$> fromObjectKey k <*> fromJSON a
+ knownKeys :: Maybe k -> a -> Maybe (k, a)
+ knownKeys Nothing _ = Nothing
+ knownKeys (Just k) a = Just (k, a)
instance Monad m => ToJSON m URI where
toJSON = toJSON . show
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/hackage-security-0.5.1.0/src/Hackage/Security/Util/Path.hs
new/hackage-security-0.5.2.1/src/Hackage/Security/Util/Path.hs
--- old/hackage-security-0.5.1.0/src/Hackage/Security/Util/Path.hs
2016-04-23 05:48:47.000000000 +0200
+++ new/hackage-security-0.5.2.1/src/Hackage/Security/Util/Path.hs
2016-06-07 23:44:49.000000000 +0200
@@ -17,6 +17,7 @@
, takeFileName
, (<.>)
, splitExtension
+ , takeExtension
-- * Unrooted paths
, Unrooted
, (</>)
@@ -26,6 +27,7 @@
, fromUnrootedFilePath
, fragment
, joinFragments
+ , splitFragments
, isPathPrefixOf
-- * File-system paths
, Relative
@@ -92,7 +94,8 @@
#endif
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BS.L
-import qualified System.FilePath as FP
+import qualified System.FilePath as FP.Native
+import qualified System.FilePath.Posix as FP.Posix
import qualified System.IO as IO
import qualified System.Directory as Dir
import qualified Codec.Archive.Tar as Tar
@@ -115,9 +118,21 @@
-- make sense to append two absolute paths together; instead, we can only
append
-- an unrooted path to another path. It also means we avoid bugs where we use
-- one kind of path where we expect another.
-newtype Path a = Path { unPath :: FilePath }
+newtype Path a = Path FilePath -- always a Posix style path internally
deriving (Show, Eq, Ord)
+mkPathNative :: FilePath -> Path a
+mkPathNative = Path . FP.Posix.joinPath . FP.Native.splitDirectories
+
+unPathNative :: Path a -> FilePath
+unPathNative (Path fp) = FP.Native.joinPath . FP.Posix.splitDirectories $ fp
+
+mkPathPosix :: FilePath -> Path a
+mkPathPosix = Path
+
+unPathPosix :: Path a -> FilePath
+unPathPosix (Path fp) = fp
+
-- | Reinterpret the root of a path
--
-- This literally just changes the type-level tag; use with caution!
@@ -129,18 +144,21 @@
-------------------------------------------------------------------------------}
takeDirectory :: Path a -> Path a
-takeDirectory = liftFP FP.takeDirectory
+takeDirectory = liftFP FP.Posix.takeDirectory
takeFileName :: Path a -> String
-takeFileName = liftFromFP FP.takeFileName
+takeFileName = liftFromFP FP.Posix.takeFileName
(<.>) :: Path a -> String -> Path a
-fp <.> ext = liftFP (FP.<.> ext) fp
+fp <.> ext = liftFP (FP.Posix.<.> ext) fp
splitExtension :: Path a -> (Path a, String)
splitExtension (Path fp) = (Path fp', ext)
where
- (fp', ext) = FP.splitExtension fp
+ (fp', ext) = FP.Posix.splitExtension fp
+
+takeExtension :: Path a -> String
+takeExtension (Path fp) = FP.Posix.takeExtension fp
{-------------------------------------------------------------------------------
Unrooted paths
@@ -155,7 +173,7 @@
pretty (Path fp) = fp
(</>) :: Path a -> Path Unrooted -> Path a
-(</>) = liftFP2 (FP.</>)
+(</>) = liftFP2 (FP.Posix.</>)
-- | Reinterpret an unrooted path
--
@@ -169,18 +187,29 @@
unrootPath :: Path root -> Path Unrooted
unrootPath (Path fp) = Path fp
+-- | Convert a relative\/unrooted Path to a FilePath (using POSIX style
+-- directory separators).
+--
+-- See also 'toAbsoluteFilePath'
+--
toUnrootedFilePath :: Path Unrooted -> FilePath
-toUnrootedFilePath = unPath
+toUnrootedFilePath = unPathPosix
+-- | Convert from a relative\/unrooted FilePath (using POSIX style directory
+-- separators).
+--
fromUnrootedFilePath :: FilePath -> Path Unrooted
-fromUnrootedFilePath = Path
+fromUnrootedFilePath = mkPathPosix
-- | A path fragment (like a single directory or filename)
fragment :: String -> Path Unrooted
-fragment = fromUnrootedFilePath
+fragment = Path
joinFragments :: [String] -> Path Unrooted
-joinFragments = liftToFP FP.joinPath
+joinFragments = liftToFP FP.Posix.joinPath
+
+splitFragments :: Path Unrooted -> [String]
+splitFragments (Path fp) = FP.Posix.splitDirectories fp
isPathPrefixOf :: Path Unrooted -> Path Unrooted -> Bool
isPathPrefixOf = liftFromFP2 isPrefixOf
@@ -204,30 +233,34 @@
-- | A file system root can be interpreted as an (absolute) FilePath
class FsRoot root where
+ -- | Convert a Path to an absolute FilePath (using native style directory
separators).
+ --
toAbsoluteFilePath :: Path root -> IO FilePath
instance FsRoot Relative where
- toAbsoluteFilePath (Path fp) = go fp
+ toAbsoluteFilePath p = go (unPathNative p)
where
go :: FilePath -> IO FilePath
#if MIN_VERSION_directory(1,2,2)
go = Dir.makeAbsolute
#else
-- copied implementation from the directory package
- go = (FP.normalise <$>) . absolutize
+ go = (FP.Native.normalise <$>) . absolutize
absolutize path -- avoid the call to `getCurrentDirectory` if we can
- | FP.isRelative path = (FP.</> path) . FP.addTrailingPathSeparator
<$>
- Dir.getCurrentDirectory
- | otherwise = return path
+ | FP.Native.isRelative path
+ = (FP.Native.</> path)
+ . FP.Native.addTrailingPathSeparator <$>
+ Dir.getCurrentDirectory
+ | otherwise = return path
#endif
instance FsRoot Absolute where
- toAbsoluteFilePath (Path fp) = return fp
+ toAbsoluteFilePath = return . unPathNative
instance FsRoot HomeDir where
- toAbsoluteFilePath (Path fp) = do
+ toAbsoluteFilePath p = do
home <- Dir.getHomeDirectory
- return $ home FP.</> fp
+ return $ home FP.Native.</> unPathNative p
-- | Abstract over a file system root
--
@@ -239,29 +272,29 @@
-------------------------------------------------------------------------------}
toFilePath :: Path Absolute -> FilePath
-toFilePath (Path fp) = fp
+toFilePath = unPathNative
fromFilePath :: FilePath -> FsPath
fromFilePath fp
- | FP.isAbsolute fp = FsPath (Path fp :: Path Absolute)
- | Just fp' <- atHome fp = FsPath (Path fp' :: Path HomeDir)
- | otherwise = FsPath (Path fp :: Path Relative)
+ | FP.Native.isAbsolute fp = FsPath (mkPathNative fp :: Path Absolute)
+ | Just fp' <- atHome fp = FsPath (mkPathNative fp' :: Path HomeDir)
+ | otherwise = FsPath (mkPathNative fp :: Path Relative)
where
-- TODO: I don't know if there a standard way that Windows users refer to
-- their home directory. For now, we'll only interpret '~'. Everybody else
-- can specify an absolute path if this doesn't work.
atHome :: FilePath -> Maybe FilePath
atHome "~" = Just ""
- atHome ('~':sep:fp') | FP.isPathSeparator sep = Just fp'
+ atHome ('~':sep:fp') | FP.Native.isPathSeparator sep = Just fp'
atHome _otherwise = Nothing
makeAbsolute :: FsPath -> IO (Path Absolute)
-makeAbsolute (FsPath p) = Path <$> toAbsoluteFilePath p
+makeAbsolute (FsPath p) = mkPathNative <$> toAbsoluteFilePath p
fromAbsoluteFilePath :: FilePath -> Path Absolute
fromAbsoluteFilePath fp
- | FP.isAbsolute fp = Path fp
- | otherwise = error "fromAbsoluteFilePath: not an absolute path"
+ | FP.Native.isAbsolute fp = mkPathNative fp
+ | otherwise = error "fromAbsoluteFilePath: not an absolute
path"
{-------------------------------------------------------------------------------
Wrappers around System.IO
@@ -363,7 +396,7 @@
fragments <$> Dir.getDirectoryContents filePath
where
fragments :: [String] -> [Path Unrooted]
- fragments = map fromUnrootedFilePath . filter (not . skip)
+ fragments = map fragment . filter (not . skip)
skip :: String -> Bool
skip "." = True
@@ -389,7 +422,7 @@
else return [path]
emptyPath :: Path Unrooted
- emptyPath = Path (FP.joinPath [])
+ emptyPath = joinFragments []
renameFile :: (FsRoot root, FsRoot root')
=> Path root -- ^ Old
@@ -431,7 +464,7 @@
Tar.append tarFile' baseDir' contents'
where
contents' :: [FilePath]
- contents' = map (toUnrootedFilePath . unrootPath) contents
+ contents' = map (unPathNative . unrootPath) contents
{-------------------------------------------------------------------------------
Wrappers around Network.URI
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/hackage-security-0.5.1.0/tests/TestSuite/HttpMem.hs
new/hackage-security-0.5.2.1/tests/TestSuite/HttpMem.hs
--- old/hackage-security-0.5.1.0/tests/TestSuite/HttpMem.hs 1970-01-01
01:00:00.000000000 +0100
+++ new/hackage-security-0.5.2.1/tests/TestSuite/HttpMem.hs 2016-06-07
23:44:49.000000000 +0200
@@ -0,0 +1,70 @@
+-- | HttpLib bridge to the in-memory repository
+module TestSuite.HttpMem (
+ httpMem
+ ) where
+
+-- stdlib
+import Network.URI (URI)
+import qualified Data.ByteString.Lazy as BS.L
+
+-- hackage-security
+import Hackage.Security.Client
+import Hackage.Security.Client.Repository.HttpLib
+import Hackage.Security.Util.Checked
+import Hackage.Security.Util.Path
+import Hackage.Security.Util.Some
+
+-- TestSuite
+import TestSuite.InMemRepo
+
+httpMem :: InMemRepo -> HttpLib
+httpMem inMemRepo = HttpLib {
+ httpGet = get inMemRepo
+ , httpGetRange = getRange inMemRepo
+ }
+
+{-------------------------------------------------------------------------------
+ Individual methods
+-------------------------------------------------------------------------------}
+
+-- | Download a file
+--
+-- Since we don't (yet?) make any attempt to simulate a cache, we ignore
+-- caching headers.
+get :: forall a. Throws SomeRemoteError
+ => InMemRepo
+ -> [HttpRequestHeader]
+ -> URI
+ -> ([HttpResponseHeader] -> BodyReader -> IO a)
+ -> IO a
+get InMemRepo{..} _requestHeaders uri callback = do
+ Some inMemFile <- inMemRepoGetPath $ castRoot (uriPath uri)
+ br <- bodyReaderFromBS $ inMemFileRender inMemFile
+ callback [HttpResponseAcceptRangesBytes] br
+
+-- | Download a byte range
+--
+-- Range is starting and (exclusive) end offset in bytes.
+--
+-- We ignore requests for compression; different servers deal with compression
+-- for byte range requests differently; in particular, Apache returns the range
+-- of the _compressed_ file, which is pretty useless for our purposes. For now
+-- we ignore this issue completely here.
+getRange :: forall a. Throws SomeRemoteError
+ => InMemRepo
+ -> [HttpRequestHeader]
+ -> URI
+ -> (Int, Int)
+ -> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a)
+ -> IO a
+getRange InMemRepo{..} _requestHeaders uri (fr, to) callback = do
+ Some inMemFile <- inMemRepoGetPath $ castRoot (uriPath uri)
+ br <- bodyReaderFromBS $ substr (inMemFileRender inMemFile)
+
+ let responseHeaders = concat [
+ [ HttpResponseAcceptRangesBytes ]
+ ]
+ callback HttpStatus206PartialContent responseHeaders br
+ where
+ substr :: BS.L.ByteString -> BS.L.ByteString
+ substr = BS.L.take (fromIntegral (to - fr)) . BS.L.drop (fromIntegral fr)
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/hackage-security-0.5.1.0/tests/TestSuite/InMemCache.hs
new/hackage-security-0.5.2.1/tests/TestSuite/InMemCache.hs
--- old/hackage-security-0.5.1.0/tests/TestSuite/InMemCache.hs 2016-04-23
05:48:47.000000000 +0200
+++ new/hackage-security-0.5.2.1/tests/TestSuite/InMemCache.hs 2016-06-07
23:44:49.000000000 +0200
@@ -8,8 +8,13 @@
import qualified Codec.Compression.GZip as GZip
import qualified Data.ByteString.Lazy as BS.L
+-- tar
+import qualified Codec.Archive.Tar as Tar
+import qualified Codec.Archive.Tar.Index as TarIndex
+import Codec.Archive.Tar.Index (TarIndex)
+
-- hackage-security
-import Hackage.Security.Client
+import Hackage.Security.Client hiding (withIndex)
import Hackage.Security.Client.Formats
import Hackage.Security.Client.Repository
import Hackage.Security.JSON
@@ -20,20 +25,25 @@
import TestSuite.InMemRepo
data InMemCache = InMemCache {
- inMemCacheGet :: CachedFile -> IO (Maybe (Path Absolute))
- , inMemCacheGetRoot :: IO (Path Absolute)
- , inMemCacheClear :: IO ()
- , inMemCachePut :: forall f typ. InMemFile typ -> Format f -> IsCached
typ -> IO ()
+ inMemCacheGet :: CachedFile -> IO (Maybe (Path Absolute))
+ , inMemCacheGetRoot :: IO (Path Absolute)
+ , inMemCacheWithIndex :: forall a. (Handle -> IO a) -> IO a
+ , inMemCacheGetIndexIdx :: IO TarIndex
+ , inMemCacheClear :: IO ()
+ , inMemCachePut :: forall f typ. InMemFile typ -> Format f
+ -> IsCached typ -> IO ()
}
newInMemCache :: Path Absolute -> RepoLayout -> IO InMemCache
newInMemCache tempDir layout = do
state <- newMVar $ initLocalState layout
return InMemCache {
- inMemCacheGet = get state tempDir
- , inMemCacheGetRoot = getRoot state tempDir
- , inMemCacheClear = clear state
- , inMemCachePut = put state
+ inMemCacheGet = get state tempDir
+ , inMemCacheGetRoot = getRoot state tempDir
+ , inMemCacheWithIndex = withIndex state tempDir
+ , inMemCacheGetIndexIdx = getIndexIdx state
+ , inMemCacheClear = clear state
+ , inMemCachePut = put state
}
{-------------------------------------------------------------------------------
@@ -106,6 +116,26 @@
getRoot state cacheTempDir =
needRoot `fmap` get state cacheTempDir CachedRoot
+withIndex :: MVar LocalState -> Path Absolute -> (Handle -> IO a) -> IO a
+withIndex state cacheTempDir action = do
+ st <- readMVar state
+ case cachedIndex st of
+ Nothing -> error "InMemCache.withIndex: Could not read index."
+ Just bs -> do
+ (_, h) <- openTempFile' cacheTempDir "01-index.tar"
+ BS.L.hPut h bs
+ hSeek h AbsoluteSeek 0
+ x <- action h
+ hClose h
+ return x
+
+getIndexIdx :: MVar LocalState -> IO TarIndex
+getIndexIdx state = do
+ st <- readMVar state
+ case cachedIndex st of
+ Nothing -> error "InMemCache.getIndexIdx: Could not read index."
+ Just index -> either throwIO return . TarIndex.build . Tar.read $ index
+
-- | Clear all cached data
clear :: MVar LocalState -> IO ()
clear state = modifyMVar_ state $ \st -> return st {
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/hackage-security-0.5.1.0/tests/TestSuite/InMemRepo.hs
new/hackage-security-0.5.2.1/tests/TestSuite/InMemRepo.hs
--- old/hackage-security-0.5.1.0/tests/TestSuite/InMemRepo.hs 2016-04-23
05:48:47.000000000 +0200
+++ new/hackage-security-0.5.2.1/tests/TestSuite/InMemRepo.hs 2016-06-07
23:44:49.000000000 +0200
@@ -72,6 +72,9 @@
-- | Rollover the timestamp and snapshot keys
, inMemRepoKeyRollover :: UTCTime -> IO ()
+
+ -- | Set the content of the repo tar index and resign
+ , inMemRepoSetIndex :: UTCTime -> [Tar.Entry] -> IO ()
}
newInMemRepo :: RepoLayout
@@ -86,6 +89,7 @@
, inMemRepoGetPath = getPath state
, inMemRepoCron = cron state
, inMemRepoKeyRollover = keyRollover state
+ , inMemRepoSetIndex = setIndex state
}
{-------------------------------------------------------------------------------
@@ -215,6 +219,41 @@
, remoteSnapshot = signedSnapshot
}
+setIndex :: MVar RemoteState -> UTCTime -> [Tar.Entry] -> IO ()
+setIndex state now entries = modifyMVar_ state $ \st@RemoteState{..} -> do
+ let snapshot, snapshot' :: Snapshot
+ snapshot = signed remoteSnapshot
+ snapshot' = snapshot {
+ snapshotVersion = versionIncrement $ snapshotVersion snapshot
+ , snapshotExpires = expiresInDays now 3
+ , snapshotInfoTarGz = fileInfo $ newTarGz
+ , snapshotInfoTar = Just $ fileInfo newTar
+ }
+
+ newTar :: BS.L.ByteString
+ newTar = Tar.write entries
+
+ newTarGz :: BS.L.ByteString
+ newTarGz = GZip.compress newTar
+
+ timestamp, timestamp' :: Timestamp
+ timestamp = signed remoteTimestamp
+ timestamp' = Timestamp {
+ timestampVersion = versionIncrement $ timestampVersion
timestamp
+ , timestampExpires = expiresInDays now 3
+ , timestampInfoSnapshot = fileInfo $ renderJSON remoteLayout
signedSnapshot
+ }
+
+ signedTimestamp = withSignatures remoteLayout [privateTimestamp
remoteKeys] timestamp'
+ signedSnapshot = withSignatures remoteLayout [privateSnapshot
remoteKeys] snapshot'
+
+ return st {
+ remoteTimestamp = signedTimestamp
+ , remoteSnapshot = signedSnapshot
+ , remoteTar = newTar
+ , remoteTarGz = newTarGz
+ }
+
keyRollover :: MVar RemoteState -> UTCTime -> IO ()
keyRollover state now = modifyMVar_ state $ \st@RemoteState{..} -> do
newKeySnapshot <- createKey' KeyTypeEd25519
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/hackage-security-0.5.1.0/tests/TestSuite/InMemRepository.hs
new/hackage-security-0.5.2.1/tests/TestSuite/InMemRepository.hs
--- old/hackage-security-0.5.1.0/tests/TestSuite/InMemRepository.hs
2016-04-23 05:48:47.000000000 +0200
+++ new/hackage-security-0.5.2.1/tests/TestSuite/InMemRepository.hs
2016-06-07 23:44:49.000000000 +0200
@@ -31,8 +31,8 @@
, repGetCachedRoot = inMemCacheGetRoot cache
, repClearCache = inMemCacheClear cache
, repLockCache = withMVar cacheLock . const
- , repWithIndex = error "newInMemRepository: repWithIndex TODO"
- , repGetIndexIdx = error "newInMemRepository: repGetIndexIdx TODO"
+ , repWithIndex = inMemCacheWithIndex cache
+ , repGetIndexIdx = inMemCacheGetIndexIdx cache
, repWithMirror = withMirror
, repLog = logger
, repLayout = layout
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/hackage-security-0.5.1.0/tests/TestSuite/JSON.hs
new/hackage-security-0.5.2.1/tests/TestSuite/JSON.hs
--- old/hackage-security-0.5.1.0/tests/TestSuite/JSON.hs 1970-01-01
01:00:00.000000000 +0100
+++ new/hackage-security-0.5.2.1/tests/TestSuite/JSON.hs 2016-06-07
23:44:49.000000000 +0200
@@ -0,0 +1,77 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module TestSuite.JSON (
+ prop_roundtrip_canonical,
+ prop_roundtrip_pretty,
+ prop_canonical_pretty,
+ ) where
+
+-- stdlib
+import Data.Int
+import Data.List (sortBy, nubBy)
+import Data.Function (on)
+import Control.Applicative
+import qualified Data.ByteString.Lazy.Char8 as BS
+import Test.QuickCheck
+
+-- hackage-security
+import Text.JSON.Canonical
+
+
+prop_roundtrip_canonical, prop_roundtrip_pretty, prop_canonical_pretty
+ :: JSValue -> Bool
+
+prop_roundtrip_canonical jsval =
+ parseCanonicalJSON (renderCanonicalJSON jsval) == Right (canonicalise
jsval)
+
+prop_roundtrip_pretty jsval =
+ parseCanonicalJSON (BS.pack (prettyCanonicalJSON jsval)) == Right jsval
+
+prop_canonical_pretty jsval =
+ parseCanonicalJSON (renderCanonicalJSON jsval) ==
+ fmap canonicalise (parseCanonicalJSON (BS.pack (prettyCanonicalJSON
jsval)))
+
+canonicalise :: JSValue -> JSValue
+canonicalise v@JSNull = v
+canonicalise v@(JSBool _) = v
+canonicalise v@(JSNum _) = v
+canonicalise v@(JSString _) = v
+canonicalise (JSArray vs) = JSArray [ canonicalise v | v <- vs]
+canonicalise (JSObject vs) = JSObject [ (k, canonicalise v)
+ | (k,v) <- sortBy (compare `on` fst)
vs ]
+
+instance Arbitrary JSValue where
+ arbitrary =
+ sized $ \sz ->
+ frequency
+ [ (1, pure JSNull)
+ , (1, JSBool <$> arbitrary)
+ , (2, JSNum <$> arbitrary)
+ , (2, JSString <$> arbitrary)
+ , (3, JSArray <$> resize (sz `div` 2) arbitrary)
+ , (3, JSObject . noDupFields <$> resize (sz `div` 2) arbitrary)
+ ]
+ where
+ noDupFields = nubBy (\(x,_) (y,_) -> x==y)
+
+ shrink JSNull = []
+ shrink (JSBool _) = []
+ shrink (JSNum n) = [ JSNum n' | n' <- shrink n ]
+ shrink (JSString s) = [ JSString s' | s' <- shrink s ]
+ shrink (JSArray vs) = [ JSArray vs' | vs' <- shrink vs ]
+ shrink (JSObject vs) = [ JSObject vs' | vs' <- shrinkList shrinkSnd vs ]
+ where
+ shrinkSnd (a,b) = [ (a,b') | b' <- shrink b ]
+
+
+instance Arbitrary Int54 where
+ arbitrary = fromIntegral <$>
+ frequency [ (1, pure lowerbound)
+ , (1, pure upperbound)
+ , (8, choose (lowerbound, upperbound))
+ ]
+ where
+ upperbound, lowerbound :: Int64
+ upperbound = 999999999999999 -- 15 decimal digits
+ lowerbound = (-999999999999999)
+ shrink = shrinkIntegral
+
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/hackage-security-0.5.1.0/tests/TestSuite.hs
new/hackage-security-0.5.2.1/tests/TestSuite.hs
--- old/hackage-security-0.5.1.0/tests/TestSuite.hs 2016-04-23
05:48:47.000000000 +0200
+++ new/hackage-security-0.5.2.1/tests/TestSuite.hs 2016-06-07
23:44:49.000000000 +0200
@@ -1,3 +1,4 @@
+{-# LANGUAGE RecordWildCards, GADTs #-}
module Main (main) where
-- stdlib
@@ -8,8 +9,13 @@
import Network.URI (URI, parseURI)
import Test.Tasty
import Test.Tasty.HUnit
-import Test.Tasty.QuickCheck
+import Test.Tasty.QuickCheck hiding (label)
import System.IO.Temp (withSystemTempDirectory)
+import qualified Codec.Archive.Tar.Entry as Tar
+import qualified Data.ByteString.Lazy.Char8 as BS
+
+-- Cabal
+import Distribution.Package (PackageName(..))
-- hackage-security
import Hackage.Security.Client
@@ -17,6 +23,7 @@
import Hackage.Security.JSON (DeserializationError(..))
import Hackage.Security.Util.Checked
import Hackage.Security.Util.Path
+import Hackage.Security.Util.Some
import Hackage.Security.Util.Pretty
import qualified Hackage.Security.Client.Repository.Remote as Remote
import qualified Hackage.Security.Client.Repository.Cache as Cache
@@ -45,6 +52,7 @@
, testCase "testInMemUpdatesAfterCron" testInMemUpdatesAfterCron
, testCase "testInMemKeyRollover" testInMemKeyRollover
, testCase "testInMemOutdatedTimestamp" testInMemOutdatedTimestamp
+ , testCase "testInMemIndex" testInMemIndex
]
, testGroup "HttpMem" [
testCase "testHttpMemInitialHasForUpdates"
testHttpMemInitialHasUpdates
@@ -52,6 +60,7 @@
, testCase "testHttpMemUpdatesAfterCron"
testHttpMemUpdatesAfterCron
, testCase "testHttpMemKeyRollover" testHttpMemKeyRollover
, testCase "testHttpMemOutdatedTimestamp"
testHttpMemOutdatedTimestamp
+ , testCase "testHttpMemIndex" testHttpMemIndex
]
, testGroup "Canonical JSON" [
testProperty "prop_roundtrip_canonical" JSON.prop_roundtrip_canonical
@@ -131,6 +140,10 @@
withAssertLog "C" logMsgs [] $ do
assertEqual "C.1" HasUpdates =<< checkForUpdates repo fourDaysLater
+testInMemIndex :: Assertion
+testInMemIndex = inMemTest $ \inMemRepo _logMsgs repo ->
+ testRepoIndex inMemRepo repo
+
{-------------------------------------------------------------------------------
Same tests, but going through the "real" Remote repository and Cache, though
still using an in-memory repository (with a HttpLib bridge)
@@ -202,6 +215,57 @@
withAssertLog "C" logMsgs [] $ do
assertEqual "C.1" HasUpdates =<< checkForUpdates repo fourDaysLater
+testHttpMemIndex :: Assertion
+testHttpMemIndex = httpMemTest $ \inMemRepo _logMsgs repo ->
+ testRepoIndex inMemRepo repo
+
+{-------------------------------------------------------------------------------
+ Identical tests between the two variants
+-------------------------------------------------------------------------------}
+
+testRepoIndex :: (Throws SomeRemoteError, Throws VerificationError)
+ => InMemRepo -> Repository down -> IO ()
+testRepoIndex inMemRepo repo = do
+ assertEqual "A" HasUpdates =<< checkForUpdates repo =<< checkExpiry
+ dir1 <- getDirectory repo
+ directoryFirst dir1 @?= DirectoryEntry 0
+ directoryNext dir1 @?= DirectoryEntry 0
+ length (directoryEntries dir1) @?= 0
+
+ now <- getCurrentTime
+ inMemRepoSetIndex inMemRepo now [testEntry1]
+
+ assertEqual "B" HasUpdates =<< checkForUpdates repo =<< checkExpiry
+ dir2 <- getDirectory repo
+ directoryFirst dir2 @?= DirectoryEntry 0
+ directoryNext dir2 @?= DirectoryEntry 2
+ length (directoryEntries dir2) @?= 1
+ directoryLookup dir2 testEntryIndexFile @?= Just (DirectoryEntry 0)
+ withIndex repo $ \IndexCallbacks{..} -> do
+ (sentry, next) <- indexLookupEntry (DirectoryEntry 0)
+ next @?= Nothing
+ case sentry of Some entry -> checkIndexEntry entry
+ where
+ checkIndexEntry :: IndexEntry dec -> Assertion
+ checkIndexEntry entry = do
+ toUnrootedFilePath (unrootPath (indexEntryPath entry))
+ @?= "foo/preferred-versions"
+ indexEntryContent entry @?= testEntrycontent
+ case indexEntryPathParsed entry of
+ Just (IndexPkgPrefs pkgname) -> do
+ pkgname @?= PackageName "foo"
+ case indexEntryContentParsed entry of
+ Right () -> return ()
+ _ -> fail "unexpected index entry content"
+ _ -> fail "unexpected index path"
+
+ testEntry1 = Tar.fileEntry path testEntrycontent
+ where
+ Right path = Tar.toTarPath False "foo/preferred-versions"
+ testEntrycontent = BS.pack "foo >= 1"
+ testEntryIndexFile = IndexPkgPrefs (PackageName "foo")
+
+
{-------------------------------------------------------------------------------
Log messages we expect when using the Remote repository
-------------------------------------------------------------------------------}
