diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 ------- diff --git a/hackage-security.cabal b/hackage-security.cabal --- a/hackage-security.cabal +++ b/hackage-security.cabal @@ -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 - (). It is based on The Update - Framework (), a set of + (). It is based on The Update + Framework (), a set of recommendations developed by security researchers at various universities in the US as well as developers on the Tor project (). @@ -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 diff --git a/src/Hackage/Security/Client.hs b/src/Hackage/Security/Client.hs --- a/src/Hackage/Security/Client.hs +++ b/src/Hackage/Security/Client.hs @@ -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 diff --git a/src/Hackage/Security/Client/Formats.hs b/src/Hackage/Security/Client/Formats.hs --- a/src/Hackage/Security/Client/Formats.hs +++ b/src/Hackage/Security/Client/Formats.hs @@ -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 diff --git a/src/Hackage/Security/Client/Repository.hs b/src/Hackage/Security/Client/Repository.hs --- a/src/Hackage/Security/Client/Repository.hs +++ b/src/Hackage/Security/Client/Repository.hs @@ -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 = diff --git a/src/Hackage/Security/Client/Repository/Cache.hs b/src/Hackage/Security/Client/Repository/Cache.hs --- a/src/Hackage/Security/Client/Repository/Cache.hs +++ b/src/Hackage/Security/Client/Repository/Cache.hs @@ -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 diff --git a/src/Hackage/Security/Client/Repository/HttpLib.hs b/src/Hackage/Security/Client/Repository/HttpLib.hs --- a/src/Hackage/Security/Client/Repository/HttpLib.hs +++ b/src/Hackage/Security/Client/Repository/HttpLib.hs @@ -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 diff --git a/src/Hackage/Security/Client/Repository/Local.hs b/src/Hackage/Security/Client/Repository/Local.hs --- a/src/Hackage/Security/Client/Repository/Local.hs +++ b/src/Hackage/Security/Client/Repository/Local.hs @@ -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 diff --git a/src/Hackage/Security/Client/Repository/Remote.hs b/src/Hackage/Security/Client/Repository/Remote.hs --- a/src/Hackage/Security/Client/Repository/Remote.hs +++ b/src/Hackage/Security/Client/Repository/Remote.hs @@ -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 ] - diff --git a/src/Hackage/Security/Client/Verify.hs b/src/Hackage/Security/Client/Verify.hs --- a/src/Hackage/Security/Client/Verify.hs +++ b/src/Hackage/Security/Client/Verify.hs @@ -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 diff --git a/src/Hackage/Security/JSON.hs b/src/Hackage/Security/JSON.hs --- a/src/Hackage/Security/JSON.hs +++ b/src/Hackage/Security/JSON.hs @@ -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) = diff --git a/src/Hackage/Security/Key.hs b/src/Hackage/Security/Key.hs --- a/src/Hackage/Security/Key.hs +++ b/src/Hackage/Security/Key.hs @@ -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 diff --git a/src/Hackage/Security/TUF/Common.hs b/src/Hackage/Security/TUF/Common.hs --- a/src/Hackage/Security/TUF/Common.hs +++ b/src/Hackage/Security/TUF/Common.hs @@ -6,6 +6,7 @@ , KeyThreshold(..) ) where +import Prelude import Hackage.Security.JSON {------------------------------------------------------------------------------- diff --git a/src/Hackage/Security/TUF/FileMap.hs b/src/Hackage/Security/TUF/FileMap.hs --- a/src/Hackage/Security/TUF/FileMap.hs +++ b/src/Hackage/Security/TUF/FileMap.hs @@ -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 diff --git a/src/Hackage/Security/TUF/Header.hs b/src/Hackage/Security/TUF/Header.hs --- a/src/Hackage/Security/TUF/Header.hs +++ b/src/Hackage/Security/TUF/Header.hs @@ -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 { diff --git a/src/Hackage/Security/TUF/Layout/Cache.hs b/src/Hackage/Security/TUF/Layout/Cache.hs --- a/src/Hackage/Security/TUF/Layout/Cache.hs +++ b/src/Hackage/Security/TUF/Layout/Cache.hs @@ -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 { diff --git a/src/Hackage/Security/TUF/Layout/Index.hs b/src/Hackage/Security/TUF/Layout/Index.hs --- a/src/Hackage/Security/TUF/Layout/Index.hs +++ b/src/Hackage/Security/TUF/Layout/Index.hs @@ -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) diff --git a/src/Hackage/Security/TUF/Layout/Repo.hs b/src/Hackage/Security/TUF/Layout/Repo.hs --- a/src/Hackage/Security/TUF/Layout/Repo.hs +++ b/src/Hackage/Security/TUF/Layout/Repo.hs @@ -5,6 +5,7 @@ , cabalLocalRepoLayout ) where +import Prelude import Distribution.Package import Distribution.Text diff --git a/src/Hackage/Security/TUF/Mirrors.hs b/src/Hackage/Security/TUF/Mirrors.hs --- a/src/Hackage/Security/TUF/Mirrors.hs +++ b/src/Hackage/Security/TUF/Mirrors.hs @@ -9,6 +9,7 @@ , describeMirror ) where +import Prelude import Control.Monad.Except import Network.URI diff --git a/src/Hackage/Security/TUF/Paths.hs b/src/Hackage/Security/TUF/Paths.hs --- a/src/Hackage/Security/TUF/Paths.hs +++ b/src/Hackage/Security/TUF/Paths.hs @@ -14,6 +14,7 @@ , anchorCachePath ) where +import Prelude import Hackage.Security.Util.Path import Hackage.Security.Util.Pretty diff --git a/src/Hackage/Security/TUF/Patterns.hs b/src/Hackage/Security/TUF/Patterns.hs --- a/src/Hackage/Security/TUF/Patterns.hs +++ b/src/Hackage/Security/TUF/Patterns.hs @@ -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" diff --git a/src/Hackage/Security/TUF/Root.hs b/src/Hackage/Security/TUF/Root.hs --- a/src/Hackage/Security/TUF/Root.hs +++ b/src/Hackage/Security/TUF/Root.hs @@ -6,6 +6,7 @@ , RoleSpec(..) ) where +import Prelude import Hackage.Security.JSON import Hackage.Security.Key import Hackage.Security.Key.Env (KeyEnv) diff --git a/src/Hackage/Security/TUF/Signed.hs b/src/Hackage/Security/TUF/Signed.hs --- a/src/Hackage/Security/TUF/Signed.hs +++ b/src/Hackage/Security/TUF/Signed.hs @@ -27,6 +27,7 @@ , toPreSignatures ) where +import Prelude import Control.Monad import Data.Functor.Identity import qualified Data.ByteString as BS diff --git a/src/Hackage/Security/TUF/Snapshot.hs b/src/Hackage/Security/TUF/Snapshot.hs --- a/src/Hackage/Security/TUF/Snapshot.hs +++ b/src/Hackage/Security/TUF/Snapshot.hs @@ -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{..} diff --git a/src/Hackage/Security/TUF/Targets.hs b/src/Hackage/Security/TUF/Targets.hs --- a/src/Hackage/Security/TUF/Targets.hs +++ b/src/Hackage/Security/TUF/Targets.hs @@ -8,6 +8,7 @@ , targetsLookup ) where +import Prelude import Hackage.Security.JSON import Hackage.Security.Key import Hackage.Security.Key.Env (KeyEnv) diff --git a/src/Hackage/Security/TUF/Timestamp.hs b/src/Hackage/Security/TUF/Timestamp.hs --- a/src/Hackage/Security/TUF/Timestamp.hs +++ b/src/Hackage/Security/TUF/Timestamp.hs @@ -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 diff --git a/src/Hackage/Security/Trusted.hs b/src/Hackage/Security/Trusted.hs --- a/src/Hackage/Security/Trusted.hs +++ b/src/Hackage/Security/Trusted.hs @@ -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 diff --git a/src/Hackage/Security/Trusted/TCB.hs b/src/Hackage/Security/Trusted/TCB.hs --- a/src/Hackage/Security/Trusted/TCB.hs +++ b/src/Hackage/Security/Trusted/TCB.hs @@ -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 diff --git a/src/Hackage/Security/Util/Base64.hs b/src/Hackage/Security/Util/Base64.hs --- a/src/Hackage/Security/Util/Base64.hs +++ b/src/Hackage/Security/Util/Base64.hs @@ -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 diff --git a/src/Hackage/Security/Util/Checked.hs b/src/Hackage/Security/Util/Checked.hs --- a/src/Hackage/Security/Util/Checked.hs +++ b/src/Hackage/Security/Util/Checked.hs @@ -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 == "<>" -> 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 diff --git a/src/Hackage/Security/Util/Exit.hs b/src/Hackage/Security/Util/Exit.hs --- a/src/Hackage/Security/Util/Exit.hs +++ b/src/Hackage/Security/Util/Exit.hs @@ -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 diff --git a/src/Hackage/Security/Util/FileLock.hsc b/src/Hackage/Security/Util/FileLock.hsc deleted file mode 100644 --- a/src/Hackage/Security/Util/FileLock.hsc +++ /dev/null @@ -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 - -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 - -#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 */ diff --git a/src/Hackage/Security/Util/IO.hs b/src/Hackage/Security/Util/IO.hs --- a/src/Hackage/Security/Util/IO.hs +++ b/src/Hackage/Security/Util/IO.hs @@ -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 {------------------------------------------------------------------------------- diff --git a/src/Hackage/Security/Util/JSON.hs b/src/Hackage/Security/Util/JSON.hs --- a/src/Hackage/Security/Util/JSON.hs +++ b/src/Hackage/Security/Util/JSON.hs @@ -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 diff --git a/src/Hackage/Security/Util/Lens.hs b/src/Hackage/Security/Util/Lens.hs --- a/src/Hackage/Security/Util/Lens.hs +++ b/src/Hackage/Security/Util/Lens.hs @@ -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 diff --git a/src/Hackage/Security/Util/Path.hs b/src/Hackage/Security/Util/Path.hs --- a/src/Hackage/Security/Util/Path.hs +++ b/src/Hackage/Security/Util/Path.hs @@ -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 diff --git a/src/Hackage/Security/Util/Pretty.hs b/src/Hackage/Security/Util/Pretty.hs --- a/src/Hackage/Security/Util/Pretty.hs +++ b/src/Hackage/Security/Util/Pretty.hs @@ -3,6 +3,8 @@ Pretty(..) ) where +import Prelude + -- | Produce a human-readable string class Pretty a where pretty :: a -> String diff --git a/src/Hackage/Security/Util/Some.hs b/src/Hackage/Security/Util/Some.hs --- a/src/Hackage/Security/Util/Some.hs +++ b/src/Hackage/Security/Util/Some.hs @@ -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 diff --git a/src/Hackage/Security/Util/Stack.hs b/src/Hackage/Security/Util/Stack.hs --- a/src/Hackage/Security/Util/Stack.hs +++ b/src/Hackage/Security/Util/Stack.hs @@ -3,6 +3,8 @@ (:-)(..) ) where +import Prelude + data h :- t = h :- t deriving (Eq, Show) infixr 5 :- diff --git a/src/Hackage/Security/Util/TypedEmbedded.hs b/src/Hackage/Security/Util/TypedEmbedded.hs --- a/src/Hackage/Security/Util/TypedEmbedded.hs +++ b/src/Hackage/Security/Util/TypedEmbedded.hs @@ -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 diff --git a/src/Prelude.hs b/src/Prelude.hs deleted file mode 100644 --- a/src/Prelude.hs +++ /dev/null @@ -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 diff --git a/src/Text/JSON/Canonical.hs b/src/Text/JSON/Canonical.hs --- a/src/Text/JSON/Canonical.hs +++ b/src/Text/JSON/Canonical.hs @@ -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 - diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs --- a/tests/TestSuite.hs +++ b/tests/TestSuite.hs @@ -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 + +prop_mkPathNative :: Property +prop_mkPathNative = property $ \(fp :: FilePath) -> (mkPathNative . unPathNative . mkPathNative) fp === mkPathNative fp diff --git a/tests/TestSuite/InMemRepo.hs b/tests/TestSuite/InMemRepo.hs --- a/tests/TestSuite/InMemRepo.hs +++ b/tests/TestSuite/InMemRepo.hs @@ -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 diff --git a/tests/TestSuite/JSON.hs b/tests/TestSuite/JSON.hs --- a/tests/TestSuite/JSON.hs +++ b/tests/TestSuite/JSON.hs @@ -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 <$>