hackage-security 0.5.3.0 → 0.6.3.3
raw patch · 45 files changed
Files
- ChangeLog.md +117/−0
- hackage-security.cabal +78/−108
- src/Hackage/Security/Client.hs +3/−25
- src/Hackage/Security/Client/Formats.hs +6/−4
- src/Hackage/Security/Client/Repository.hs +34/−12
- src/Hackage/Security/Client/Repository/Cache.hs +15/−2
- src/Hackage/Security/Client/Repository/HttpLib.hs +2/−2
- src/Hackage/Security/Client/Repository/Local.hs +2/−1
- src/Hackage/Security/Client/Repository/Remote.hs +10/−15
- src/Hackage/Security/Client/Verify.hs +4/−1
- src/Hackage/Security/JSON.hs +4/−9
- src/Hackage/Security/Key.hs +3/−33
- src/Hackage/Security/TUF/Common.hs +1/−0
- src/Hackage/Security/TUF/FileMap.hs +0/−12
- src/Hackage/Security/TUF/Header.hs +5/−5
- src/Hackage/Security/TUF/Layout/Cache.hs +2/−1
- src/Hackage/Security/TUF/Layout/Index.hs +3/−1
- src/Hackage/Security/TUF/Layout/Repo.hs +1/−0
- src/Hackage/Security/TUF/Mirrors.hs +1/−0
- src/Hackage/Security/TUF/Paths.hs +1/−0
- src/Hackage/Security/TUF/Patterns.hs +13/−29
- src/Hackage/Security/TUF/Root.hs +1/−0
- src/Hackage/Security/TUF/Signed.hs +1/−0
- src/Hackage/Security/TUF/Snapshot.hs +8/−3
- src/Hackage/Security/TUF/Targets.hs +1/−0
- src/Hackage/Security/TUF/Timestamp.hs +6/−1
- src/Hackage/Security/Trusted.hs +2/−3
- src/Hackage/Security/Trusted/TCB.hs +31/−38
- src/Hackage/Security/Util/Base64.hs +1/−0
- src/Hackage/Security/Util/Checked.hs +5/−34
- src/Hackage/Security/Util/Exit.hs +3/−1
- src/Hackage/Security/Util/FileLock.hsc +0/−202
- src/Hackage/Security/Util/IO.hs +54/−21
- src/Hackage/Security/Util/JSON.hs +1/−16
- src/Hackage/Security/Util/Lens.hs +18/−19
- src/Hackage/Security/Util/Path.hs +15/−27
- src/Hackage/Security/Util/Pretty.hs +2/−0
- src/Hackage/Security/Util/Some.hs +1/−17
- src/Hackage/Security/Util/Stack.hs +2/−0
- src/Hackage/Security/Util/TypedEmbedded.hs +4/−1
- src/Prelude.hs +0/−32
- src/Text/JSON/Canonical.hs +2/−14
- tests/TestSuite.hs +61/−11
- tests/TestSuite/InMemRepo.hs +2/−1
- tests/TestSuite/JSON.hs +39/−8
ChangeLog.md view
@@ -1,3 +1,120 @@+See also http://pvp.haskell.org/faq++0.6.3.3+-------++* Remove `lukko` package flag. Now we unconditionally use `GHC.IO.Handle.Lock`+ instead of the [`lukko` package](https://hackage.haskell.org/package/lukko).+* Allow `Cabal-3.18` and `Cabal-syntax-3.18`.+* Allow building against newer releases of other dependencies.+* Tested with GHC 8.4 - 9.14.++0.6.3.2+-------++* Allow `tar-0.7`.+* Relax upper bounds for GHC 9.14 shipped packages.+* Remove obsolete `deriving Typeable`.+* Tested with GHC 8.4 - 9.14 alpha1.++0.6.3.1+-------++* Allow `QuickCheck-2.16`.+* Tested with GHC 8.4 - 9.12.+++0.6.3.0+-------++* Make `lukko` flag automatic and off by default, using file locking+ facilities from `GHC.IO.Handle.Lock` and not from+ on [`lukko` package](https://hackage.haskell.org/package/lukko).+ The change is not expected to affect anyone detrimentally,+ but one can set the flag on in their configuration to restore+ the previous behaviour.+* Allow building against newer releases of dependencies.+* Tested with GHC 8.4 - 9.12.+++0.6.2.6+-------++* Drop flag `use-network-uri` and support for `network-2.5`.+* Fix build failure in testsuite with `tar-0.5`+ ([PR #312](https://github.com/haskell/hackage-security/pull/312)).+* Tested with GHC 8.4 - 9.8.++0.6.2.5+-------++* Allow `Cabal-3.12` and `Cabal-syntax-3.12`.+* Allow `zlib-0.7`.+* Drop flag `use-old-time` and support for `old-time`, require `time ≥ 1.5`+ ([PR #304](https://github.com/haskell/hackage-security/pull/304)).+* Drop support for GHC < 8.4+ ([PR #306](https://github.com/haskell/hackage-security/pull/306)).+* Code maintenance: address warning `star-is-type`, `unused-record-wildcards` etc.+ ([PR #306](https://github.com/haskell/hackage-security/pull/306)).+* Tested with GHC 8.4 - 9.8.++0.6.2.4+-------++* Allow `tar-0.6`+* Drop support for GHC < 7.8 in favor of `PatternSynonyms`+* Drop flags `base48`, `mtl21`, `old-directory` and support for GHC 7.8, `mtl < 2.2` and `directory < 1.2`+* Tested with GHC 7.10 - 9.8++0.6.2.3+-------++* Bump base for GHC 9.4 comp+* Fix code to *really* support mtl-2.3++0.6.2.2+-------++* Fix broken compilation of test-suite with Cabal-syntax-3.8.1.0 on Hackage+* Huge README updates++0.6.2.1+-------++* Allow GHC-9.0 (base-4.15) (#265)+* Fix running `cabal repl hackage-security` (#263)++0.6.2.0+-------++* Safely prepare for when cabal factors out Cabal-syntax++0.6.1.0+-------++* Support basic auth in package-indices (#252)+* Fix tests due to new aeson handling of unescaped control sequences (#256)+* Bump a lot of bounds on packages we depend on++0.6.0.1+-------++* Fix bug in non-default `-lukko` build-configuration (#242)+* Add support for `template-haskell-2.16.0.0` (#240)++0.6.0.0+-------++* Remove `Hackage.Security.TUF.FileMap.lookupM`+* Don't expose `Hackage.Security.Util.IO` module+* Don't expose `Hackage.Security.Util.Lens` module+* Report missing keys in `.meta` objects more appropriately as+ `ReportSchemaErrors(expected)` instead of via `Monad(fail)`+* Add support for GHC 8.8 / base-4.13+* Use `lukko` for file-locking+* Extend `LogMessage` to signal events for cache lock acquiring and release+* New `lockCacheWithLogger` operation+ 0.5.3.0 -------
hackage-security.cabal view
@@ -1,12 +1,12 @@-cabal-version: 1.12+cabal-version: 1.18 name: hackage-security-version: 0.5.3.0+version: 0.6.3.3 synopsis: Hackage security library description: The hackage security library provides both server and client utilities for securing the Hackage package server- (<http://hackage.haskell.org/>). It is based on The Update- Framework (<http://theupdateframework.com/>), a set of+ (<https://hackage.haskell.org/>). It is based on The Update+ Framework (<https://theupdateframework.com/>), a set of recommendations developed by security researchers at various universities in the US as well as developers on the Tor project (<https://www.torproject.org/>).@@ -24,31 +24,37 @@ license-file: LICENSE author: Edsko de Vries maintainer: cabal-devel@haskell.org-copyright: Copyright 2015-2016 Well-Typed LLP+copyright: Copyright 2015-2022 Well-Typed LLP category: Distribution homepage: https://github.com/haskell/hackage-security bug-reports: https://github.com/haskell/hackage-security/issues build-type: Simple -extra-source-files:+tested-with:+ GHC == 9.14.1+ GHC == 9.12.4+ GHC == 9.10.3+ GHC == 9.8.4+ GHC == 9.6.7+ GHC == 9.4.8+ GHC == 9.2.8+ GHC == 9.0.2+ GHC == 8.10.7+ GHC == 8.8.4+ GHC == 8.6.5+ GHC == 8.4.4++extra-doc-files: ChangeLog.md source-repository head type: git location: https://github.com/haskell/hackage-security.git -flag base48- description: Are we using @base@ 4.8 or later?- manual: False--flag use-network-uri- description: Are we using @network-uri@?+flag Cabal-syntax+ description: Are we using Cabal-syntax? manual: False--flag old-directory- description: Use @directory@ < 1.2 and @old-time@- manual: False- default: False+ default: False library -- Most functionality is exported through the top-level entry points .Client@@ -67,8 +73,6 @@ Hackage.Security.Trusted Hackage.Security.TUF.FileMap Hackage.Security.Util.Checked- Hackage.Security.Util.IO- Hackage.Security.Util.Lens Hackage.Security.Util.Path Hackage.Security.Util.Pretty Hackage.Security.Util.Some@@ -92,39 +96,42 @@ Hackage.Security.TUF.Timestamp Hackage.Security.Util.Base64 Hackage.Security.Util.Exit- Hackage.Security.Util.FileLock+ Hackage.Security.Util.IO Hackage.Security.Util.JSON+ Hackage.Security.Util.Lens Hackage.Security.Util.Stack Hackage.Security.Util.TypedEmbedded- Prelude- -- We support ghc 7.4 (bundled with Cabal 1.14) and up- build-depends: base >= 4.5 && < 4.12,- base16-bytestring >= 0.1.1 && < 0.2,- base64-bytestring >= 1.0 && < 1.1,- bytestring >= 0.9 && < 0.11,- Cabal >= 1.14 && < 2.4,- containers >= 0.4 && < 0.6,- ed25519 >= 0.0 && < 0.1,- filepath >= 1.2 && < 1.5,- mtl >= 2.2 && < 2.3,- parsec >= 3.1 && < 3.2,- pretty >= 1.0 && < 1.2,- cryptohash-sha256 >= 0.11 && < 0.12,++ build-depends: base >= 4.11 && < 4.23,+ base16-bytestring >= 0.1.1 && < 1.1,+ base64-bytestring >= 1.0 && < 1.3,+ bytestring >= 0.10.8.2 && < 0.13,+ containers >= 0.5.11 && < 0.9,+ cryptohash-sha256 >= 0.11 && < 0.12,+ directory >= 1.3.1.5 && < 1.4,+ ed25519 >= 0.0 && < 0.1,+ filepath >= 1.4.2 && < 1.6,+ mtl >= 2.2.2 && < 2.4,+ network-uri >= 2.6 && < 2.7,+ network >= 2.6 && < 3.3,+ parsec >= 3.1.13 && < 3.2,+ pretty >= 1.0 && < 1.2, -- 0.4.2 introduces TarIndex, 0.4.4 introduces more -- functionality, 0.5.0 changes type of serialise- tar >= 0.5 && < 0.6,- time >= 1.2 && < 1.9,- transformers >= 0.4 && < 0.6,- zlib >= 0.5 && < 0.7,+ tar >= 0.5 && < 0.8,+ template-haskell >= 2.13 && < 2.25,+ time >= 1.8.0.2 && < 1.16,+ transformers >= 0.3 && < 0.7,+ zlib >= 0.5 && < 0.8, -- whatever versions are bundled with ghc:- template-haskell,- ghc-prim- if flag(old-directory)- build-depends: directory >= 1.1.0.2 && < 1.2,- old-time >= 1 && < 1.2+ ghc-prim >= 0.5.2 && < 0.14++ if flag(Cabal-syntax)+ build-depends: Cabal-syntax >= 3.7 && < 3.20 else- build-depends: directory >= 1.2 && < 1.4- build-tool-depends: hsc2hs:hsc2hs >= 0.67 && <0.69+ build-depends: Cabal >= 2.2.0.1 && < 2.6+ || >= 3.0 && < 3.7,+ Cabal-syntax < 3.7 hs-source-dirs: src default-language: Haskell2010@@ -138,7 +145,9 @@ KindSignatures MultiParamTypeClasses NamedFieldPuns+ NoImplicitPrelude NoMonomorphismRestriction+ PatternSynonyms RankNTypes RecordWildCards ScopedTypeVariables@@ -147,70 +156,19 @@ TypeFamilies TypeOperators ViewPatterns- other-extensions: BangPatterns+ other-extensions:+ AllowAmbiguousTypes+ BangPatterns CPP+ DeriveLift OverlappingInstances PackageImports+ RoleAnnotations+ StaticPointers UndecidableInstances - -- use the new stage1/cross-compile-friendly Quotes subset of TH for new GHCs- if impl(ghc >= 8.0)- other-extensions: TemplateHaskellQuotes- else- other-extensions: TemplateHaskell- ghc-options: -Wall - if flag(base48)- build-depends: base >= 4.8- else- build-depends: base < 4.8, old-locale == 1.0.*-- -- The URI type got split out off the network package after version 2.5, and- -- moved to a separate network-uri package. Since we don't need the rest of- -- network here, it would suffice to rely only on network-uri:- --- -- > if flag(use-network-uri)- -- > build-depends: network-uri >= 2.6 && < 2.7- -- > else- -- > build-depends: network >= 2.5 && < 2.6- --- -- However, if we did the same in hackage-security-HTTP, Cabal would consider- -- those two flag choices (hackage-security:use-network-uri and- -- hackage-security-HTTP:use-network-uri) to be completely independent; but- -- they aren't: if it links hackage-security against network-uri and- -- hackage-security-HTTP against network, we will get type errors when- -- hackage-security-HTTP tries to pass a URI to hackage-security.- --- -- It might seem we can solve this problem by re-exporting the URI type in- -- hackage-security and avoid the dependency in hackage-security-HTTP- -- altogether. However, this merely shifts the problem: hackage-security-HTTP- -- relies on the HTTP library which--surprise!--makes the same choice between- -- depending on network or network-uri. Cabal will not notice that we cannot- -- build hackage-security and hackage-security-HTTP against network-uri but- -- HTTP against network.- --- -- We solve the problem by explicitly relying on network-2.6 when choosing- -- network-uri. This dependency is redundant, strictly speaking. However, it- -- serves as a proxy for forcing flag choices: since all packages in a- -- solution must be linked against the same version of network, having one- -- version of network in one branch of the conditional and another version of- -- network in the other branch forces the choice to be consistent throughout.- -- (Note that the HTTP library does the same thing, though in this case the- -- dependency in network is not redundant.)- if flag(use-network-uri)- build-depends: network-uri >= 2.6 && < 2.7,- network >= 2.6 && < 2.7- else- build-depends: network >= 2.5 && < 2.6-- if impl(ghc >= 7.8)- other-extensions: RoleAnnotations-- if impl(ghc >= 7.10)- other-extensions: AllowAmbiguousTypes- StaticPointers- test-suite TestSuite type: exitcode-stdio-1.0 main-is: TestSuite.hs@@ -225,20 +183,32 @@ -- inherited constraints from lib:hackage-security component build-depends: hackage-security, base,- Cabal, containers, bytestring, network-uri, tar,+ text, time, zlib + if flag(Cabal-syntax)+ build-depends: Cabal >= 3.7 && < 3.20,+ Cabal-syntax >= 3.7 && < 3.20+ else+ build-depends: Cabal >= 2.2.0.1 && < 2.6+ || >= 3.0 && < 3.7,+ Cabal-syntax < 3.7+ -- dependencies exclusive to test-suite- build-depends: tasty == 1.0.*,- tasty-hunit == 0.10.*,- tasty-quickcheck == 0.10.*,- QuickCheck == 2.9.*,- temporary == 1.2.*+ build-depends: tasty >= 1.1.0.4 && < 1.6,+ -- tasty-1.1.0.4 is the version in Stackage LTS 12.26 (GHC 8.4)+ tasty-hunit == 0.10.*,+ tasty-quickcheck >= 0.10 && < 1,+ QuickCheck >= 2.11 && < 2.19,+ aeson >= 1.4 && < 1.6 || >= 2.0 && < 2.3,+ vector >= 0.12 && < 0.14,+ unordered-containers >= 0.2.8.0 && < 0.3,+ temporary >= 1.2 && < 1.4 hs-source-dirs: tests default-language: Haskell2010
src/Hackage/Security/Client.hs view
@@ -1,7 +1,5 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE StaticPointers #-}-#endif+ -- | Main entry point into the Hackage Security framework for clients module Hackage.Security.Client ( -- * Checking for updates@@ -51,7 +49,6 @@ import Data.Ord (comparing) import Data.Time import Data.Traversable (for)-import Data.Typeable (Typeable) import qualified Codec.Archive.Tar as Tar import qualified Codec.Archive.Tar.Entry as Tar import qualified Codec.Archive.Tar.Index as Tar@@ -89,7 +86,7 @@ -- This implements the logic described in Section 5.1, "The client application", -- of the TUF spec. It checks which of the server metadata has changed, and -- downloads all changed metadata to the local cache. (Metadata here refers--- both to the TUF security metadata as well as the Hackage packge index.)+-- both to the TUF security metadata as well as the Hackage package index.) -- -- You should pass @Nothing@ for the UTCTime _only_ under exceptional -- circumstances (such as when the main server is down for longer than the@@ -333,11 +330,7 @@ -- | Get all cached info (if any) getCachedInfo ::-#if __GLASGOW_HASKELL__ < 800- (Applicative m, MonadIO m)-#else MonadIO m-#endif => Repository down -> m CachedInfo getCachedInfo rep = do (cachedRoot, cachedKeyEnv) <- readLocalRoot rep@@ -360,9 +353,6 @@ return (trustLocalFile signedRoot, rootKeys (signed signedRoot)) readLocalFile :: ( FromJSON ReadJSON_Keys_Layout (Signed a), MonadIO m-#if __GLASGOW_HASKELL__ < 800- , Applicative m-#endif ) => Repository down -> KeyEnv -> CachedFile -> m (Maybe (Trusted a)) readLocalFile rep cachedKeyEnv file = do@@ -383,7 +373,7 @@ -> Maybe UTCTime -> RemoteFile (f :- ()) Metadata -> Verify (Trusted a, down Metadata)-getRemoteFile rep@Repository{..} cachedInfo@CachedInfo{..} isRetry mNow file = do+getRemoteFile rep@Repository{} cachedInfo@CachedInfo{..} isRetry mNow file = do (targetPath, tempPath) <- getRemote' rep isRetry file verifyFileInfo' (remoteFileDefaultInfo file) targetPath tempPath signed <- throwErrorsChecked (VerificationErrorDeserialization targetPath) =<<@@ -940,33 +930,21 @@ rethrowInvalidPackageException = throwIO data InvalidPackageException = InvalidPackageException PackageIdentifier- deriving (Typeable) data LocalFileCorrupted = LocalFileCorrupted DeserializationError- deriving (Typeable) data InvalidFileInIndex = forall dec. InvalidFileInIndex { invalidFileInIndex :: IndexFile dec , invalidFileInIndexRaw :: BS.L.ByteString , invalidFileInIndexError :: DeserializationError }- deriving (Typeable) -#if MIN_VERSION_base(4,8,0) deriving instance Show InvalidPackageException deriving instance Show LocalFileCorrupted deriving instance Show InvalidFileInIndex instance Exception InvalidPackageException where displayException = pretty instance Exception LocalFileCorrupted where displayException = pretty instance Exception InvalidFileInIndex where displayException = pretty-#else-instance Show InvalidPackageException where show = pretty-instance Show LocalFileCorrupted where show = pretty-instance Show InvalidFileInIndex where show = pretty-instance Exception InvalidPackageException-instance Exception LocalFileCorrupted-instance Exception InvalidFileInIndex-#endif instance Pretty InvalidPackageException where pretty (InvalidPackageException pkgId) = "Invalid package " ++ display pkgId
src/Hackage/Security/Client/Formats.hs view
@@ -17,6 +17,8 @@ , formatsLookup ) where +import Prelude+import Data.Kind (Type) import Hackage.Security.Util.Stack import Hackage.Security.Util.TypedEmbedded @@ -30,7 +32,7 @@ -- | Format is a singleton type (reflection type to term level) -- -- NOTE: In the future we might add further compression formats.-data Format :: * -> * where+data Format :: Type -> Type where FUn :: Format FormatUn FGz :: Format FormatGz @@ -50,11 +52,11 @@ -- -- Rather than having a general list here, we enumerate all possibilities. -- This means we are very precise about what we expect, and we avoid any runtime--- errors about unexpect format definitions.+-- errors about unexpected format definitions. -- -- NOTE: If we add additional cases here (for dealing with additional formats) -- all calls to @error "inaccessible"@ need to be reevaluated.-data Formats :: * -> * -> * where+data Formats :: Type -> Type -> Type where FsNone :: Formats () a FsUn :: a -> Formats (FormatUn :- ()) a FsGz :: a -> Formats (FormatGz :- ()) a@@ -73,7 +75,7 @@ -- | @HasFormat fs f@ is a proof that @f@ is a key in @fs@. -- -- See 'formatsMember' and 'formatsLookup' for typical usage.-data HasFormat :: * -> * -> * where+data HasFormat :: Type -> Type -> Type where HFZ :: Format f -> HasFormat (f :- fs) f HFS :: HasFormat fs f -> HasFormat (f' :- fs) f
src/Hackage/Security/Client/Repository.hs view
@@ -30,8 +30,9 @@ , mustCache ) where +import Prelude import Control.Exception-import Data.Typeable (Typeable)+import Data.Kind (Type) import qualified Codec.Archive.Tar.Index as Tar import qualified Data.ByteString.Lazy as BS.L @@ -62,7 +63,7 @@ -- is metadata actual binary content. -- -- NOTE: Haddock lacks GADT support so constructors have only regular comments.-data RemoteFile :: * -> * -> * where+data RemoteFile :: Type -> Type -> Type where -- Timestamp metadata (@timestamp.json@) -- -- We never have (explicit) file length available for timestamps.@@ -180,7 +181,7 @@ -- * Download the file from the repository and make it available at a -- temporary location -- * Use the provided file length to protect against endless data attacks.- -- (Repositories such as local repositories that are not suspectible to+ -- (Repositories such as local repositories that are not susceptible to -- endless data attacks can safely ignore this argument.) -- * Move the file from its temporary location to its permanent location -- if verification succeeds.@@ -316,6 +317,27 @@ -- (we will try with a different mirror if any are available) | LogMirrorFailed MirrorDescription SomeException + -- | This log event is triggered before invoking a filesystem lock+ -- operation that may block for a significant amount of time; once+ -- the possibly blocking call completes successfully,+ -- 'LogLockWaitDone' will be emitted.+ --+ -- @since 0.6.0+ | LogLockWait (Path Absolute)++ -- | Denotes completion of the operation that advertised a+ -- 'LogLockWait' event+ --+ -- @since 0.6.0+ | LogLockWaitDone (Path Absolute)++ -- | Denotes the filesystem lock previously acquired (signaled by+ -- 'LogLockWait') has been released.+ --+ -- @since 0.6.0+ | LogUnlock (Path Absolute)++ -- | Records why we are downloading a file rather than updating it. data UpdateFailure = -- | Server does not support incremental downloads@@ -339,7 +361,7 @@ Downloaded files -------------------------------------------------------------------------------} -class DownloadedFile (down :: * -> *) where+class DownloadedFile (down :: Type -> Type) where -- | Verify a download file downloadedVerify :: down a -> Trusted FileInfo -> IO Bool @@ -359,17 +381,11 @@ -- -- For instance, for repositories using HTTP this might correspond to a 404; -- for local repositories this might correspond to file-not-found, etc.-data SomeRemoteError :: * where+data SomeRemoteError :: Type where SomeRemoteError :: Exception e => e -> SomeRemoteError- deriving (Typeable) -#if MIN_VERSION_base(4,8,0) deriving instance Show SomeRemoteError instance Exception SomeRemoteError where displayException = pretty-#else-instance Exception SomeRemoteError-instance Show SomeRemoteError where show = pretty-#endif instance Pretty SomeRemoteError where pretty (SomeRemoteError ex) = displayException ex@@ -402,7 +418,7 @@ -------------------------------------------------------------------------------} -- | Is a particular remote file cached?-data IsCached :: * -> * where+data IsCached :: Type -> Type where -- This remote file should be cached, and we ask for it by name CacheAs :: CachedFile -> IsCached Metadata @@ -451,6 +467,12 @@ "Cannot update " ++ pretty file ++ " (" ++ pretty ex ++ ")" pretty (LogMirrorFailed mirror ex) = "Exception " ++ displayException ex ++ " when using mirror " ++ mirror+ pretty (LogLockWait file) =+ "Waiting to acquire cache lock on " ++ pretty file+ pretty (LogLockWaitDone file) =+ "Acquired cache lock on " ++ pretty file+ pretty (LogUnlock file) =+ "Released cache lock on " ++ pretty file instance Pretty UpdateFailure where pretty UpdateImpossibleUnsupported =
src/Hackage/Security/Client/Repository/Cache.hs view
@@ -12,13 +12,15 @@ , getIndexIdx , cacheRemoteFile , lockCache+ , lockCacheWithLogger ) where +import Prelude import Control.Exception import Control.Monad import Control.Monad.IO.Class import Data.Maybe-import Codec.Archive.Tar (Entries(..))+import Codec.Archive.Tar (Entries, pattern Done, pattern Fail, pattern Next) import Codec.Archive.Tar.Index (TarIndex, IndexBuilder, TarEntryOffset) import qualified Codec.Archive.Tar as Tar import qualified Codec.Archive.Tar.Index as TarIndex@@ -214,7 +216,18 @@ -- This avoids two concurrent processes updating the cache at the same time, -- provided they both take the lock. lockCache :: Cache -> IO () -> IO ()-lockCache Cache{..} = withDirLock cacheRoot+lockCache Cache{..} = withDirLock (\_ -> return ()) cacheRoot++-- | Variant of 'lockCache' which emits 'LogMessage's before and after+-- a possibly blocking file-locking system call+--+-- @since 0.6.0+lockCacheWithLogger :: (LogMessage -> IO ()) -> Cache -> IO () -> IO ()+lockCacheWithLogger logger Cache{..} = withDirLock logger' cacheRoot+ where+ logger' (WithDirLockEventPre fn) = logger (LogLockWait fn)+ logger' (WithDirLockEventPost fn) = logger (LogLockWaitDone fn)+ logger' (WithDirLockEventUnlock fn) = logger (LogUnlock fn) {------------------------------------------------------------------------------- Auxiliary: tar
src/Hackage/Security/Client/Repository/HttpLib.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} -- | Abstracting over HTTP libraries module Hackage.Security.Client.Repository.HttpLib ( HttpLib(..)@@ -11,6 +10,7 @@ , bodyReaderFromBS ) where +import Prelude import Data.IORef import Network.URI hiding (uriPath, path) import qualified Data.ByteString as BS@@ -44,7 +44,7 @@ -- HTTP servers are normally expected to respond to a range request with -- a "206 Partial Content" response. However, servers can respond with a -- "200 OK" response, sending the entire file instead (for instance, this- -- may happen for servers that don't actually support range rqeuests, but+ -- may happen for servers that don't actually support range requests, but -- for which we optimistically assumed they did). Implementations of -- 'HttpLib' may accept such a response and inform the @hackage-security@ -- library that the whole file is being returned; the security library can
src/Hackage/Security/Client/Repository/Local.hs view
@@ -5,6 +5,7 @@ , withRepository ) where +import Prelude import Hackage.Security.Client.Formats import Hackage.Security.Client.Repository import Hackage.Security.Client.Repository.Cache@@ -51,7 +52,7 @@ , repClearCache = clearCache cache , repWithIndex = withIndex cache , repGetIndexIdx = getIndexIdx cache- , repLockCache = lockCache cache+ , repLockCache = lockCacheWithLogger logger cache , repWithMirror = mirrorsUnsupported , repLog = logger , repLayout = repLayout
src/Hackage/Security/Client/Repository/Remote.hs view
@@ -27,11 +27,13 @@ , fileSizeWithinBounds ) where +import Prelude import Control.Concurrent import Control.Exception-import Control.Monad.Cont+import Control.Monad (when, unless)+import Control.Monad.IO.Class (MonadIO)+import Data.Kind (Type) import Data.List (nub, intercalate)-import Data.Typeable import Network.URI hiding (uriPath, path) import System.IO () import qualified Data.ByteString as BS@@ -178,7 +180,7 @@ , repClearCache = Cache.clearCache cache , repWithIndex = Cache.withIndex cache , repGetIndexIdx = Cache.getIndexIdx cache- , repLockCache = Cache.lockCache cache+ , repLockCache = Cache.lockCacheWithLogger logger cache , repWithMirror = withMirror httpLib selectedMirror logger@@ -236,7 +238,7 @@ -- error we want to make sure caches get files upstream in case the validation -- error was because the cache updated files out of order. httpRequestHeaders :: RemoteConfig -> AttemptNr -> [HttpRequestHeader]-httpRequestHeaders RemoteConfig{..} attemptNr =+httpRequestHeaders RemoteConfig{} attemptNr = if attemptNr == 0 then defaultHeaders else HttpRequestMaxAge0 : defaultHeaders where@@ -254,7 +256,7 @@ -> Maybe [Mirror] -- ^ TUF mirrors -> IO a -- ^ Callback -> IO a-withMirror HttpLib{..}+withMirror HttpLib{} selectedMirror logger oobMirrors@@ -298,7 +300,7 @@ -------------------------------------------------------------------------------} -- | Download method (downloading or updating)-data DownloadMethod :: * -> * -> * where+data DownloadMethod :: Type -> Type -> Type where -- Download this file (we never attempt to update this type of file) NeverUpdated :: { neverUpdatedFormat :: HasFormat fs f@@ -336,7 +338,7 @@ unless rangeSupport $ exit $ CannotUpdate hasGz UpdateImpossibleUnsupported -- We must already have a local file to be updated- mCachedIndex <- lift $ Cache.getCachedIndex cfgCache (hasFormatGet hasGz)+ mCachedIndex <- liftIO $ Cache.getCachedIndex cfgCache (hasFormatGet hasGz) cachedIndex <- case mCachedIndex of Nothing -> exit $ CannotUpdate hasGz UpdateImpossibleNoLocalCopy Just fp -> return fp@@ -483,7 +485,6 @@ fileTooLargePath :: TargetPath , fileTooLargeExpected :: FileSize }- deriving (Typeable) instance Pretty FileTooLarge where pretty FileTooLarge{..} = concat [@@ -496,13 +497,8 @@ expected (FileSizeExact n) = "exactly " ++ show n expected (FileSizeBound n) = "at most " ++ show n -#if MIN_VERSION_base(4,8,0) deriving instance Show FileTooLarge instance Exception FileTooLarge where displayException = pretty-#else-instance Exception FileTooLarge-instance Show FileTooLarge where show = pretty-#endif {------------------------------------------------------------------------------- Information about remote files@@ -598,7 +594,7 @@ Files downloaded from the remote repository -------------------------------------------------------------------------------} -data RemoteTemp :: * -> * where+data RemoteTemp :: Type -> Type where DownloadedWhole :: { wholeTemp :: Path Absolute } -> RemoteTemp a@@ -685,4 +681,3 @@ BS.L.take (fromIntegral deltaSeek) existing , temp ]-
src/Hackage/Security/Client/Verify.hs view
@@ -10,8 +10,11 @@ , liftIO ) where +import Prelude import Control.Exception-import Control.Monad.Reader+import Control.Monad (join, void)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Reader (ReaderT, runReaderT, ask) import Data.IORef import Hackage.Security.Util.IO
src/Hackage/Security/JSON.hs view
@@ -38,12 +38,13 @@ , module Hackage.Security.Util.JSON ) where +import Prelude import Control.Arrow (first, second) import Control.Exception-import Control.Monad.Except-import Control.Monad.Reader+import Control.Monad (unless, liftM)+import Control.Monad.Except (MonadError, Except, ExceptT, runExcept, runExceptT, throwError)+import Control.Monad.Reader (MonadReader, Reader, runReader, local, ask) import Data.Functor.Identity-import Data.Typeable (Typeable) import qualified Data.ByteString.Lazy as BS.L import Hackage.Security.Key@@ -80,15 +81,9 @@ -- -- Records actual and expected types. | DeserializationErrorFileType String String- deriving (Typeable) -#if MIN_VERSION_base(4,8,0) deriving instance Show DeserializationError instance Exception DeserializationError where displayException = pretty-#else-instance Show DeserializationError where show = pretty-instance Exception DeserializationError-#endif instance Pretty DeserializationError where pretty (DeserializationErrorMalformed str) =
src/Hackage/Security/Key.hs view
@@ -25,9 +25,9 @@ , verify ) where +import Prelude import Control.Monad import Data.Functor.Identity-import Data.Typeable (Typeable) import Text.JSON.Canonical import qualified Crypto.Hash.SHA256 as SHA256 import qualified Crypto.Sign.Ed25519 as Ed25519@@ -36,10 +36,6 @@ import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Lazy as BS.L -#if !MIN_VERSION_base(4,7,0)-import qualified Data.Typeable as Typeable-#endif- import Hackage.Security.Util.JSON import Hackage.Security.Util.Some import Hackage.Security.Util.TypedEmbedded@@ -53,15 +49,12 @@ data Key a where KeyEd25519 :: Ed25519.PublicKey -> Ed25519.SecretKey -> Key Ed25519- deriving (Typeable) data PublicKey a where PublicKeyEd25519 :: Ed25519.PublicKey -> PublicKey Ed25519- deriving (Typeable) data PrivateKey a where PrivateKeyEd25519 :: Ed25519.SecretKey -> PrivateKey Ed25519- deriving (Typeable) deriving instance Show (Key typ) deriving instance Show (PublicKey typ)@@ -144,8 +137,8 @@ -- | The key ID of a key, by definition, is the hexdigest of the SHA-256 hash of -- the canonical JSON form of the key where the private object key is excluded. ----- NOTE: The FromJSON and ToJSON instances for KeyId are ntentially omitted. Use--- writeKeyAsId instead.+-- NOTE: The FromJSON and ToJSON instances for KeyId are intentionally omitted.+-- Use writeKeyAsId instead. newtype KeyId = KeyId { keyIdString :: String } deriving (Show, Eq, Ord) @@ -276,26 +269,3 @@ case tag of "ed25519" -> return . Some $ KeyTypeEd25519 _otherwise -> expected "valid key type" (Just tag)--{-------------------------------------------------------------------------------- Orphans-- Pre-7.8 (base 4.7) we cannot have Typeable instance for higher-kinded types.- Instead, here we provide some instance for specific instantiations.--------------------------------------------------------------------------------}--#if !MIN_VERSION_base(4,7,0)-tyConKey, tyConPublicKey, tyConPrivateKey :: Typeable.TyCon-tyConKey = Typeable.mkTyCon3 "hackage-security" "Hackage.Security.Key" "Key"-tyConPublicKey = Typeable.mkTyCon3 "hackage-security" "Hackage.Security.Key" "PublicKey"-tyConPrivateKey = Typeable.mkTyCon3 "hackage-security" "Hackage.Security.Key" "PrivateKey"--instance Typeable (Some Key) where- typeOf _ = Typeable.mkTyConApp tyConSome [Typeable.mkTyConApp tyConKey []]--instance Typeable (Some PublicKey) where- typeOf _ = Typeable.mkTyConApp tyConSome [Typeable.mkTyConApp tyConPublicKey []]--instance Typeable (Some PrivateKey) where- typeOf _ = Typeable.mkTyConApp tyConSome [Typeable.mkTyConApp tyConPrivateKey []]-#endif
src/Hackage/Security/TUF/Common.hs view
@@ -6,6 +6,7 @@ , KeyThreshold(..) ) where +import Prelude import Hackage.Security.JSON {-------------------------------------------------------------------------------
src/Hackage/Security/TUF/FileMap.hs view
@@ -13,8 +13,6 @@ , (!) , insert , fromList- -- * Convenience accessors- , lookupM -- * Comparing file maps , FileChange(..) , fileMapChanges@@ -70,16 +68,6 @@ fromList :: [(TargetPath, FileInfo)] -> FileMap fromList = FileMap . Map.fromList--{-------------------------------------------------------------------------------- Convenience accessors--------------------------------------------------------------------------------}--lookupM :: Monad m => FileMap -> TargetPath -> m FileInfo-lookupM m fp =- case lookup fp m of- Nothing -> fail $ "No entry for " ++ pretty fp ++ " in filemap"- Just nfo -> return nfo {------------------------------------------------------------------------------- Comparing filemaps
src/Hackage/Security/TUF/Header.hs view
@@ -12,8 +12,8 @@ , versionIncrement ) where +import Prelude import Data.Time-import Data.Typeable (Typeable) import Hackage.Security.JSON import Hackage.Security.Util.Lens@@ -35,9 +35,9 @@ -- every file update. -- -- 'Show' and 'Read' instance are defined in terms of the underlying 'Int'--- (this is use for example by hackage during the backup process).+-- (this is used for example by Hackage during the backup process). newtype FileVersion = FileVersion Int54- deriving (Eq, Ord, Typeable)+ deriving (Eq, Ord) instance Show FileVersion where show (FileVersion v) = show v@@ -52,9 +52,9 @@ -- allows that, because you could set an expiry date 2000 years into the future. -- By having the Maybe here we avoid the _need_ for such encoding issues.) newtype FileExpires = FileExpires (Maybe UTCTime)- deriving (Eq, Ord, Show, Typeable)+ deriving (Eq, Ord, Show) --- | Occassionally it is useful to read only a header from a file.+-- | Occasionally it is useful to read only a header from a file. -- -- 'HeaderOnly' intentionally only has a 'FromJSON' instance (no 'ToJSON'). data Header = Header {
src/Hackage/Security/TUF/Layout/Cache.hs view
@@ -4,6 +4,7 @@ , cabalCacheLayout ) where +import Prelude import Hackage.Security.TUF.Paths import Hackage.Security.Util.Path @@ -14,7 +15,7 @@ -- | Location of the various files we cache -- -- Although the generic TUF algorithms do not care how we organize the cache,--- we nonetheless specity this here because as long as there are tools which+-- we nonetheless specify this here because as long as there are tools which -- access files in the cache directly we need to define the cache layout. -- See also comments for 'defaultCacheLayout'. data CacheLayout = CacheLayout {
src/Hackage/Security/TUF/Layout/Index.hs view
@@ -9,6 +9,8 @@ , indexLayoutPkgPrefs ) where +import Prelude+import Data.Kind (Type) import Distribution.Package import Distribution.Text @@ -42,7 +44,7 @@ -- TODO: If we wanted to support legacy Hackage, we should also have a case for -- the global preferred-versions file. But supporting legacy Hackage will -- probably require more work anyway..-data IndexFile :: * -> * where+data IndexFile :: Type -> Type where -- Package-specific metadata (@targets.json@) IndexPkgMetadata :: PackageIdentifier -> IndexFile (Signed Targets)
src/Hackage/Security/TUF/Layout/Repo.hs view
@@ -5,6 +5,7 @@ , cabalLocalRepoLayout ) where +import Prelude import Distribution.Package import Distribution.Text
src/Hackage/Security/TUF/Mirrors.hs view
@@ -9,6 +9,7 @@ , describeMirror ) where +import Prelude import Control.Monad.Except import Network.URI
src/Hackage/Security/TUF/Paths.hs view
@@ -14,6 +14,7 @@ , anchorCachePath ) where +import Prelude import Hackage.Security.Util.Path import Hackage.Security.Util.Pretty
src/Hackage/Security/TUF/Patterns.hs view
@@ -1,13 +1,10 @@ -- | Patterns and replacements -- -- NOTE: This module was developed to prepare for proper delegation (#39).--- It is currently unusued.-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 800-{-# LANGUAGE TemplateHaskellQuotes #-}-#else-{-# LANGUAGE TemplateHaskell #-}-#endif+-- It is currently unused.+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE StandaloneDeriving #-}+ module Hackage.Security.TUF.Patterns ( -- * Patterns and replacements FileName@@ -25,7 +22,8 @@ , qqd ) where -import Control.Monad.Except+import Prelude+import Control.Monad (guard) import Language.Haskell.TH (Q, Exp) import System.FilePath.Posix import qualified Language.Haskell.TH.Syntax as TH@@ -128,8 +126,8 @@ go [] _ = Nothing go [f] (PatFileConst f') = do guard (f == f') return ()- go [f] (PatFileExt e') = do let (bn, _:e) = splitExtension f- guard $ e == e'+ go [f] (PatFileExt e') = do let (bn, dotExt) = splitExtension f+ guard $ dotExt == '.':e' return (bn :- ()) go [_] _ = Nothing go (d:p) (PatDirConst d' p') = do guard (d == d')@@ -272,22 +270,9 @@ Left err -> fail $ "Invalid delegation: " ++ err Right del -> TH.lift del -instance TH.Lift (Pattern a) where- lift (PatFileConst fn) = [| PatFileConst fn |]- lift (PatFileExt e) = [| PatFileExt e |]- lift PatFileAny = [| PatFileAny |]- lift (PatDirConst d p) = [| PatDirConst d p |]- lift (PatDirAny p) = [| PatDirAny p |]--instance TH.Lift (Replacement a) where- lift (RepFileConst fn) = [| RepFileConst fn |]- lift (RepFileExt e ) = [| RepFileExt e |]- lift RepFileAny = [| RepFileAny |]- lift (RepDirConst d r) = [| RepDirConst d r |]- lift (RepDirAny r) = [| RepDirAny r |]--instance TH.Lift Delegation where- lift (Delegation pat repl) = [| Delegation pat repl |]+deriving instance TH.Lift (Pattern a)+deriving instance TH.Lift (Replacement a)+deriving instance TH.Lift Delegation {------------------------------------------------------------------------------- JSON@@ -338,9 +323,8 @@ ) _ex2 :: Maybe String-_ex2 = matchDelegation del "A/x/y/z.foo"- where- Right del = parseDelegation "A/*/*/*.foo" "B/*/C/*/*.bar"+_ex2 = either undefined (`matchDelegation` "A/x/y/z.foo")+ (parseDelegation "A/*/*/*.foo" "B/*/C/*/*.bar") _ex3 :: Either String Delegation _ex3 = parseDelegation "foo" "*/bar"
src/Hackage/Security/TUF/Root.hs view
@@ -6,6 +6,7 @@ , RoleSpec(..) ) where +import Prelude import Hackage.Security.JSON import Hackage.Security.Key import Hackage.Security.Key.Env (KeyEnv)
src/Hackage/Security/TUF/Signed.hs view
@@ -27,6 +27,7 @@ , toPreSignatures ) where +import Prelude import Control.Monad import Data.Functor.Identity import qualified Data.ByteString as BS
src/Hackage/Security/TUF/Snapshot.hs view
@@ -3,6 +3,7 @@ Snapshot(..) ) where +import Prelude import Control.Monad.Except import Control.Monad.Reader @@ -13,6 +14,7 @@ import Hackage.Security.TUF.Layout.Repo import Hackage.Security.TUF.Signed import qualified Hackage.Security.TUF.FileMap as FileMap+import Hackage.Security.Util.Pretty (pretty) {------------------------------------------------------------------------------- Datatypes@@ -76,9 +78,12 @@ snapshotVersion <- fromJSField enc "version" snapshotExpires <- fromJSField enc "expires" snapshotMeta <- fromJSField enc "meta"- snapshotInfoRoot <- FileMap.lookupM snapshotMeta (pathRoot repoLayout)- snapshotInfoMirrors <- FileMap.lookupM snapshotMeta (pathMirrors repoLayout)- snapshotInfoTarGz <- FileMap.lookupM snapshotMeta (pathIndexTarGz repoLayout)+ let lookupMeta k = case FileMap.lookup k snapshotMeta of+ Nothing -> expected ("\"" ++ pretty k ++ "\" entry in .meta object") Nothing+ Just v -> pure v+ snapshotInfoRoot <- lookupMeta (pathRoot repoLayout)+ snapshotInfoMirrors <- lookupMeta (pathMirrors repoLayout)+ snapshotInfoTarGz <- lookupMeta (pathIndexTarGz repoLayout) let snapshotInfoTar = FileMap.lookup (pathIndexTar repoLayout) snapshotMeta return Snapshot{..}
src/Hackage/Security/TUF/Targets.hs view
@@ -8,6 +8,7 @@ , targetsLookup ) where +import Prelude import Hackage.Security.JSON import Hackage.Security.Key import Hackage.Security.Key.Env (KeyEnv)
src/Hackage/Security/TUF/Timestamp.hs view
@@ -3,6 +3,7 @@ Timestamp(..) ) where +import Prelude import Control.Monad.Except import Control.Monad.Reader @@ -13,6 +14,7 @@ import Hackage.Security.TUF.Layout.Repo import Hackage.Security.TUF.Signed import qualified Hackage.Security.TUF.FileMap as FileMap+import Hackage.Security.Util.Pretty (pretty) {------------------------------------------------------------------------------- Datatypes@@ -56,7 +58,10 @@ timestampVersion <- fromJSField enc "version" timestampExpires <- fromJSField enc "expires" timestampMeta <- fromJSField enc "meta"- timestampInfoSnapshot <- FileMap.lookupM timestampMeta (pathSnapshot repoLayout)+ let lookupMeta k = case FileMap.lookup k timestampMeta of+ Nothing -> expected ("\"" ++ pretty k ++ "\" entry in .meta object") Nothing+ Just v -> pure v+ timestampInfoSnapshot <- lookupMeta (pathSnapshot repoLayout) return Timestamp{..} instance (MonadKeys m, MonadReader RepoLayout m) => FromJSON m (Signed Timestamp) where
src/Hackage/Security/Trusted.hs view
@@ -1,7 +1,5 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE StaticPointers #-}-#endif+ module Hackage.Security.Trusted ( module Hackage.Security.Trusted.TCB -- * Derived functions@@ -12,6 +10,7 @@ , trustedFileInfoEqual ) where +import Prelude import Data.Function (on) import Data.Time import Hackage.Security.TUF
src/Hackage/Security/Trusted/TCB.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} module Hackage.Security.Trusted.TCB ( -- * Trusted values Trusted(DeclareTrusted)@@ -16,19 +15,14 @@ , signaturesVerified , verifyRole' , verifyFingerprints-#if __GLASGOW_HASKELL__ >= 710 -- * Re-exports , StaticPtr-#else- -- * Fake static pointers- , StaticPtr- , static-#endif ) where +import Prelude import Control.Exception-import Control.Monad.Except-import Data.Typeable+import Control.Monad (when, unless)+import Control.Monad.Except (Except, runExcept, throwError) import Data.Time import Hackage.Security.TUF import Hackage.Security.JSON@@ -36,18 +30,8 @@ import Hackage.Security.Util.Pretty import qualified Hackage.Security.Util.Lens as Lens -#if __GLASGOW_HASKELL__ >= 710 import GHC.StaticPtr-#else--- Fake static pointers for ghc < 7.10. This means Trusted offers no--- additional type safety, but that's okay: we can still verify the code--- with ghc 7.10 and get the additional checks.-newtype StaticPtr a = StaticPtr { deRefStaticPtr :: a } -static :: a -> StaticPtr a-static = StaticPtr-#endif- -- | Trusted values -- -- Trusted values originate in only two ways:@@ -165,7 +149,10 @@ -- | Errors thrown during role validation data VerificationError = -- | Not enough signatures signed with the appropriate keys- VerificationErrorSignatures TargetPath+ VerificationErrorSignatures TargetPath -- what were we verifying?+ Integer -- threshold+ [KeyId] -- trusted keys+ [KeyId] -- found signing keys -- | The file is expired | VerificationErrorExpired TargetPath@@ -196,29 +183,27 @@ -- -- We record all verification errors that occurred before we gave up. | VerificationErrorLoop VerificationHistory- deriving (Typeable) -- | Root metadata updated (as part of the normal update process) data RootUpdated = RootUpdated- deriving (Typeable) type VerificationHistory = [Either RootUpdated VerificationError] -#if MIN_VERSION_base(4,8,0) deriving instance Show VerificationError deriving instance Show RootUpdated instance Exception VerificationError where displayException = pretty instance Exception RootUpdated where displayException = pretty-#else-instance Exception VerificationError-instance Show VerificationError where show = pretty-instance Show RootUpdated where show = pretty-instance Exception RootUpdated-#endif +indentedLines :: [String] -> String+indentedLines = unlines . map (" " ++)+ instance Pretty VerificationError where- pretty (VerificationErrorSignatures file) =- pretty file ++ " does not have enough signatures signed with the appropriate keys"+ pretty (VerificationErrorSignatures file threshold trusted sigs) =+ pretty file ++ " does not have enough signatures signed with the appropriate keys\n"+ ++ "Expected at least " ++ show threshold ++ " signatures from:\n"+ ++ indentedLines (map keyIdString trusted)+ ++ "Found signatures from:\n"+ ++ indentedLines (map keyIdString sigs) pretty (VerificationErrorExpired file) = pretty file ++ " is expired" pretty (VerificationErrorVersion file) =@@ -233,7 +218,7 @@ "Could not deserialize " ++ pretty file ++ ": " ++ pretty err pretty (VerificationErrorLoop es) = "Verification loop. Errors in order:\n"- ++ unlines (map ((" " ++) . either pretty pretty) es)+ ++ indentedLines (map (either pretty pretty) es) instance Pretty RootUpdated where pretty RootUpdated = "Root information updated"@@ -289,8 +274,9 @@ -- was invalid we would already have thrown an error constructing Signed. -- (Similarly, if two signatures were made by the same key, the FromJSON -- instance for Signatures would have thrown an error.)- unless (length (filter isRoleSpecKey sigs) >= fromIntegral threshold) $- throwError $ VerificationErrorSignatures targetPath+ let nSigs = length (filter isRoleSpecKey sigs)+ unless (nSigs >= fromIntegral threshold) $+ throwError $ VerificationErrorSignatures targetPath (fromIntegral threshold) trustedKeys signingKeys -- Everything is A-OK! return $ SignaturesVerified signed@@ -298,6 +284,10 @@ isRoleSpecKey :: Signature -> Bool isRoleSpecKey Signature{..} = signatureKey `elem` roleSpecKeys + trustedKeys, signingKeys :: [KeyId]+ trustedKeys = map someKeyId roleSpecKeys+ signingKeys = map (someKeyId . signatureKey) sigs+ -- | Variation on 'verifyRole' that uses key IDs rather than keys -- -- This is used during the bootstrap process.@@ -312,9 +302,12 @@ (KeyThreshold threshold) targetPath Signed{signatures = Signatures sigs, ..} =- if length (filter isTrustedKey sigs) >= fromIntegral threshold+ if length (filter isTrustedKey signingKeys) >= fromIntegral threshold then Right $ SignaturesVerified signed- else Left $ VerificationErrorSignatures targetPath+ else Left $ VerificationErrorSignatures targetPath (fromIntegral threshold) fingerprints signingKeys where- isTrustedKey :: Signature -> Bool- isTrustedKey Signature{..} = someKeyId signatureKey `elem` fingerprints+ signingKeys :: [KeyId]+ signingKeys = map (someKeyId . signatureKey) sigs++ isTrustedKey :: KeyId -> Bool+ isTrustedKey key = key `elem` fingerprints
src/Hackage/Security/Util/Base64.hs view
@@ -4,6 +4,7 @@ , toByteString ) where +import Prelude import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as C8 -- only called on B64-enc strings import qualified Data.ByteString.Base64 as B64
src/Hackage/Security/Util/Checked.hs view
@@ -1,15 +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 #-} {-# LANGUAGE IncoherentInstances #-}-#endif+{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE DeriveDataTypeable#-}+{-# OPTIONS_GHC -Wno-unused-binds #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- | Checked exceptions module Hackage.Security.Util.Checked (@@ -25,15 +18,11 @@ , internalError ) where +import Prelude import Control.Exception (Exception, IOException) import qualified Control.Exception as Base-import Data.Typeable (Typeable) -#if __GLASGOW_HASKELL__ >= 708 import GHC.Prim (coerce)-#else-import Unsafe.Coerce (unsafeCoerce)-#endif {------------------------------------------------------------------------------- Basic infrastructure@@ -42,9 +31,7 @@ -- | Checked exceptions class Throws e where -#if __GLASGOW_HASKELL__ >= 708 type role Throws representational-#endif unthrow :: forall a e proxy . proxy e -> (Throws e => a) -> a unthrow _ x = unWrap (coerceWrap (Wrap x :: Wrap e a))@@ -55,22 +42,10 @@ -- | Determine if an exception is asynchronous, based on its type. isAsync :: Exception e => e -> Bool-#if MIN_VERSION_base(4, 7, 0) isAsync e = case Base.fromException $ Base.toException e of Just Base.SomeAsyncException{} -> True Nothing -> False-#else--- Earlier versions of GHC had no SomeAsyncException. We have to--- instead make up a list of async exceptions.-isAsync e =- let se = Base.toException e- in case () of- ()- | Just (_ :: Base.AsyncException) <- Base.fromException se -> True- | show e == "<<timeout>>" -> True- | otherwise -> False-#endif -- | 'Base.catch', but immediately rethrows asynchronous exceptions -- (as determined by 'isAsync').@@ -82,7 +57,7 @@ -- | Wraps up an async exception as a synchronous exception. newtype SyncException = SyncException Base.SomeException- deriving (Show, Typeable)+ deriving (Show) instance Exception SyncException -- | Throw a checked exception@@ -130,11 +105,7 @@ newtype Wrap e a = Wrap { unWrap :: Throws e => a } coerceWrap :: Wrap e a -> Wrap (Catch e) a-#if __GLASGOW_HASKELL__ >= 708 coerceWrap = coerce-#else-coerceWrap = unsafeCoerce-#endif data Proxy a = Proxy
src/Hackage/Security/Util/Exit.hs view
@@ -1,6 +1,8 @@ module Hackage.Security.Util.Exit where -import Control.Monad.Except+import Prelude+import Control.Monad (liftM)+import Control.Monad.Except (ExceptT, runExceptT, throwError) {------------------------------------------------------------------------------- Auxiliary: multiple exit points
− src/Hackage/Security/Util/FileLock.hsc
@@ -1,202 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE InterruptibleFFI #-}-{-# LANGUAGE DeriveDataTypeable #-}---- | This compat module can be removed once base-4.10 (ghc-8.2) is the minimum--- required version. Though note that the locking functionality is not in--- public modules in base-4.10, just in the "GHC.IO.Handle.Lock" module.------ Copied from @cabal-install@ codebase "Distribution.Client.Compat.FileLock".-module Hackage.Security.Util.FileLock (- FileLockingNotSupported(..)- , LockMode(..)- , hLock- , hTryLock- ) where--#if MIN_VERSION_base(4,10,0)--import GHC.IO.Handle.Lock--#else---- The remainder of this file is a modified copy--- of GHC.IO.Handle.Lock from ghc-8.2.x------ The modifications were just to the imports and the CPP, since we do not have--- access to the HAVE_FLOCK from the ./configure script. We approximate the--- lack of HAVE_FLOCK with @defined(solaris2_HOST_OS) || defined(aix_HOST_OS)@--- instead since those are known major Unix platforms lacking @flock()@ or--- having broken one.--import Control.Exception (Exception)-import Data.Typeable--#if defined(solaris2_HOST_OS) || defined(aix_HOST_OS)--import Control.Exception (throwIO)-import System.IO (Handle)--#else--import Data.Bits-import Data.Function-import Control.Concurrent.MVar--import Foreign.C.Error-import Foreign.C.Types--import GHC.IO.Handle.Types-import GHC.IO.FD-import GHC.IO.Exception--#if defined(mingw32_HOST_OS)--#if defined(i386_HOST_ARCH)-## define WINDOWS_CCONV stdcall-#elif defined(x86_64_HOST_ARCH)-## define WINDOWS_CCONV ccall-#else-# error Unknown mingw32 arch-#endif--#include <windows.h>--import Foreign.Marshal.Alloc-import Foreign.Marshal.Utils-import Foreign.Ptr-import GHC.Windows--#else /* !defined(mingw32_HOST_OS), so assume unix with flock() */--#include <sys/file.h>--#endif /* !defined(mingw32_HOST_OS) */--#endif /* !(defined(solaris2_HOST_OS) || defined(aix_HOST_OS)) */----- | Exception thrown by 'hLock' on non-Windows platforms that don't support--- 'flock'.-data FileLockingNotSupported = FileLockingNotSupported- deriving (Typeable, Show)--instance Exception FileLockingNotSupported----- | Indicates a mode in which a file should be locked.-data LockMode = SharedLock | ExclusiveLock---- | If a 'Handle' references a file descriptor, attempt to lock contents of the--- underlying file in appropriate mode. If the file is already locked in--- incompatible mode, this function blocks until the lock is established. The--- lock is automatically released upon closing a 'Handle'.------ Things to be aware of:------ 1) This function may block inside a C call. If it does, in order to be able--- to interrupt it with asynchronous exceptions and/or for other threads to--- continue working, you MUST use threaded version of the runtime system.------ 2) The implementation uses 'LockFileEx' on Windows and 'flock' otherwise,--- hence all of their caveats also apply here.------ 3) On non-Windows plaftorms that don't support 'flock' (e.g. Solaris) this--- function throws 'FileLockingNotImplemented'. We deliberately choose to not--- provide fcntl based locking instead because of its broken semantics.------ @since 4.10.0.0-hLock :: Handle -> LockMode -> IO ()-hLock h mode = lockImpl h "hLock" mode True >> return ()---- | Non-blocking version of 'hLock'.------ @since 4.10.0.0-hTryLock :: Handle -> LockMode -> IO Bool-hTryLock h mode = lockImpl h "hTryLock" mode False--------------------------------------------#if defined(solaris2_HOST_OS) || defined(aix_HOST_OS)---- | No-op implementation.-lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool-lockImpl _ _ _ _ = throwIO FileLockingNotSupported--#else /* !(defined(solaris2_HOST_OS) || defined(aix_HOST_OS)) */--#if defined(mingw32_HOST_OS)--lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool-lockImpl h ctx mode block = do- FD{fdFD = fd} <- handleToFd h- wh <- throwErrnoIf (== iNVALID_HANDLE_VALUE) ctx $ c_get_osfhandle fd- allocaBytes sizeof_OVERLAPPED $ \ovrlpd -> do- fillBytes ovrlpd (fromIntegral sizeof_OVERLAPPED) 0- let flags = cmode .|. (if block then 0 else #{const LOCKFILE_FAIL_IMMEDIATELY})- -- We want to lock the whole file without looking up its size to be- -- consistent with what flock does. According to documentation of LockFileEx- -- "locking a region that goes beyond the current end-of-file position is- -- not an error", however e.g. Windows 10 doesn't accept maximum possible- -- value (a pair of MAXDWORDs) for mysterious reasons. Work around that by- -- trying 2^32-1.- fix $ \retry -> c_LockFileEx wh flags 0 0xffffffff 0x0 ovrlpd >>= \b -> case b of- True -> return True- False -> getLastError >>= \err -> case () of- () | not block && err == #{const ERROR_LOCK_VIOLATION} -> return False- | err == #{const ERROR_OPERATION_ABORTED} -> retry- | otherwise -> failWith ctx err- where- sizeof_OVERLAPPED = #{size OVERLAPPED}-- cmode = case mode of- SharedLock -> 0- ExclusiveLock -> #{const LOCKFILE_EXCLUSIVE_LOCK}---- https://msdn.microsoft.com/en-us/library/aa297958.aspx-foreign import ccall unsafe "_get_osfhandle"- c_get_osfhandle :: CInt -> IO HANDLE---- https://msdn.microsoft.com/en-us/library/windows/desktop/aa365203.aspx-foreign import WINDOWS_CCONV interruptible "LockFileEx"- c_LockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> DWORD -> Ptr () -> IO BOOL--#else /* !defined(mingw32_HOST_OS), so assume unix with flock() */--lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool-lockImpl h ctx mode block = do- FD{fdFD = fd} <- handleToFd h- let flags = cmode .|. (if block then 0 else #{const LOCK_NB})- fix $ \retry -> c_flock fd flags >>= \n -> case n of- 0 -> return True- _ -> getErrno >>= \errno -> case () of- () | not block && errno == eWOULDBLOCK -> return False- | errno == eINTR -> retry- | otherwise -> ioException $ errnoToIOError ctx errno (Just h) Nothing- where- cmode = case mode of- SharedLock -> #{const LOCK_SH}- ExclusiveLock -> #{const LOCK_EX}--foreign import ccall interruptible "flock"- c_flock :: CInt -> CInt -> IO CInt--#endif /* !defined(mingw32_HOST_OS) */---- | Turn an existing Handle into a file descriptor. This function throws an--- IOError if the Handle does not reference a file descriptor.-handleToFd :: Handle -> IO FD-handleToFd h = case h of- FileHandle _ mv -> do- Handle__{haDevice = dev} <- readMVar mv- case cast dev of- Just fd -> return fd- Nothing -> throwErr "not a file descriptor"- DuplexHandle{} -> throwErr "not a file handle"- where- throwErr msg = ioException $ IOError (Just h)- InappropriateType "handleToFd" msg Nothing Nothing--#endif /* defined(solaris2_HOST_OS) || defined(aix_HOST_OS) */--#endif /* MIN_VERSION_base */
src/Hackage/Security/Util/IO.hs view
@@ -2,20 +2,23 @@ -- * Miscelleneous getFileSize , handleDoesNotExist+ , WithDirLockEvent(..) , withDirLock -- * Debugging , timedIO ) where -import Control.Monad (unless)+import Prelude+import Control.Concurrent (threadDelay) import Control.Exception import Data.Time import System.IO hiding (openTempFile, withFile) import System.IO.Error import Hackage.Security.Util.Path-import Hackage.Security.Util.FileLock (hTryLock, LockMode(ExclusiveLock), FileLockingNotSupported) +import GHC.IO.Handle.Lock (hLock, hUnlock, LockMode(ExclusiveLock), FileLockingNotSupported)+ {------------------------------------------------------------------------------- Miscelleneous -------------------------------------------------------------------------------}@@ -32,21 +35,32 @@ then return Nothing else throwIO e ++data WithDirLockEvent+ = WithDirLockEventPre (Path Absolute)+ | WithDirLockEventPost (Path Absolute)+ | WithDirLockEventUnlock (Path Absolute)+ -- | Attempt to create a filesystem lock in the specified directory. -- -- This will use OS-specific file locking primitives: "GHC.IO.Handle.Lock" with -- @base-4.10" and later or a shim for @base@ versions. ----- Throws an exception if the lock is already present.+-- Blocks if the lock is already present. --+-- The logger callback passed as first argument is invoked before and+-- after acquiring a lock, and after unlocking.+-- -- May fallback to locking via creating a directory: -- Given a file @/path/to@, we do this by attempting to create the directory -- @//path/to/hackage-security-lock@, and deleting the directory again -- afterwards. Creating a directory that already exists will throw an exception -- on most OSs (certainly Linux, OSX and Windows) and is a reasonably common way -- to implement a lock file.-withDirLock :: Path Absolute -> IO a -> IO a-withDirLock dir = bracket takeLock releaseLock . const+withDirLock :: (WithDirLockEvent -> IO ()) -> Path Absolute -> IO a -> IO a+withDirLock logger dir+ = bracket takeLock (\h -> releaseLock h >> logger (WithDirLockEventUnlock lock))+ . const where lock :: Path Absolute lock = dir </> fragment "hackage-security-lock"@@ -54,28 +68,47 @@ lock' :: FilePath lock' = toFilePath lock + me = "Hackage.Security.Util.IO.withDirLock: "++ wrapLog :: IO a -> IO a+ wrapLog op = do+ logger (WithDirLockEventPre lock)+ h <- op+ logger (WithDirLockEventPost lock)+ return h+ takeLock = do h <- openFile lock' ReadWriteMode- handle (takeDirLock h) $ do- gotlock <- hTryLock h ExclusiveLock- unless gotlock $- fail $ "hTryLock: lock already exists: " ++ lock'+ wrapLog $ handle (fallbackToDirLock h) $ do+ hLock h ExclusiveLock return (Just h) - takeDirLock :: Handle -> FileLockingNotSupported -> IO (Maybe Handle)- takeDirLock h _ = do- -- We fallback to directory locking- -- so we need to cleanup lock file first: close and remove- hClose h- handle onIOError (removeFile lock)- createDirectory lock- return Nothing - onIOError :: IOError -> IO ()- onIOError _ = hPutStrLn stderr- "withDirLock: cannot remove lock file before directory lock fallback"+ -- If file locking isn't supported then we fallback to directory locking,+ -- polling if necessary.+ fallbackToDirLock :: Handle -> FileLockingNotSupported -> IO (Maybe Handle)+ fallbackToDirLock h _ = takeDirLock >> return Nothing+ where+ takeDirLock :: IO ()+ takeDirLock = do+ -- We fallback to directory locking+ -- so we need to cleanup lock file first: close and remove+ hClose h+ handle onIOError (removeFile lock)+ handle onCreateDirError (createDirectory lock) - releaseLock (Just h) = hClose h+ onCreateDirError :: IOError -> IO ()+ onCreateDirError ioe+ | isAlreadyExistsError ioe = threadDelay (1*1000*1000) >> takeDirLock+ | otherwise = fail (me++"error creating directory lock: "++show ioe)++ onIOError :: IOError -> IO ()+ onIOError _ = hPutStrLn stderr+ (me++"cannot remove lock file before directory lock fallback")++ releaseLock (Just h) =+ hUnlock h >>+ hClose h releaseLock Nothing = removeDirectory lock {-------------------------------------------------------------------------------
src/Hackage/Security/Util/JSON.hs view
@@ -1,7 +1,3 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ < 710-{-# LANGUAGE OverlappingInstances #-}-#endif -- | module Hackage.Security.Util.JSON ( -- * Type classes@@ -23,6 +19,7 @@ , Int54 ) where +import Prelude import Control.Monad (liftM) import Data.Maybe (catMaybes) import Data.Map (Map)@@ -31,10 +28,6 @@ import Network.URI import qualified Data.Map as Map -#if !MIN_VERSION_time(1,5,0)-import System.Locale (defaultTimeLocale)-#endif- import Hackage.Security.Util.Path {-------------------------------------------------------------------------------@@ -119,16 +112,12 @@ fromJSON val = expected' "int" val instance-#if __GLASGOW_HASKELL__ >= 710 {-# OVERLAPPABLE #-}-#endif (Monad m, ToJSON m a) => ToJSON m [a] where toJSON = liftM JSArray . mapM toJSON instance-#if __GLASGOW_HASKELL__ >= 710 {-# OVERLAPPABLE #-}-#endif (ReportSchemaErrors m, FromJSON m a) => FromJSON m [a] where fromJSON (JSArray as) = mapM fromJSON as fromJSON val = expected' "array" val@@ -142,10 +131,6 @@ case parseTimeM False defaultTimeLocale "%FT%TZ" str of Just time -> return time Nothing -> expected "valid date-time string" (Just str)-#if !MIN_VERSION_time(1,5,0)- where- parseTimeM _trim = parseTime-#endif instance ( Monad m , ToObjectKey m k
src/Hackage/Security/Util/Lens.hs view
@@ -7,13 +7,14 @@ -- * Generic definitions Lens , Lens'+ , Traversal+ , Traversal' , get- , modify+ , over , set- -- * Specific lenses- , lookupM ) where +import Prelude import Control.Applicative import Data.Functor.Identity @@ -22,27 +23,25 @@ -------------------------------------------------------------------------------} -- | Polymorphic lens-type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t+type Lens s t a b = forall f. Functor f => LensLike f s t a b -- | Monomorphic lens type Lens' s a = Lens s s a a -get :: Lens' s a -> s -> a-get l = getConst . l Const+-- | Polymorphic traversal+type Traversal s t a b = forall f. Applicative f => LensLike f s t a b -modify :: Lens s t a b -> (a -> b) -> s -> t-modify l f = runIdentity . l (Identity . f)+-- | Monomorphic traversal+type Traversal' s a = Traversal s s a a -set :: Lens s t a b -> b -> s -> t-set l = modify l . const+type LensLike f s t a b = (a -> f b) -> s -> f t+type LensLike' f s a = LensLike f s s a a -{-------------------------------------------------------------------------------- Specific lenses--------------------------------------------------------------------------------}+get :: LensLike' (Const a) s a -> s -> a+get l = getConst . l Const -lookupM :: forall a b. (Eq a, Monoid b) => a -> Lens' [(a, b)] b-lookupM a f = go- where- go [] = (\b' -> [(a, b')] ) <$> f mempty- go ((a', b):xs) | a == a' = (\b' -> (a, b'):xs ) <$> f b- | otherwise = (\xs' -> (a', b):xs') <$> go xs+over :: LensLike Identity s t a b -> (a -> b) -> s -> t+over l f = runIdentity . l (Identity . f)++set :: LensLike Identity s t a b -> b -> s -> t+set l = over l . const
src/Hackage/Security/Util/Path.hs view
@@ -7,7 +7,6 @@ -- -- Note that his module does not import any other modules from Hackage.Security; -- everywhere else we use Path instead of FilePath directly.-{-# LANGUAGE CPP #-} module Hackage.Security.Util.Path ( -- * Paths Path(..)@@ -72,6 +71,9 @@ , fromURIPath , uriPath , modifyUriPath+ -- * Internals+ , mkPathNative+ , unPathNative -- * Re-exports , IOMode(..) , BufferMode(..)@@ -83,15 +85,12 @@ , IO.hSeek ) where +import Prelude import Control.Monad import Data.List (isPrefixOf) import System.IO (IOMode(..), BufferMode(..), Handle, SeekMode(..)) import System.IO.Unsafe (unsafeInterleaveIO)-#if MIN_VERSION_directory(1,2,0) import Data.Time (UTCTime)-#else-import System.Time (ClockTime)-#endif import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BS.L import qualified System.FilePath as FP.Native@@ -122,11 +121,18 @@ deriving (Show, Eq, Ord) mkPathNative :: FilePath -> Path a-mkPathNative = Path . FP.Posix.joinPath . FP.Native.splitDirectories+mkPathNative = Path . canonicalizePathSeparator unPathNative :: Path a -> FilePath-unPathNative (Path fp) = FP.Native.joinPath . FP.Posix.splitDirectories $ fp+unPathNative (Path fp) = fp +canonicalizePathSeparator :: FilePath -> FilePath+canonicalizePathSeparator = map (replaceSeparator)+ where+ replaceSeparator c+ | FP.Native.isPathSeparator c = '/'+ | otherwise = c+ mkPathPosix :: FilePath -> Path a mkPathPosix = Path @@ -238,21 +244,7 @@ toAbsoluteFilePath :: Path root -> IO FilePath instance FsRoot Relative where- 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.Native.normalise <$>) . absolutize- absolutize path -- avoid the call to `getCurrentDirectory` if we can- | FP.Native.isRelative path- = (FP.Native.</> path)- . FP.Native.addTrailingPathSeparator <$>- Dir.getCurrentDirectory- | otherwise = return path-#endif+ toAbsoluteFilePath p = Dir.makeAbsolute (unPathNative p) instance FsRoot Absolute where toAbsoluteFilePath = return . unPathNative@@ -294,7 +286,7 @@ fromAbsoluteFilePath :: FilePath -> Path Absolute fromAbsoluteFilePath fp | FP.Native.isAbsolute fp = mkPathNative fp- | otherwise = error "fromAbsoluteFilePath: not an absolute path"+ | otherwise = error ("fromAbsoluteFilePath: not an absolute path: " ++ fp) {------------------------------------------------------------------------------- Wrappers around System.IO@@ -370,11 +362,7 @@ filePath <- toAbsoluteFilePath path Dir.doesDirectoryExist filePath -#if MIN_VERSION_directory(1,2,0) getModificationTime :: FsRoot root => Path root -> IO UTCTime-#else-getModificationTime :: FsRoot root => Path root -> IO ClockTime-#endif getModificationTime path = do filePath <- toAbsoluteFilePath path Dir.getModificationTime filePath
src/Hackage/Security/Util/Pretty.hs view
@@ -3,6 +3,8 @@ Pretty(..) ) where +import Prelude+ -- | Produce a human-readable string class Pretty a where pretty :: a -> String
src/Hackage/Security/Util/Some.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} -- | Hiding existentials module Hackage.Security.Util.Some ( Some(..)@@ -13,29 +12,14 @@ , SomePretty(..) -- ** Type checking , typecheckSome-#if !MIN_VERSION_base(4,7,0)- -- ** Compatibility with base < 4.7- , tyConSome-#endif ) where -#if MIN_VERSION_base(4,7,0)-import Data.Typeable (Typeable)-#else-import qualified Data.Typeable as Typeable-#endif+import Prelude import Hackage.Security.Util.TypedEmbedded import Hackage.Security.Util.Pretty data Some f = forall a. Some (f a)--#if MIN_VERSION_base(4,7,0)-deriving instance Typeable Some-#else-tyConSome :: Typeable.TyCon-tyConSome = Typeable.mkTyCon3 "hackage-security" "Hackage.Security.Util.Some" "Some"-#endif {------------------------------------------------------------------------------- Equality on Some types
src/Hackage/Security/Util/Stack.hs view
@@ -3,6 +3,8 @@ (:-)(..) ) where +import Prelude+ data h :- t = h :- t deriving (Eq, Show) infixr 5 :-
src/Hackage/Security/Util/TypedEmbedded.hs view
@@ -7,6 +7,9 @@ , AsType(..) ) where +import Prelude+import Data.Kind (Type)+ -- | Type equality proofs -- -- This is a direct copy of "type-equality:Data.Type.Equality"; if we don't@@ -14,7 +17,7 @@ data a :=: b where Refl :: a :=: a -type family TypeOf (f :: * -> *) :: * -> *+type family TypeOf (f :: Type -> Type) :: Type -> Type -- | Equality check that gives us a type-level equality proof. class Unify f where
− src/Prelude.hs
@@ -1,32 +0,0 @@--- | Smooth over differences between various ghc versions by making older--- preludes look like 4.8.0-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE CPP #-}-module Prelude (- module P-#if !MIN_VERSION_base(4,8,0)- , Applicative(..)- , Monoid(..)- , (<$>)- , (<$)- , Traversable(traverse)- , displayException-#endif- ) where--#if MIN_VERSION_base(4,8,0)-import "base" Prelude as P-#else-#if MIN_VERSION_base(4,6,0)-import "base" Prelude as P-#else-import "base" Prelude as P hiding (catch)-#endif-import Control.Applicative-import Control.Exception (Exception)-import Data.Monoid-import Data.Traversable (Traversable(traverse))--displayException :: Exception e => e -> String-displayException = show-#endif
src/Text/JSON/Canonical.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE CPP #-}--------------------------------------------------------------------- -- | -- Module : Text.JSON.Parsec -- Copyright : (c) Galois, Inc. 2007-2009, Duncan Coutts 2015@@ -30,27 +28,21 @@ , prettyCanonicalJSON ) where +import Prelude import Text.ParserCombinators.Parsec ( CharParser, (<|>), (<?>), many, between, sepBy , satisfy, char, string, digit, spaces , parse ) import Text.PrettyPrint hiding (char) import qualified Text.PrettyPrint as Doc-#if !(MIN_VERSION_base(4,7,0))-import Control.Applicative ((<$>), (<$), pure, (<*>), (<*), (*>))-#endif import Control.Arrow (first)-import Data.Bits (Bits)-#if MIN_VERSION_base(4,7,0)-import Data.Bits (FiniteBits)-#endif+import Data.Bits (Bits, FiniteBits) import Data.Char (isDigit, digitToInt) import Data.Data (Data) import Data.Function (on) import Data.Int (Int64) import Data.Ix (Ix) import Data.List (foldl', sortBy)-import Data.Typeable (Typeable) import Foreign.Storable (Storable) import Text.Printf (PrintfArg) import qualified Data.ByteString.Lazy.Char8 as BS@@ -82,13 +74,10 @@ , Ord , Real , Ix-#if MIN_VERSION_base(4,7,0) , FiniteBits-#endif , Bits , Storable , PrintfArg- , Typeable ) instance Bounded Int54 where@@ -352,4 +341,3 @@ go [] = [] go [y] = [p <+> y, r] go (y:ys) = (p <+> y) : go ys-
tests/TestSuite.hs view
@@ -2,14 +2,14 @@ module Main (main) where -- stdlib-import Control.Exception-import Control.Monad+import Control.Exception ( handleJust )+import Control.Monad ( unless ) import Data.Maybe (fromJust)-import Data.Time-import Network.URI (URI, parseURI)-import Test.Tasty-import Test.Tasty.HUnit-import Test.Tasty.QuickCheck hiding (label)+import Data.Time ( UTCTime, getCurrentTime )+import Network.URI ( URI, parseURI )+import Test.Tasty ( defaultMain, testGroup, TestTree )+import Test.Tasty.HUnit ( testCase, (@?=), assertEqual, assertFailure, Assertion )+import Test.Tasty.QuickCheck ( testProperty, Property, (===), property ) import System.IO.Temp (withSystemTempDirectory) import qualified Codec.Archive.Tar.Entry as Tar import qualified Data.ByteString.Lazy.Char8 as BS@@ -70,7 +70,11 @@ testProperty "prop_roundtrip_canonical" JSON.prop_roundtrip_canonical , testProperty "prop_roundtrip_pretty" JSON.prop_roundtrip_pretty , testProperty "prop_canonical_pretty" JSON.prop_canonical_pretty+ , testProperty "prop_aeson_canonical" JSON.prop_aeson_canonical ]+ , testGroup "Path" [+ testProperty "Hackage.Security.Util.Path.mkPathNative" prop_mkPathNative+ ] ] {-------------------------------------------------------------------------------@@ -237,7 +241,7 @@ length (directoryEntries dir1) @?= 0 now <- getCurrentTime- inMemRepoSetIndex inMemRepo now [testEntry1]+ inMemRepoSetIndex inMemRepo now testEntries1 assertEqual "B" HasUpdates =<< checkForUpdates repo =<< checkExpiry dir2 <- getDirectory repo@@ -263,9 +267,16 @@ _ -> fail "unexpected index entry content" _ -> fail "unexpected index path" - testEntry1 = Tar.fileEntry path testEntrycontent- where- Right path = Tar.toTarPath False "foo/preferred-versions"++#if MIN_VERSION_tar(0,7,0)+ testEntries1 :: [Tar.GenEntry BS.ByteString Tar.TarPath linkTarget]+#elif MIN_VERSION_tar(0,6,0)+ testEntries1 :: [Tar.GenEntry Tar.TarPath linkTarget]+#else+ testEntries1 :: [Tar.Entry]+#endif+ testEntries1 = either (const []) (pure . (`Tar.fileEntry` testEntrycontent))+ (Tar.toTarPath False "foo/preferred-versions") testEntrycontent = BS.pack "foo >= 1" testEntryIndexFile = IndexPkgPrefs (mkPackageName "foo") @@ -283,6 +294,9 @@ , downloading isMirrors , noLocalCopy , downloading isIndex+ , lockingWait+ , lockingWaitDone+ , lockingRelease ] -- | Log messages when we do a check for updates and there are no changes@@ -290,6 +304,9 @@ msgsNoUpdates = [ selectedMirror inMemURI , downloading isTimestamp+ , lockingWait+ , lockingWaitDone+ , lockingRelease ] -- | Log messages we expect when the timestamp and snapshot have been resigned@@ -298,6 +315,9 @@ selectedMirror inMemURI , downloading isTimestamp , downloading isSnapshot+ , lockingWait+ , lockingWaitDone+ , lockingRelease ] -- | Log messages we expect when the timestamp key has been rolled over@@ -307,12 +327,18 @@ , downloading isTimestamp , verificationError $ unknownKeyError timestampPath , downloading isRoot+ , lockingWait+ , lockingWaitDone+ , lockingRelease , downloading isTimestamp , downloading isSnapshot -- Since we delete the timestamp and snapshot on a root info change, -- we will then conclude that we need to update the mirrors and the index. , downloading isMirrors , updating isIndex+ , lockingWait+ , lockingWaitDone+ , lockingRelease ] {-------------------------------------------------------------------------------@@ -335,6 +361,14 @@ updating isFile (LogUpdating file) = isFile file updating _ _ = False +lockingWait, lockingWaitDone, lockingRelease :: LogMessage -> Bool+lockingWait (LogLockWait _) = True+lockingWait _ = False+lockingWaitDone (LogLockWaitDone _) = True+lockingWaitDone _ = False+lockingRelease (LogUnlock _) = True+lockingRelease _ = False+ expired :: TargetPath -> VerificationError -> Bool expired f (VerificationErrorExpired f') = f == f' expired _ _ = False@@ -493,6 +527,9 @@ bootstrapMsgs :: [LogMessage -> Bool] bootstrapMsgs = [ selectedMirror inMemURI , downloading isRoot+ , lockingWait+ , lockingWaitDone+ , lockingRelease ] layout :: RepoLayout@@ -513,3 +550,16 @@ mkPackageName :: String -> PackageName mkPackageName = PackageName #endif++{-------------------------------------------------------------------------------+ Path tests+-------------------------------------------------------------------------------}++-- | Disclaimer: This test uses the vanilla generator for @type 'FilePath' = String@+-- and may thus been ineffective in establishing the desired round-trip property for+-- 'mkPathNative' and 'unPathNative' with sufficient probability.+--+-- Discussion at <https://github.com/haskell/hackage-security/pull/336#discussion_r2750538855>++prop_mkPathNative :: Property+prop_mkPathNative = property $ \(fp :: FilePath) -> (mkPathNative . unPathNative . mkPathNative) fp === mkPathNative fp
tests/TestSuite/InMemRepo.hs view
@@ -8,6 +8,7 @@ -- stdlib import Control.Exception+import Data.Kind (Type) import Data.Time import qualified Codec.Archive.Tar as Tar import qualified Codec.Compression.GZip as GZip@@ -33,7 +34,7 @@ "Files" from the in-memory repository -------------------------------------------------------------------------------} -data InMemFile :: * -> * where+data InMemFile :: Type -> Type where InMemMetadata :: ToJSON WriteJSON a => RepoLayout -> a -> InMemFile Metadata InMemBinary :: BS.L.ByteString -> InMemFile Binary
tests/TestSuite/JSON.hs view
@@ -1,35 +1,51 @@+{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module TestSuite.JSON ( prop_roundtrip_canonical, prop_roundtrip_pretty, prop_canonical_pretty,+ prop_aeson_canonical, ) 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 +-- aeson+import Data.Aeson (Value (..), eitherDecode)+import Data.String (fromString)+import qualified Data.Vector as V+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap as KM+#else+import qualified Data.HashMap.Strict as HM+#endif -prop_roundtrip_canonical, prop_roundtrip_pretty, prop_canonical_pretty- :: JSValue -> Bool+-- text+import qualified Data.Text as Text +prop_aeson_canonical, prop_roundtrip_canonical, prop_roundtrip_pretty, prop_canonical_pretty+ :: JSValue -> Property+ prop_roundtrip_canonical jsval =- parseCanonicalJSON (renderCanonicalJSON jsval) == Right (canonicalise jsval)+ parseCanonicalJSON (renderCanonicalJSON jsval) === Right (canonicalise jsval) prop_roundtrip_pretty jsval =- parseCanonicalJSON (BS.pack (prettyCanonicalJSON jsval)) == Right jsval+ parseCanonicalJSON (BS.pack (prettyCanonicalJSON jsval)) === Right jsval prop_canonical_pretty jsval =- parseCanonicalJSON (renderCanonicalJSON jsval) ==+ parseCanonicalJSON (renderCanonicalJSON jsval) === fmap canonicalise (parseCanonicalJSON (BS.pack (prettyCanonicalJSON jsval))) +prop_aeson_canonical jsval =+ eitherDecode (renderCanonicalJSON jsval) === Right (toAeson (canonicalise jsval))+ canonicalise :: JSValue -> JSValue canonicalise v@JSNull = v canonicalise v@(JSBool _) = v@@ -39,6 +55,9 @@ canonicalise (JSObject vs) = JSObject [ (k, canonicalise v) | (k,v) <- sortBy (compare `on` fst) vs ] +sanitizeString :: String -> String+sanitizeString s = Text.unpack (Text.replace (Text.pack "\\") (Text.pack "\\\\") (Text.pack (show s)))+ instance Arbitrary JSValue where arbitrary = sized $ \sz ->@@ -46,12 +65,13 @@ [ (1, pure JSNull) , (1, JSBool <$> arbitrary) , (2, JSNum <$> arbitrary)- , (2, JSString <$> arbitrary)+ , (2, JSString . sanitizeString . getASCIIString <$> arbitrary) , (3, JSArray <$> resize (sz `div` 2) arbitrary)- , (3, JSObject . noDupFields <$> resize (sz `div` 2) arbitrary)+ , (3, JSObject . mapFirst (sanitizeString . getASCIIString) . noDupFields <$> resize (sz `div` 2) arbitrary) ] where noDupFields = nubBy (\(x,_) (y,_) -> x==y)+ mapFirst f = map (\(x, y) -> (f x, y)) shrink JSNull = [] shrink (JSBool _) = []@@ -62,6 +82,17 @@ where shrinkSnd (a,b) = [ (a,b') | b' <- shrink b ] +toAeson :: JSValue -> Value+toAeson JSNull = Null+toAeson (JSBool b) = Bool b+toAeson (JSNum n) = Number (fromIntegral n)+toAeson (JSString s) = String (fromString s)+toAeson (JSArray xs) = Array $ V.fromList [ toAeson x | x <- xs ]+#if MIN_VERSION_aeson(2,0,0)+toAeson (JSObject xs) = Object $ KM.fromList [ (fromString k, toAeson v) | (k, v) <- xs ]+#else+toAeson (JSObject xs) = Object $ HM.fromList [ (fromString k, toAeson v) | (k, v) <- xs ]+#endif instance Arbitrary Int54 where arbitrary = fromIntegral <$>