pantry 0.8.2.2 → 0.8.3
raw patch · 34 files changed
+7376/−6995 lines, 34 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- Pantry.Internal.Stackage: [pcCasaMaxPerRequest] :: PantryConfig -> !Int
- Pantry.Internal.Stackage: [pcCasaRepoPrefix] :: PantryConfig -> !CasaRepoPrefix
+ Pantry: NoCasaConfig :: PantryException
+ Pantry: withPantryConfig' :: HasLogFunc env => Path Abs Dir -> PackageIndexConfig -> HpackExecutable -> Int -> Maybe (CasaRepoPrefix, Int) -> (SnapName -> RawSnapshotLocation) -> (PantryConfig -> RIO env a) -> RIO env a
+ Pantry.Internal.Stackage: [pcCasaConfig] :: PantryConfig -> !Maybe (CasaRepoPrefix, Int)
- Pantry.Internal.Stackage: PantryConfig :: !PackageIndexConfig -> !HpackExecutable -> !Path Abs Dir -> !Storage -> !MVar Bool -> !IORef (Map RawPackageLocationImmutable GenericPackageDescription) -> !IORef (Map (Path Abs Dir) (PrintWarnings -> IO GenericPackageDescription, PackageName, Path Abs File)) -> !Int -> !CasaRepoPrefix -> !Int -> (SnapName -> RawSnapshotLocation) -> PantryConfig
+ Pantry.Internal.Stackage: PantryConfig :: !PackageIndexConfig -> !HpackExecutable -> !Path Abs Dir -> !Storage -> !MVar Bool -> !IORef (Map RawPackageLocationImmutable GenericPackageDescription) -> !IORef (Map (Path Abs Dir) (PrintWarnings -> IO GenericPackageDescription, PackageName, Path Abs File)) -> !Int -> !Maybe (CasaRepoPrefix, Int) -> (SnapName -> RawSnapshotLocation) -> PantryConfig
Files
- ChangeLog.md +8/−0
- app/test-pretty-exceptions/unix/System/Terminal.hsc +2/−2
- pantry.cabal +274/−274
- src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs +101/−93
- src/Pantry.hs +2008/−1935
- src/Pantry/Archive.hs +225/−174
- src/Pantry/Casa.hs +46/−40
- src/Pantry/HPack.hs +62/−59
- src/Pantry/HTTP.hs +60/−62
- src/Pantry/Hackage.hs +285/−267
- src/Pantry/Internal.hs +12/−11
- src/Pantry/Internal/AesonExtended.hs +135/−105
- src/Pantry/Internal/Companion.hs +26/−24
- src/Pantry/Internal/Stackage.hs +19/−44
- src/Pantry/Internal/StaticBytes.hs +49/−43
- src/Pantry/Repo.hs +153/−130
- src/Pantry/SHA256.hs +27/−23
- src/Pantry/SQLite.hs +44/−32
- src/Pantry/Storage.hs +377/−362
- src/Pantry/Tree.hs +27/−24
- src/Pantry/Types.hs +3320/−3200
- src/unix/System/IsWindows.hs +2/−1
- src/windows/System/IsWindows.hs +2/−1
- test/Pantry/ArchiveSpec.hs +13/−10
- test/Pantry/BuildPlanSpec.hs +5/−5
- test/Pantry/CabalSpec.hs +9/−6
- test/Pantry/CasaSpec.hs +8/−5
- test/Pantry/FileSpec.hs +8/−6
- test/Pantry/GlobalHintsSpec.hs +11/−8
- test/Pantry/HackageSpec.hs +8/−5
- test/Pantry/Internal/StaticBytesSpec.hs +15/−12
- test/Pantry/InternalSpec.hs +7/−4
- test/Pantry/TreeSpec.hs +9/−6
- test/Pantry/TypesSpec.hs +19/−22
ChangeLog.md view
@@ -1,5 +1,13 @@ # Changelog for pantry +## v0.8.3 + +* Expose `withPantryConfig'`, which allows for optional use of Casa. + `NoCasaConfig` is now a data constructor of `PantryException`. +* `withRepo`, in the case of Git, will now, if necessary, fetch the specific + commit. (For example, GitHub repositories include the commits of unmerged pull + requests but these are not fetched when the repository is cloned.) + ## v0.8.2.2 * Add error S-395 (`NoLocalPackageDirFound`).
app/test-pretty-exceptions/unix/System/Terminal.hsc view
@@ -35,10 +35,10 @@ alloca $ \p -> do errno <- ioctl (#const STDOUT_FILENO) (#const TIOCGWINSZ) p if errno < 0 - then return Nothing + then pure Nothing else do WindowWidth w <- peek p - return . Just . fromIntegral $ w + pure . Just . fromIntegral $ w -- | hIsTerminaDevice does not recognise handles to mintty terminals as terminal -- devices, but isMinTTYHandle does.
pantry.cabal view
@@ -1,275 +1,275 @@ cabal-version: 1.12 - --- This file has been generated from package.yaml by hpack version 0.35.2. --- --- see: https://github.com/sol/hpack - -name: pantry -version: 0.8.2.2 -synopsis: Content addressable Haskell package management -description: Please see the README on GitHub at <https://github.com/commercialhaskell/pantry#readme> -category: Development -homepage: https://github.com/commercialhaskell/pantry#readme -bug-reports: https://github.com/commercialhaskell/pantry/issues -author: Michael Snoyman -maintainer: michael@snoyman.com -copyright: 2018-2022 FP Complete -license: BSD3 -license-file: LICENSE -build-type: Simple -extra-source-files: - README.md - ChangeLog.md - attic/hpack-0.1.2.3.tar.gz - attic/package-0.1.2.3.tar.gz - attic/symlink-to-dir.tar.gz - -source-repository head - type: git - location: https://github.com/commercialhaskell/pantry - -flag test-pretty-exceptions - description: Build an executable to test pretty exceptions - manual: False - default: False - -library - exposed-modules: - Pantry - Pantry.SHA256 - Pantry.Internal - Pantry.Internal.StaticBytes - Pantry.Internal.Stackage - Pantry.Internal.Companion - Pantry.Internal.AesonExtended - other-modules: - Hackage.Security.Client.Repository.HttpLib.HttpClient - Pantry.Archive - Pantry.HTTP - Pantry.HPack - Pantry.Hackage - Pantry.Repo - Pantry.SQLite - Pantry.Storage - Pantry.Casa - Pantry.Tree - Pantry.Types - hs-source-dirs: - src/ - ghc-options: -Wall - build-depends: - Cabal >=3 && <3.11 - , aeson - , ansi-terminal - , base >=4.10 && <5 - , bytestring - , casa-client - , casa-types - , conduit - , conduit-extra - , containers - , cryptonite - , cryptonite-conduit - , digest - , filelock - , generic-deriving - , hackage-security - , hpack >=0.35.1 - , http-client - , http-client-tls - , http-conduit - , http-download - , http-types - , memory - , mtl - , network-uri - , path - , path-io - , persistent - , persistent-sqlite >=2.9.3 - , persistent-template - , primitive - , resourcet - , rio - , rio-orphans - , rio-prettyprint - , tar-conduit - , text - , text-metrics - , time - , transformers - , unix-compat - , unliftio - , unordered-containers - , vector - , yaml - , zip-archive - default-language: Haskell2010 - if impl(ghc >= 9.4.5) && os(windows) - build-depends: - network >=3.1.2.9 - if os(windows) - other-modules: - System.IsWindows - hs-source-dirs: - src/windows/ - else - other-modules: - System.IsWindows - hs-source-dirs: - src/unix/ - -executable test-pretty-exceptions - main-is: Main.hs - other-modules: - Paths_pantry - hs-source-dirs: - app/test-pretty-exceptions - ghc-options: -Wall - build-depends: - Cabal >=3 && <3.11 - , aeson - , ansi-terminal - , base >=4.10 && <5 - , bytestring - , casa-client - , casa-types - , conduit - , conduit-extra - , containers - , cryptonite - , cryptonite-conduit - , digest - , filelock - , generic-deriving - , hackage-security - , hpack >=0.35.1 - , http-client - , http-client-tls - , http-conduit - , http-download - , http-types - , memory - , mtl - , network-uri - , optparse-applicative - , pantry - , path - , path-io - , persistent - , persistent-sqlite >=2.9.3 - , persistent-template - , primitive - , resourcet - , rio - , rio-orphans - , rio-prettyprint - , tar-conduit - , text - , text-metrics - , time - , transformers - , unix-compat - , unliftio - , unordered-containers - , vector - , yaml - , zip-archive - default-language: Haskell2010 - if impl(ghc >= 9.4.5) && os(windows) - build-depends: - network >=3.1.2.9 - if !flag(test-pretty-exceptions) - buildable: False - if os(windows) - other-modules: - PathAbsExamples - System.Terminal - hs-source-dirs: - app/test-pretty-exceptions/windows/ - build-depends: - Win32 - , process - else - other-modules: - PathAbsExamples - System.Terminal - hs-source-dirs: - app/test-pretty-exceptions/unix/ - -test-suite spec - type: exitcode-stdio-1.0 - main-is: Spec.hs - other-modules: - Pantry.ArchiveSpec - Pantry.BuildPlanSpec - Pantry.CabalSpec - Pantry.CasaSpec - Pantry.FileSpec - Pantry.GlobalHintsSpec - Pantry.HackageSpec - Pantry.Internal.StaticBytesSpec - Pantry.InternalSpec - Pantry.TreeSpec - Pantry.TypesSpec - Paths_pantry - hs-source-dirs: - test - ghc-options: -Wall - build-depends: - Cabal >=3 && <3.11 - , QuickCheck - , aeson - , ansi-terminal - , base >=4.10 && <5 - , bytestring - , casa-client - , casa-types - , conduit - , conduit-extra - , containers - , cryptonite - , cryptonite-conduit - , digest - , exceptions - , filelock - , generic-deriving - , hackage-security - , hedgehog - , hpack >=0.35.1 - , hspec - , http-client - , http-client-tls - , http-conduit - , http-download - , http-types - , memory - , mtl - , network-uri - , pantry - , path - , path-io - , persistent - , persistent-sqlite >=2.9.3 - , persistent-template - , primitive - , raw-strings-qq - , resourcet - , rio - , rio-orphans - , rio-prettyprint - , tar-conduit - , text - , text-metrics - , time - , transformers - , unix-compat - , unliftio - , unordered-containers - , vector - , yaml - , zip-archive - default-language: Haskell2010 - if impl(ghc >= 9.4.5) && os(windows) - build-depends: - network >=3.1.2.9 ++-- This file has been generated from package.yaml by hpack version 0.35.2.+--+-- see: https://github.com/sol/hpack++name: pantry+version: 0.8.3+synopsis: Content addressable Haskell package management+description: Please see the README on GitHub at <https://github.com/commercialhaskell/pantry#readme>+category: Development+homepage: https://github.com/commercialhaskell/pantry#readme+bug-reports: https://github.com/commercialhaskell/pantry/issues+author: Michael Snoyman+maintainer: michael@snoyman.com+copyright: 2018-2022 FP Complete+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md+ attic/hpack-0.1.2.3.tar.gz+ attic/package-0.1.2.3.tar.gz+ attic/symlink-to-dir.tar.gz++source-repository head+ type: git+ location: https://github.com/commercialhaskell/pantry++flag test-pretty-exceptions+ description: Build an executable to test pretty exceptions+ manual: False+ default: False++library+ exposed-modules:+ Pantry+ Pantry.SHA256+ Pantry.Internal+ Pantry.Internal.StaticBytes+ Pantry.Internal.Stackage+ Pantry.Internal.Companion+ Pantry.Internal.AesonExtended+ other-modules:+ Hackage.Security.Client.Repository.HttpLib.HttpClient+ Pantry.Archive+ Pantry.HTTP+ Pantry.HPack+ Pantry.Hackage+ Pantry.Repo+ Pantry.SQLite+ Pantry.Storage+ Pantry.Casa+ Pantry.Tree+ Pantry.Types+ hs-source-dirs:+ src/+ ghc-options: -Wall+ build-depends:+ Cabal >=3 && <3.11+ , aeson+ , ansi-terminal+ , base >=4.10 && <5+ , bytestring+ , casa-client+ , casa-types+ , conduit+ , conduit-extra+ , containers+ , cryptonite+ , cryptonite-conduit+ , digest+ , filelock+ , generic-deriving+ , hackage-security+ , hpack >=0.35.1+ , http-client+ , http-client-tls+ , http-conduit+ , http-download+ , http-types+ , memory+ , mtl+ , network-uri+ , path+ , path-io+ , persistent+ , persistent-sqlite >=2.9.3+ , persistent-template+ , primitive+ , resourcet+ , rio+ , rio-orphans+ , rio-prettyprint+ , tar-conduit+ , text+ , text-metrics+ , time+ , transformers+ , unix-compat+ , unliftio+ , unordered-containers+ , vector+ , yaml+ , zip-archive+ default-language: Haskell2010+ if impl(ghc >= 9.4.5) && os(windows)+ build-depends:+ network >=3.1.2.9+ if os(windows)+ other-modules:+ System.IsWindows+ hs-source-dirs:+ src/windows/+ else+ other-modules:+ System.IsWindows+ hs-source-dirs:+ src/unix/++executable test-pretty-exceptions+ main-is: Main.hs+ other-modules:+ Paths_pantry+ hs-source-dirs:+ app/test-pretty-exceptions+ ghc-options: -Wall+ build-depends:+ Cabal >=3 && <3.11+ , aeson+ , ansi-terminal+ , base >=4.10 && <5+ , bytestring+ , casa-client+ , casa-types+ , conduit+ , conduit-extra+ , containers+ , cryptonite+ , cryptonite-conduit+ , digest+ , filelock+ , generic-deriving+ , hackage-security+ , hpack >=0.35.1+ , http-client+ , http-client-tls+ , http-conduit+ , http-download+ , http-types+ , memory+ , mtl+ , network-uri+ , optparse-applicative+ , pantry+ , path+ , path-io+ , persistent+ , persistent-sqlite >=2.9.3+ , persistent-template+ , primitive+ , resourcet+ , rio+ , rio-orphans+ , rio-prettyprint+ , tar-conduit+ , text+ , text-metrics+ , time+ , transformers+ , unix-compat+ , unliftio+ , unordered-containers+ , vector+ , yaml+ , zip-archive+ default-language: Haskell2010+ if impl(ghc >= 9.4.5) && os(windows)+ build-depends:+ network >=3.1.2.9+ if !flag(test-pretty-exceptions)+ buildable: False+ if os(windows)+ other-modules:+ PathAbsExamples+ System.Terminal+ hs-source-dirs:+ app/test-pretty-exceptions/windows/+ build-depends:+ Win32+ , process+ else+ other-modules:+ PathAbsExamples+ System.Terminal+ hs-source-dirs:+ app/test-pretty-exceptions/unix/++test-suite spec+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Pantry.ArchiveSpec+ Pantry.BuildPlanSpec+ Pantry.CabalSpec+ Pantry.CasaSpec+ Pantry.FileSpec+ Pantry.GlobalHintsSpec+ Pantry.HackageSpec+ Pantry.Internal.StaticBytesSpec+ Pantry.InternalSpec+ Pantry.TreeSpec+ Pantry.TypesSpec+ Paths_pantry+ hs-source-dirs:+ test+ ghc-options: -Wall+ build-depends:+ Cabal >=3 && <3.11+ , QuickCheck+ , aeson+ , ansi-terminal+ , base >=4.10 && <5+ , bytestring+ , casa-client+ , casa-types+ , conduit+ , conduit-extra+ , containers+ , cryptonite+ , cryptonite-conduit+ , digest+ , exceptions+ , filelock+ , generic-deriving+ , hackage-security+ , hedgehog+ , hpack >=0.35.1+ , hspec+ , http-client+ , http-client-tls+ , http-conduit+ , http-download+ , http-types+ , memory+ , mtl+ , network-uri+ , pantry+ , path+ , path-io+ , persistent+ , persistent-sqlite >=2.9.3+ , persistent-template+ , primitive+ , raw-strings-qq+ , resourcet+ , rio+ , rio-orphans+ , rio-prettyprint+ , tar-conduit+ , text+ , text-metrics+ , time+ , transformers+ , unix-compat+ , unliftio+ , unordered-containers+ , vector+ , yaml+ , zip-archive+ default-language: Haskell2010+ if impl(ghc >= 9.4.5) && os(windows)+ build-depends:+ network >=3.1.2.9
src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs view
@@ -3,26 +3,24 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} -- Adapted from `hackage-security-http-client` to use our own -- `Pantry.HTTP` implementation -module Hackage.Security.Client.Repository.HttpLib.HttpClient ( - httpLib +module Hackage.Security.Client.Repository.HttpLib.HttpClient + ( httpLib ) where -import Control.Exception -import Control.Monad (void) -import Data.ByteString (ByteString) -import Network.URI -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS.C8 +import Control.Exception +import Control.Monad ( void ) +import Data.ByteString ( ByteString ) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS.C8 +import Hackage.Security.Client hiding ( Header ) +import Hackage.Security.Client.Repository.HttpLib +import Hackage.Security.Util.Checked +import Network.URI import qualified Pantry.HTTP as HTTP -import Hackage.Security.Client hiding (Header) -import Hackage.Security.Client.Repository.HttpLib -import Hackage.Security.Util.Checked - {------------------------------------------------------------------------------- Top-level API -------------------------------------------------------------------------------} @@ -30,55 +28,60 @@ -- | An 'HttpLib' value using the default global manager httpLib :: HttpLib httpLib = HttpLib - { httpGet = get - , httpGetRange = getRange - } + { httpGet = get + , httpGetRange = getRange + } {------------------------------------------------------------------------------- Individual methods -------------------------------------------------------------------------------} -get :: Throws SomeRemoteError - => [HttpRequestHeader] -> URI - -> ([HttpResponseHeader] -> BodyReader -> IO a) - -> IO a +get :: + Throws SomeRemoteError + => [HttpRequestHeader] -> URI + -> ([HttpResponseHeader] -> BodyReader -> IO a) + -> IO a get reqHeaders uri callback = wrapCustomEx $ do - -- TODO: setUri fails under certain circumstances; in particular, when - -- the URI contains URL auth. Not sure if this is a concern. - request' <- HTTP.setUri HTTP.defaultRequest uri - let request = setRequestHeaders reqHeaders request' - checkHttpException $ HTTP.withResponse request $ \response -> do - let br = wrapCustomEx $ HTTP.getResponseBody response - callback (getResponseHeaders response) br + -- TODO: setUri fails under certain circumstances; in particular, when + -- the URI contains URL auth. Not sure if this is a concern. + request' <- HTTP.setUri HTTP.defaultRequest uri + let request = setRequestHeaders reqHeaders request' + checkHttpException $ HTTP.withResponse request $ \response -> do + let br = wrapCustomEx $ HTTP.getResponseBody response + callback (getResponseHeaders response) br -getRange :: Throws SomeRemoteError - => [HttpRequestHeader] -> URI -> (Int, Int) - -> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a) - -> IO a +getRange :: + Throws SomeRemoteError + => [HttpRequestHeader] + -> URI + -> (Int, Int) + -> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a) + -> IO a getRange reqHeaders uri (from, to) callback = wrapCustomEx $ do - request' <- HTTP.setUri HTTP.defaultRequest uri - let request = setRange from to - $ setRequestHeaders reqHeaders request' - checkHttpException $ HTTP.withResponse request $ \response -> do - let br = wrapCustomEx $ HTTP.getResponseBody response - case () of - () | HTTP.getResponseStatus response == HTTP.partialContent206 -> - callback HttpStatus206PartialContent (getResponseHeaders response) br - () | HTTP.getResponseStatus response == HTTP.ok200 -> - callback HttpStatus200OK (getResponseHeaders response) br - _otherwise -> - throwChecked $ HTTP.HttpExceptionRequest request - $ HTTP.StatusCodeException (void response) "" + request' <- HTTP.setUri HTTP.defaultRequest uri + let request = setRange from to + $ setRequestHeaders reqHeaders request' + checkHttpException $ HTTP.withResponse request $ \response -> do + let br = wrapCustomEx $ HTTP.getResponseBody response + case () of + () | HTTP.getResponseStatus response == HTTP.partialContent206 -> + callback HttpStatus206PartialContent (getResponseHeaders response) br + () | HTTP.getResponseStatus response == HTTP.ok200 -> + callback HttpStatus200OK (getResponseHeaders response) br + _otherwise -> + throwChecked $ HTTP.HttpExceptionRequest request + $ HTTP.StatusCodeException (void response) "" -- | Wrap custom exceptions -- -- NOTE: The only other exception defined in @http-client@ is @TimeoutTriggered@ -- but it is currently disabled <https://github.com/snoyberg/http-client/issues/116> -wrapCustomEx :: (Throws HTTP.HttpException => IO a) - -> (Throws SomeRemoteError => IO a) -wrapCustomEx act = handleChecked (\(ex :: HTTP.HttpException) -> go ex) act - where - go ex = throwChecked (SomeRemoteError ex) +wrapCustomEx :: + (Throws HTTP.HttpException => IO a) + -> (Throws SomeRemoteError => IO a) +wrapCustomEx = handleChecked (\(ex :: HTTP.HttpException) -> go ex) + where + go ex = throwChecked (SomeRemoteError ex) checkHttpException :: Throws HTTP.HttpException => IO a -> IO a checkHttpException = handle $ \(ex :: HTTP.HttpException) -> @@ -94,58 +97,63 @@ hAcceptEncoding :: HTTP.HeaderName hAcceptEncoding = "Accept-Encoding" -setRange :: Int -> Int - -> HTTP.Request -> HTTP.Request +setRange :: + Int + -> Int + -> HTTP.Request + -> HTTP.Request setRange from to = - HTTP.addRequestHeader HTTP.hRange rangeHeader - where - -- Content-Range header uses inclusive rather than exclusive bounds - -- See <http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html> - rangeHeader = BS.C8.pack $ "bytes=" ++ show from ++ "-" ++ show (to - 1) + HTTP.addRequestHeader HTTP.hRange rangeHeader + where + -- Content-Range header uses inclusive rather than exclusive bounds + -- See <http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html> + rangeHeader = BS.C8.pack $ "bytes=" ++ show from ++ "-" ++ show (to - 1) -- | Set request headers -setRequestHeaders :: [HttpRequestHeader] - -> HTTP.Request -> HTTP.Request +setRequestHeaders :: + [HttpRequestHeader] + -> HTTP.Request + -> HTTP.Request setRequestHeaders opts = - setRequestHeaders' (trOpt disallowCompressionByDefault opts) - where - setRequestHeaders' :: [HTTP.Header] -> HTTP.Request -> HTTP.Request - setRequestHeaders' = foldr (\(name, val) f -> f . HTTP.setRequestHeader name [val]) id + setRequestHeaders' (trOpt disallowCompressionByDefault opts) + where + setRequestHeaders' :: [HTTP.Header] -> HTTP.Request -> HTTP.Request + setRequestHeaders' = + foldr (\(name, val) f -> f . HTTP.setRequestHeader name [val]) id - trOpt :: [(HTTP.HeaderName, [ByteString])] - -> [HttpRequestHeader] - -> [HTTP.Header] - trOpt acc [] = - map finalizeHeader acc - trOpt acc (HttpRequestMaxAge0:os) = - trOpt (insert HTTP.hCacheControl ["max-age=0"] acc) os - trOpt acc (HttpRequestNoTransform:os) = - trOpt (insert HTTP.hCacheControl ["no-transform"] acc) os + trOpt :: + [(HTTP.HeaderName, [ByteString])] + -> [HttpRequestHeader] + -> [HTTP.Header] + trOpt acc [] = + map finalizeHeader acc + trOpt acc (HttpRequestMaxAge0:os) = + trOpt (insert HTTP.hCacheControl ["max-age=0"] acc) os + trOpt acc (HttpRequestNoTransform:os) = + trOpt (insert HTTP.hCacheControl ["no-transform"] acc) os - -- disable content compression (potential security issue) - disallowCompressionByDefault :: [(HTTP.HeaderName, [ByteString])] - disallowCompressionByDefault = [(hAcceptEncoding, [])] + -- disable content compression (potential security issue) + disallowCompressionByDefault :: [(HTTP.HeaderName, [ByteString])] + disallowCompressionByDefault = [(hAcceptEncoding, [])] - -- Some headers are comma-separated, others need multiple headers for - -- multiple options. - -- - -- TODO: Right we we just comma-separate all of them. - finalizeHeader :: (HTTP.HeaderName, [ByteString]) - -> HTTP.Header - finalizeHeader (name, strs) = (name, BS.intercalate ", " (reverse strs)) + -- Some headers are comma-separated, others need multiple headers for + -- multiple options. + -- + -- TODO: Right we we just comma-separate all of them. + finalizeHeader :: + (HTTP.HeaderName, [ByteString]) + -> HTTP.Header + finalizeHeader (name, strs) = (name, BS.intercalate ", " (reverse strs)) - insert :: Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])] - insert _ _ [] = [] - insert x y ((k, v):pairs) - | x == k = (k, v ++ y) : insert x y pairs - | otherwise = (k, v) : insert x y pairs + insert :: Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])] + insert _ _ [] = [] + insert x y ((k, v):pairs) + | x == k = (k, v ++ y) : insert x y pairs + | otherwise = (k, v) : insert x y pairs -- | Extract the response headers getResponseHeaders :: HTTP.Response a -> [HttpResponseHeader] -getResponseHeaders response = concat [ - [ HttpResponseAcceptRangesBytes - | (hAcceptRanges, "bytes") `elem` headers - ] - ] - where - headers = HTTP.getResponseHeaders response +getResponseHeaders response = + [ HttpResponseAcceptRangesBytes | (hAcceptRanges, "bytes") `elem` headers ] + where + headers = HTTP.getResponseHeaders response
src/Pantry.hs view
@@ -1,1935 +1,2008 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE LambdaCase #-} --- | Content addressable Haskell package management, providing for --- secure, reproducible acquisition of Haskell package contents and --- metadata. --- --- @since 0.1.0.0 -module Pantry - ( -- * Running - PantryConfig - , PackageIndexConfig (..) - , HackageSecurityConfig (..) - , defaultPackageIndexConfig - , defaultDownloadPrefix - , defaultHackageSecurityConfig - , defaultCasaRepoPrefix - , defaultCasaMaxPerRequest - , defaultSnapshotLocation - , HasPantryConfig (..) - , withPantryConfig - , HpackExecutable (..) - - -- ** Convenience - , PantryApp - , runPantryApp - , runPantryAppClean - , runPantryAppWith - , hpackExecutableL - - -- * Types - - -- ** Exceptions - , PantryException (..) - , Mismatch (..) - , FuzzyResults (..) - - -- ** Cabal types - , PackageName - , Version - , FlagName - , PackageIdentifier (..) - - -- ** Files - , FileSize (..) - , RelFilePath (..) - , ResolvedPath (..) - , Unresolved - , SafeFilePath - , mkSafeFilePath - - -- ** Cryptography - , SHA256 - , TreeKey (..) - , BlobKey (..) - - -- ** Packages - , RawPackageMetadata (..) - , PackageMetadata (..) - , Package (..) - - -- ** Hackage - , CabalFileInfo (..) - , Revision (..) - , PackageIdentifierRevision (..) - , UsePreferredVersions (..) - - -- ** Archives - , RawArchive (..) - , Archive (..) - , ArchiveLocation (..) - - -- ** Repos - , Repo (..) - , RepoType (..) - , SimpleRepo (..) - , withRepo - , fetchRepos - , fetchReposRaw - - -- ** Package location - , RawPackageLocation (..) - , PackageLocation (..) - , toRawPL - , RawPackageLocationImmutable (..) - , PackageLocationImmutable (..) - - -- ** Snapshots - , RawSnapshotLocation (..) - , SnapshotLocation (..) - , toRawSL - , RawSnapshot (..) - , Snapshot (..) - , RawSnapshotPackage (..) - , SnapshotPackage (..) - , RawSnapshotLayer (..) - , SnapshotLayer (..) - , toRawSnapshotLayer - , WantedCompiler (..) - , SnapName (..) - , snapshotLocation - - -- * Loading values - , resolvePaths - , loadPackageRaw - , tryLoadPackageRawViaCasa - , loadPackage - , loadRawSnapshotLayer - , loadSnapshotLayer - , loadSnapshot - , loadAndCompleteSnapshot - , loadAndCompleteSnapshot' - , loadAndCompleteSnapshotRaw - , loadAndCompleteSnapshotRaw' - , CompletedSL (..) - , CompletedPLI (..) - , addPackagesToSnapshot - , AddPackagesConfig (..) - - -- * Completion functions - , CompletePackageLocation (..) - , completePackageLocation - , completeSnapshotLocation - , warnMissingCabalFile - - -- * Parsers - , parseWantedCompiler - , parseSnapName - , parseRawSnapshotLocation - , parsePackageIdentifierRevision - , parseHackageText - - -- ** Cabal values - , parsePackageIdentifier - , parsePackageName - , parsePackageNameThrowing - , parseFlagName - , parseVersion - , parseVersionThrowing - - -- * Cabal helpers - , packageIdentifierString - , packageNameString - , flagNameString - , versionString - , moduleNameString - , CabalString (..) - , toCabalStringMap - , unCabalStringMap - , gpdPackageIdentifier - , gpdPackageName - , gpdVersion - - -- * Package location - , fetchPackages - , unpackPackageLocationRaw - , unpackPackageLocation - , getPackageLocationName - , getRawPackageLocationIdent - , packageLocationIdent - , packageLocationVersion - , getRawPackageLocationTreeKey - , getPackageLocationTreeKey - - -- * Cabal files - , loadCabalFileRaw - , loadCabalFile - , loadCabalFileRawImmutable - , loadCabalFileImmutable - , loadCabalFilePath - , findOrGenerateCabalFile - , PrintWarnings (..) - - -- * Hackage index - , updateHackageIndex - , DidUpdateOccur (..) - , RequireHackageIndex (..) - , hackageIndexTarballL - , getHackagePackageVersions - , getLatestHackageVersion - , getLatestHackageLocation - , getLatestHackageRevision - , getHackageTypoCorrections - , loadGlobalHints - , partitionReplacedDependencies - - -- * Snapshot cache - , SnapshotCacheHash (..) - , withSnapshotCache - ) where - -import Database.Persist (entityKey) -import RIO -#if !MIN_VERSION_rio(0,1,17) -import Data.Bifunctor (bimap) -#endif -import Conduit -import Control.Arrow (right) -import Control.Monad.State.Strict (State, execState, get, modify') -import qualified RIO.Map as Map -import qualified RIO.Set as Set -import qualified RIO.ByteString as B -import qualified RIO.Text as T -import qualified RIO.List as List -import qualified RIO.FilePath as FilePath -import Pantry.Archive -import Pantry.Casa -import Casa.Client (thParserCasaRepo, CasaRepoPrefix) -import Pantry.Repo -import qualified Pantry.SHA256 as SHA256 -import Pantry.Storage hiding (TreeEntry, PackageName, Version, findOrGenerateCabalFile) -import Pantry.Tree -import Pantry.Types as P -import Pantry.Hackage -import Path (Path, Abs, File, toFilePath, Dir, (</>), filename, parseAbsDir, parent, parseRelFile) -import Path.IO (doesFileExist, resolveDir', listDir) -import Distribution.PackageDescription (GenericPackageDescription, FlagName) -import qualified Distribution.PackageDescription as D -import Distribution.Parsec (PWarning (..), showPos) -import qualified Hpack -import qualified Hpack.Config as Hpack -import Network.HTTP.Download -import RIO.PrettyPrint -import RIO.PrettyPrint.StylesUpdate -import RIO.Process -import RIO.Text (unpack) -import RIO.Directory (getAppUserDataDirectory) -import qualified Data.Yaml as Yaml -import Pantry.Internal.AesonExtended (WithJSONWarnings (..), Value) -import Data.Aeson.Types (parseEither) -import Data.Monoid (Endo (..)) -import Pantry.HTTP -import Data.Char (isHexDigit) -import Data.Time (getCurrentTime, diffUTCTime) - -import Data.Yaml.Include (decodeFileWithWarnings) -import Hpack.Yaml (formatWarning) -import Hpack.Error (formatHpackError) -import System.IO.Error (isDoesNotExistError) - -decodeYaml :: FilePath -> IO (Either String ([String], Value)) -decodeYaml file = do - bimap displayException (first formatWarnings) <$> decodeFileWithWarnings file - where - formatWarnings = map (formatWarning file) - -formatYamlParseError :: FilePath -> Yaml.ParseException -> String -formatYamlParseError file e = - "In respect of an Hpack defaults file:\n" - <> file - <> ":\n\n" - <> displayException e - --- | Create a new 'PantryConfig' with the given settings. --- --- For something easier to use in simple cases, see 'runPantryApp'. --- --- @since 0.1.0.0 -withPantryConfig - :: HasLogFunc env - => Path Abs Dir - -- ^ pantry root directory, where the SQLite database and Hackage - -- downloads are kept. - -> PackageIndexConfig - -- ^ Package index configuration. You probably want - -- 'defaultPackageIndexConfig'. - -> HpackExecutable - -- ^ When converting an hpack @package.yaml@ file to a cabal file, - -- what version of hpack should we use? - -> Int - -- ^ Maximum connection count - -> CasaRepoPrefix - -- ^ The casa pull URL e.g. https://casa.fpcomplete.com/v1/pull. - -> Int - -- ^ Max casa keys to pull per request. - -> (SnapName -> RawSnapshotLocation) - -- ^ The location of snapshot synonyms - -> (PantryConfig -> RIO env a) - -- ^ What to do with the config - -> RIO env a -withPantryConfig root pic he count pullURL maxPerRequest snapLoc inner = do - env <- ask - pantryRelFile <- parseRelFile "pantry.sqlite3" - -- Silence persistent's logging output, which is really noisy - runRIO (mempty :: LogFunc) $ initStorage (root </> pantryRelFile) $ \storage -> runRIO env $ do - ur <- newMVar True - ref1 <- newIORef mempty - ref2 <- newIORef mempty - inner PantryConfig - { pcPackageIndex = pic - , pcHpackExecutable = he - , pcRootDir = root - , pcStorage = storage - , pcUpdateRef = ur - , pcConnectionCount = count - , pcParsedCabalFilesRawImmutable = ref1 - , pcParsedCabalFilesMutable = ref2 - , pcCasaRepoPrefix = pullURL - , pcCasaMaxPerRequest = maxPerRequest - , pcSnapshotLocation = snapLoc - } - --- | Default pull URL for Casa. --- --- @since 0.1.1.1 -defaultCasaRepoPrefix :: CasaRepoPrefix -defaultCasaRepoPrefix = $(thParserCasaRepo "https://casa.fpcomplete.com") - --- | Default max keys to pull per request. --- --- @since 0.1.1.1 -defaultCasaMaxPerRequest :: Int -defaultCasaMaxPerRequest = 1280 - --- | Default 'PackageIndexConfig' value using the official Hackage server. --- --- @since 0.6.0 -defaultPackageIndexConfig :: PackageIndexConfig -defaultPackageIndexConfig = PackageIndexConfig - { picDownloadPrefix = defaultDownloadPrefix - , picHackageSecurityConfig = defaultHackageSecurityConfig - } - --- | The download prefix for the official Hackage server. --- --- @since 0.6.0 -defaultDownloadPrefix :: Text -defaultDownloadPrefix = "https://hackage.haskell.org/" - --- | Returns the latest version of the given package available from --- Hackage. --- --- @since 0.1.0.0 -getLatestHackageVersion - :: (HasPantryConfig env, HasLogFunc env) - => RequireHackageIndex - -> PackageName -- ^ package name - -> UsePreferredVersions - -> RIO env (Maybe PackageIdentifierRevision) -getLatestHackageVersion req name preferred = - ((fmap fst . Map.maxViewWithKey) >=> go) <$> getHackagePackageVersions req preferred name - where - go (version, m) = do - (_rev, BlobKey sha size) <- fst <$> Map.maxViewWithKey m - pure $ PackageIdentifierRevision name version $ CFIHash sha $ Just size - --- | Returns location of the latest version of the given package available from --- Hackage. --- --- @since 0.1.0.0 -getLatestHackageLocation - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => RequireHackageIndex - -> PackageName -- ^ package name - -> UsePreferredVersions - -> RIO env (Maybe PackageLocationImmutable) -getLatestHackageLocation req name preferred = do - mversion <- - fmap fst . Map.maxViewWithKey <$> getHackagePackageVersions req preferred name - let mVerCfKey = do - (version, revisions) <- mversion - (_rev, cfKey) <- fst <$> Map.maxViewWithKey revisions - pure (version, cfKey) - - forM mVerCfKey $ \(version, cfKey@(BlobKey sha size)) -> do - let pir = PackageIdentifierRevision name version (CFIHash sha (Just size)) - treeKey' <- getHackageTarballKey pir - pure $ PLIHackage (PackageIdentifier name version) cfKey treeKey' - --- | Returns the latest revision of the given package version available from --- Hackage. --- --- @since 0.1.0.0 -getLatestHackageRevision - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => RequireHackageIndex - -> PackageName -- ^ package name - -> Version - -> RIO env (Maybe (Revision, BlobKey, TreeKey)) -getLatestHackageRevision req name version = do - revisions <- getHackagePackageVersionRevisions req name version - case fmap fst $ Map.maxViewWithKey revisions of - Nothing -> pure Nothing - Just (revision, cfKey@(BlobKey sha size)) -> do - let cfi = CFIHash sha (Just size) - treeKey' <- getHackageTarballKey (PackageIdentifierRevision name version cfi) - return $ Just (revision, cfKey, treeKey') - --- | Fetch keys and blobs and insert into the database where possible. -fetchTreeKeys :: - (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => [RawPackageLocationImmutable] - -> RIO env () -fetchTreeKeys treeKeys = do - pure () - -- Find all tree keys that are missing from the database. - packageLocationsMissing :: [RawPackageLocationImmutable] <- - withStorage - (filterM - (fmap isNothing . maybe (pure Nothing) getTreeForKey . getRawTreeKey) - treeKeys) - pullTreeStart <- liftIO getCurrentTime - -- Pull down those tree keys from Casa, automatically inserting into - -- our local database. - treeKeyBlobs :: Map TreeKey P.Tree <- - handleAny (const mempty) - (fmap - Map.fromList - (withStorage - (runConduitRes - (casaBlobSource - (fmap unTreeKey (mapMaybe getRawTreeKey packageLocationsMissing)) .| - mapMC parseTreeM .| - sinkList)))) - pullTreeEnd <- liftIO getCurrentTime - let pulledPackages = - mapMaybe - (\treeKey' -> - List.find - ((== Just treeKey') . getRawTreeKey) - packageLocationsMissing) - (Map.keys treeKeyBlobs) - -- Pull down all unique file blobs. - let uniqueFileBlobKeys :: Set BlobKey - uniqueFileBlobKeys = - foldMap - (\(P.TreeMap files) -> Set.fromList (map teBlob (toList files))) - treeKeyBlobs - pullBlobStart <- liftIO getCurrentTime - mpulledBlobKeys :: Maybe Int <- - handleAny (const (pure Nothing)) - (fmap Just (withStorage - (runConduitRes - (casaBlobSource uniqueFileBlobKeys .| mapC (const 1) .| sumC)))) - for_ mpulledBlobKeys $ \pulledBlobKeys -> do - pullBlobEnd <- liftIO getCurrentTime - logDebug - ("Pulled from Casa: " <> - mconcat (List.intersperse ", " (map display pulledPackages)) <> - " (" <> - display (T.pack (show (diffUTCTime pullTreeEnd pullTreeStart))) <> - "), " <> - plural pulledBlobKeys "file" <> - " (" <> - display (T.pack (show (diffUTCTime pullBlobEnd pullBlobStart))) <> - ")") - -- Store the tree for each missing package. - for_ - packageLocationsMissing - (\rawPackageLocationImmutable -> - let mkey = getRawTreeKey rawPackageLocationImmutable - in case mkey of - Nothing -> - logDebug - ("Ignoring package with no tree key " <> - display rawPackageLocationImmutable <> - ", can't look in Casa for it.") - Just key -> - case Map.lookup key treeKeyBlobs of - Nothing -> - logDebug - ("Package key " <> display key <> " (" <> - display rawPackageLocationImmutable <> - ") not returned from Casa.") - Just tree -> do - identifier <- - getRawPackageLocationIdent rawPackageLocationImmutable - case findCabalOrHpackFile rawPackageLocationImmutable tree of - Just buildFile -> withStorage $ do - ecachedTree <- loadCachedTree tree - case ecachedTree of - Left e -> - lift $ logWarn - ("Loading cached tree after download from Casa failed on " <> - display rawPackageLocationImmutable <> ": " <> - displayShow e) - Right cachedTree -> - void $ storeTree - rawPackageLocationImmutable - identifier - cachedTree - buildFile - Nothing -> - logWarn - ("Unable to find build file for package: " <> - display rawPackageLocationImmutable)) - where - unTreeKey :: TreeKey -> BlobKey - unTreeKey (P.TreeKey blobKey) = blobKey - --- | Download all of the packages provided into the local cache --- without performing any unpacking. Can be useful for build tools --- wanting to prefetch or provide an offline mode. --- --- @since 0.1.0.0 -fetchPackages - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env, Foldable f) - => f PackageLocationImmutable - -> RIO env () -fetchPackages pls = do - fetchTreeKeys (fmap toRawPLI (toList pls)) - traverseConcurrently_ (void . uncurry getHackageTarball) hackages - -- TODO in the future, be concurrent in these as well - fetchArchives archives - fetchRepos repos - where - s x = Endo (x:) - run (Endo f) = f [] - (hackagesE, archivesE, reposE) = foldMap go pls - hackages = run hackagesE - archives = run archivesE - repos = run reposE - - go (PLIHackage ident cfHash tree) = (s (toPir ident cfHash, Just tree), mempty, mempty) - go (PLIArchive archive pm) = (mempty, s (archive, pm), mempty) - go (PLIRepo repo pm) = (mempty, mempty, s (repo, pm)) - - toPir (PackageIdentifier name ver) (BlobKey sha size) = - PackageIdentifierRevision name ver (CFIHash sha (Just size)) - --- | Unpack a given 'RawPackageLocationImmutable' into the given --- directory. Does not generate any extra subdirectories. --- --- @since 0.1.0.0 -unpackPackageLocationRaw - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => Path Abs Dir -- ^ unpack directory - -> RawPackageLocationImmutable - -> RIO env () -unpackPackageLocationRaw fp loc = loadPackageRaw loc >>= unpackTree loc fp . packageTree - --- | Unpack a given 'PackageLocationImmutable' into the given --- directory. Does not generate any extra subdirectories. --- --- @since 0.1.0.0 -unpackPackageLocation - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => Path Abs Dir -- ^ unpack directory - -> PackageLocationImmutable - -> RIO env () -unpackPackageLocation fp loc = loadPackage loc >>= unpackTree (toRawPLI loc) fp . packageTree - --- | Load the cabal file for the given 'PackageLocationImmutable'. --- --- This function ignores all warnings. --- --- @since 0.1.0.0 -loadCabalFileImmutable - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => PackageLocationImmutable - -> RIO env GenericPackageDescription -loadCabalFileImmutable loc = withCache $ do - logDebug $ "Parsing cabal file for " <> display loc - bs <- loadCabalFileBytes loc - (_warnings, gpd) <- rawParseGPD (Left $ toRawPLI loc) bs - let pm = - case loc of - PLIHackage (PackageIdentifier name version) _cfHash mtree -> PackageMetadata - { pmIdent = PackageIdentifier name version - , pmTreeKey = mtree - } - PLIArchive _ pm' -> pm' - PLIRepo _ pm' -> pm' - let exc = MismatchedPackageMetadata (toRawPLI loc) (toRawPM pm) Nothing - (gpdPackageIdentifier gpd) - PackageIdentifier name ver = pmIdent pm - maybe (throwIO exc) pure $ do - guard $ name == gpdPackageName gpd - guard $ ver == gpdVersion gpd - pure gpd - where - withCache inner = do - let rawLoc = toRawPLI loc - ref <- view $ pantryConfigL.to pcParsedCabalFilesRawImmutable - m0 <- readIORef ref - case Map.lookup rawLoc m0 of - Just x -> pure x - Nothing -> do - x <- inner - atomicModifyIORef' ref $ \m -> (Map.insert rawLoc x m, x) - --- | Load the cabal file for the given 'RawPackageLocationImmutable'. --- --- This function ignores all warnings. --- --- Note that, for now, this will not allow support for hpack files in --- these package locations. Instead, all @PackageLocationImmutable@s --- will require a .cabal file. This may be relaxed in the future. --- --- @since 0.1.0.0 -loadCabalFileRawImmutable - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => RawPackageLocationImmutable - -> RIO env GenericPackageDescription -loadCabalFileRawImmutable loc = withCache $ do - logDebug $ "Parsing cabal file for " <> display loc - bs <- loadRawCabalFileBytes loc - (_warnings, gpd) <- rawParseGPD (Left loc) bs - let rpm = - case loc of - RPLIHackage (PackageIdentifierRevision name version _cfi) mtree -> RawPackageMetadata - { rpmName = Just name - , rpmVersion = Just version - , rpmTreeKey = mtree - } - RPLIArchive _ rpm' -> rpm' - RPLIRepo _ rpm' -> rpm' - let exc = MismatchedPackageMetadata loc rpm Nothing (gpdPackageIdentifier gpd) - maybe (throwIO exc) pure $ do - guard $ maybe True (== gpdPackageName gpd) (rpmName rpm) - guard $ maybe True (== gpdVersion gpd) (rpmVersion rpm) - pure gpd - where - withCache inner = do - ref <- view $ pantryConfigL.to pcParsedCabalFilesRawImmutable - m0 <- readIORef ref - case Map.lookup loc m0 of - Just x -> pure x - Nothing -> do - x <- inner - atomicModifyIORef' ref $ \m -> (Map.insert loc x m, x) - --- | Same as 'loadCabalFileRawImmutable', but takes a 'RawPackageLocation'. --- Never prints warnings, see 'loadCabalFilePath' for that. --- --- @since 0.8.0 -loadCabalFileRaw - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => Maybe Text -- ^ The program name used by Hpack (the library), defaults to - -- \"hpack\". - -> RawPackageLocation - -> RIO env GenericPackageDescription -loadCabalFileRaw _ (RPLImmutable loc) = loadCabalFileRawImmutable loc -loadCabalFileRaw progName (RPLMutable rfp) = do - (gpdio, _, _) <- loadCabalFilePath progName (resolvedAbsolute rfp) - liftIO $ gpdio NoPrintWarnings - --- | Same as 'loadCabalFileImmutable', but takes a 'PackageLocation'. Never --- prints warnings, see 'loadCabalFilePath' for that. --- --- @since 0.8.0 -loadCabalFile - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => Maybe Text -- ^ The program name used by Hpack (the library), defaults to - -- \"hpack\". - -> PackageLocation - -> RIO env GenericPackageDescription -loadCabalFile _ (PLImmutable loc) = loadCabalFileImmutable loc -loadCabalFile progName (PLMutable rfp) = do - (gpdio, _, _) <- loadCabalFilePath progName (resolvedAbsolute rfp) - liftIO $ gpdio NoPrintWarnings - --- | Parse the Cabal file for the package inside the given directory. Performs --- various sanity checks, such as the file name being correct and having only a --- single Cabal file. --- --- @since 0.8.0 -loadCabalFilePath - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => Maybe Text -- ^ The program name used by Hpack (the library), defaults to - -- \"hpack\". - -> Path Abs Dir -- ^ project directory, with a cabal file or hpack file - -> RIO env - ( PrintWarnings -> IO GenericPackageDescription - , PackageName - , Path Abs File - ) -loadCabalFilePath progName dir = do - ref <- view $ pantryConfigL.to pcParsedCabalFilesMutable - mcached <- Map.lookup dir <$> readIORef ref - case mcached of - Just triple -> pure triple - Nothing -> do - (name, cabalfp) <- findOrGenerateCabalFile progName dir - gpdRef <- newIORef Nothing - run <- askRunInIO - let gpdio = run . getGPD cabalfp gpdRef - triple = (gpdio, name, cabalfp) - atomicModifyIORef' ref $ \m -> (Map.insert dir triple m, triple) - where - getGPD cabalfp gpdRef printWarnings = do - mpair <- readIORef gpdRef - (warnings0, gpd) <- - case mpair of - Just pair -> pure pair - Nothing -> do - bs <- liftIO $ B.readFile $ toFilePath cabalfp - (warnings0, gpd) <- rawParseGPD (Right cabalfp) bs - checkCabalFileName (gpdPackageName gpd) cabalfp - pure (warnings0, gpd) - warnings <- - case printWarnings of - YesPrintWarnings -> mapM_ (logWarn . toPretty cabalfp) warnings0 $> [] - NoPrintWarnings -> pure warnings0 - writeIORef gpdRef $ Just (warnings, gpd) - pure gpd - - toPretty :: Path Abs File -> PWarning -> Utf8Builder - toPretty src (PWarning _type pos msg) = - "Cabal file warning in " <> - fromString (toFilePath src) <> "@" <> - fromString (showPos pos) <> ": " <> - fromString msg - - -- | Check if the given name in the @Package@ matches the name of the .cabal file - checkCabalFileName :: MonadThrow m => PackageName -> Path Abs File -> m () - checkCabalFileName name cabalfp = do - -- Previously, we just use parsePackageNameFromFilePath. However, that can - -- lead to confusing error messages. See: - -- https://github.com/commercialhaskell/stack/issues/895 - let expected = T.unpack $ unSafeFilePath $ cabalFileName name - when (expected /= toFilePath (filename cabalfp)) - $ throwM $ MismatchedCabalName cabalfp name - --- | Get the file name for the Cabal file in the given directory. --- --- If no Cabal file is present, or more than one is present, an exception is --- thrown via 'throwM'. --- --- If the directory contains a file named package.yaml, Hpack is used to --- generate a Cabal file from it. --- --- @since 0.8.0 -findOrGenerateCabalFile - :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => Maybe Text -- ^ The program name used by Hpack (the library), defaults to - -- \"hpack\". - -> Path Abs Dir -- ^ package directory - -> RIO env (PackageName, Path Abs File) -findOrGenerateCabalFile progName pkgDir = do - let hpackProgName = fromString . unpack <$> progName - hpack hpackProgName pkgDir - (_, allFiles) <- listDir pkgDir `catchIO` \e -> if isDoesNotExistError e - then throwIO $ NoLocalPackageDirFound pkgDir - else throwIO e - let files = filter (flip hasExtension "cabal" . toFilePath) allFiles - -- If there are multiple files, ignore files that start with - -- ".". On unixlike environments these are hidden, and this - -- character is not valid in package names. The main goal is - -- to ignore emacs lock files - see - -- https://github.com/commercialhaskell/stack/issues/1897. - let isHidden ('.':_) = True - isHidden _ = False - case filter (not . isHidden . toFilePath . filename) files of - [] -> throwIO $ NoCabalFileFound pkgDir - [x] -> maybe - (throwIO $ InvalidCabalFilePath x) - (\pn -> pure $ (pn, x)) $ - List.stripSuffix ".cabal" (toFilePath (filename x)) >>= - parsePackageName - _:_ -> throwIO $ MultipleCabalFilesFound pkgDir files - where hasExtension fp x = FilePath.takeExtension fp == "." ++ x - --- | Generate Cabal file from package.yaml, if necessary. -hpack - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => Maybe Hpack.ProgramName -- ^ The program name used by Hpack (the library). - -> Path Abs Dir - -> RIO env () -hpack progName pkgDir = do - packageConfigRelFile <- parseRelFile Hpack.packageConfig - let hpackFile = pkgDir </> packageConfigRelFile - mHpackProgName = maybe id Hpack.setProgramName progName - exists <- liftIO $ doesFileExist hpackFile - when exists $ do - logDebug $ "Running Hpack on " <> fromString (toFilePath hpackFile) - - he <- view $ pantryConfigL.to pcHpackExecutable - case he of - HpackBundled -> - liftIO - ( Hpack.hpackResultWithError - $ mHpackProgName - $ Hpack.setDecode decodeYaml - $ Hpack.setFormatYamlParseError formatYamlParseError - $ Hpack.setTarget - (toFilePath hpackFile) Hpack.defaultOptions - ) - >>= \ case - Left err -> throwIO (HpackLibraryException hpackFile $ formatHpackError (fromMaybe "hpack" progName) err) - Right r -> do - forM_ (Hpack.resultWarnings r) (logWarn . fromString) - let cabalFile = fromString . Hpack.resultCabalFile $ r - case Hpack.resultStatus r of - Hpack.Generated -> - logDebug $ "Hpack generated a modified version of " - <> cabalFile - Hpack.OutputUnchanged -> - logDebug $ "Hpack output unchanged in " <> cabalFile - Hpack.AlreadyGeneratedByNewerHpack -> logWarn $ - cabalFile <> - " was generated with a newer version of Hpack. Ignoring " <> - fromString (toFilePath hpackFile) <> - " in favor of the Cabal file.\n" <> - "Either please upgrade and try again or, if you want to use the " <> - fromString (toFilePath (filename hpackFile)) <> - " file instead of the Cabal file,\n" <> - "then please delete the Cabal file." - Hpack.ExistingCabalFileWasModifiedManually -> logWarn $ - cabalFile <> - " was modified manually. Ignoring " <> - fromString (toFilePath hpackFile) <> - " in favor of the Cabal file.\n" <> - "If you want to use the " <> - fromString (toFilePath (filename hpackFile)) <> - " file instead of the Cabal file,\n" <> - "then please delete the Cabal file." - HpackCommand command -> catchAny - ( withWorkingDir (toFilePath pkgDir) $ - proc command [] runProcess_ - ) - ( throwIO . HpackExeException command pkgDir) - --- | Get the 'PackageIdentifier' from a 'GenericPackageDescription'. --- --- @since 0.1.0.0 -gpdPackageIdentifier :: GenericPackageDescription -> PackageIdentifier -gpdPackageIdentifier = D.package . D.packageDescription - --- | Get the 'PackageName' from a 'GenericPackageDescription'. --- --- @since 0.1.0.0 -gpdPackageName :: GenericPackageDescription -> PackageName -gpdPackageName = pkgName . gpdPackageIdentifier - --- | Get the 'Version' from a 'GenericPackageDescription'. --- --- @since 0.1.0.0 -gpdVersion :: GenericPackageDescription -> Version -gpdVersion = pkgVersion . gpdPackageIdentifier - -loadCabalFileBytes - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => PackageLocationImmutable - -> RIO env ByteString - --- Just ignore the mtree for this. Safe assumption: someone who filled --- in the TreeKey also filled in the cabal file hash, and that's a --- more efficient lookup mechanism. -loadCabalFileBytes (PLIHackage pident cfHash _mtree) = getHackageCabalFile (pirForHash pident cfHash) - -loadCabalFileBytes pl = do - package <- loadPackage pl - let sfp = cabalFileName $ pkgName $ packageIdent package - cabalBlobKey <- case (packageCabalEntry package) of - PCHpack pcHpack -> pure $ teBlob . phGenerated $ pcHpack - PCCabalFile (TreeEntry blobKey _) -> pure blobKey - mbs <- withStorage $ loadBlob cabalBlobKey - case mbs of - Nothing -> do - throwIO $ TreeReferencesMissingBlob (toRawPLI pl) sfp cabalBlobKey - Just bs -> pure bs - --- FIXME: to be removed -loadRawCabalFileBytes - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => RawPackageLocationImmutable - -> RIO env ByteString - --- Just ignore the mtree for this. Safe assumption: someone who filled --- in the TreeKey also filled in the cabal file hash, and that's a --- more efficient lookup mechanism. -loadRawCabalFileBytes (RPLIHackage pir _mtree) = getHackageCabalFile pir - -loadRawCabalFileBytes pl = do - package <- loadPackageRaw pl - let sfp = cabalFileName $ pkgName $ packageIdent package - TreeEntry cabalBlobKey _ft = case packageCabalEntry package of - PCCabalFile cabalTE -> cabalTE - PCHpack hpackCE -> phGenerated hpackCE - mbs <- withStorage $ loadBlob cabalBlobKey - case mbs of - Nothing -> do - throwIO $ TreeReferencesMissingBlob pl sfp cabalBlobKey - Just bs -> pure bs - --- | Load a 'Package' from a 'PackageLocationImmutable'. --- --- @since 0.1.0.0 -loadPackage - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => PackageLocationImmutable - -> RIO env Package -loadPackage = loadPackageRaw . toRawPLI - --- | Load a 'Package' from a 'RawPackageLocationImmutable'. --- --- Load the package either from the local DB, Casa, or as a last --- resort, the third party (hackage, archive or repo). --- --- @since 0.1.0.0 -loadPackageRaw - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => RawPackageLocationImmutable - -> RIO env Package -loadPackageRaw rpli = do - case getRawTreeKey rpli of - Just treeKey' -> do - mpackage <- tryLoadPackageRawViaDbOrCasa rpli treeKey' - case mpackage of - Nothing -> loadPackageRawViaThirdParty - Just package -> pure package - Nothing -> loadPackageRawViaThirdParty - where - loadPackageRawViaThirdParty = do - logDebug ("Loading package from third-party: " <> display rpli) - case rpli of - RPLIHackage pir mtree -> htrPackage <$> getHackageTarball pir mtree - RPLIArchive archive pm -> getArchivePackage rpli archive pm - RPLIRepo repo rpm -> getRepo repo rpm - --- | Try to load a package via the database or Casa. -tryLoadPackageRawViaDbOrCasa :: - (HasLogFunc env, HasPantryConfig env, HasProcessContext env) - => RawPackageLocationImmutable - -> TreeKey - -> RIO env (Maybe Package) -tryLoadPackageRawViaDbOrCasa rpli treeKey' = do - mviaDb <- tryLoadPackageRawViaLocalDb rpli treeKey' - case mviaDb of - Just package -> do - logDebug ("Loaded package from Pantry: " <> display rpli) - pure (Just package) - Nothing -> do - mviaCasa <- tryLoadPackageRawViaCasa rpli treeKey' - case mviaCasa of - Just package -> do - logDebug ("Loaded package from Casa: " <> display rpli) - pure (Just package) - Nothing -> pure Nothing - --- | Maybe load the package from Casa. -tryLoadPackageRawViaCasa :: - (HasLogFunc env, HasPantryConfig env, HasProcessContext env) - => RawPackageLocationImmutable - -> TreeKey - -> RIO env (Maybe Package) -tryLoadPackageRawViaCasa rlpi treeKey' = do - mtreePair <- casaLookupTree treeKey' - case mtreePair of - Nothing -> pure Nothing - Just (treeKey'', _tree) -> do - fetchTreeKeys [rlpi] - mdb <- tryLoadPackageRawViaLocalDb rlpi treeKey'' - case mdb of - Nothing -> do - logWarn - ("Did not find tree key in DB after pulling it from Casa: " <> - display treeKey'' <> - " (for " <> - display rlpi <> - ")") - pure Nothing - Just package -> pure (Just package) - --- | Maybe load the package from the local database. -tryLoadPackageRawViaLocalDb :: - (HasLogFunc env, HasPantryConfig env, HasProcessContext env) - => RawPackageLocationImmutable - -> TreeKey - -> RIO env (Maybe Package) -tryLoadPackageRawViaLocalDb rlpi treeKey' = do - mtreeEntity <- withStorage (getTreeForKey treeKey') - case mtreeEntity of - Nothing -> pure Nothing - Just treeId -> - fmap Just (withStorage (loadPackageById rlpi (entityKey treeId))) - --- | Complete package location, plus whether the package has a cabal file. This --- is relevant to reproducibility, see --- <https://tech.fpcomplete.com/blog/storing-generated-cabal-files> --- --- @since 0.4.0.0 -data CompletePackageLocation = CompletePackageLocation - { cplComplete :: !PackageLocationImmutable - , cplHasCabalFile :: !Bool - } - --- | Fill in optional fields in a 'PackageLocationImmutable' for more reproducible builds. --- --- @since 0.1.0.0 -completePackageLocation - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => RawPackageLocationImmutable - -> RIO env CompletePackageLocation -completePackageLocation (RPLIHackage (PackageIdentifierRevision n v (CFIHash sha (Just size))) (Just tk)) = - pure CompletePackageLocation - { cplComplete = PLIHackage (PackageIdentifier n v) (BlobKey sha size) tk - , cplHasCabalFile = True - } -completePackageLocation (RPLIHackage pir0@(PackageIdentifierRevision name version cfi0) _) = do - logDebug $ "Completing package location information from " <> display pir0 - (pir, cfKey) <- - case cfi0 of - CFIHash sha (Just size) -> pure (pir0, BlobKey sha size) - _ -> do - bs <- getHackageCabalFile pir0 - let size = FileSize (fromIntegral (B.length bs)) - sha = SHA256.hashBytes bs - cfi = CFIHash sha (Just size) - pir = PackageIdentifierRevision name version cfi - logDebug $ "Added in cabal file hash: " <> display pir - pure (pir, BlobKey sha size) - treeKey' <- getHackageTarballKey pir - pure CompletePackageLocation - { cplComplete = PLIHackage (PackageIdentifier name version) cfKey treeKey' - , cplHasCabalFile = True - } -completePackageLocation pl@(RPLIArchive archive rpm) = do - mpackage <- - case rpmTreeKey rpm of - Just treeKey' -> tryLoadPackageRawViaDbOrCasa pl treeKey' - Nothing -> pure Nothing - case (,,) <$> raHash archive <*> raSize archive <*> mpackage of - Just (sha256, fileSize, package) -> do - let RawArchive loc _ _ subdir = archive - pure CompletePackageLocation - { cplComplete = PLIArchive (Archive loc sha256 fileSize subdir) (packagePM package) - , cplHasCabalFile = - case packageCabalEntry package of - PCCabalFile{} -> True - PCHpack{} -> False - } - Nothing -> byThirdParty (isJust mpackage) - where - byThirdParty warnAboutMissingSizeSha = do - (sha, size, package, _cachedTree) <- getArchive pl archive rpm - when warnAboutMissingSizeSha (warnWith sha size) - -- (getArchive checks archive and package metadata) - let RawArchive loc _ _ subdir = archive - logDebug $ fromString $ show (pl, sha, size, package) - pure CompletePackageLocation - { cplComplete = PLIArchive (Archive loc sha size subdir) (packagePM package) - , cplHasCabalFile = - case packageCabalEntry package of - PCCabalFile{} -> True - PCHpack{} -> False - } - warnWith sha size = - logWarn - (mconcat - [ "The package " - , display pl - , " is available from the local content-addressable storage database, \n" - , "but we can't use it unless you specify the size and hash for this package.\n" - , "Add the following to your package description:\n" - , "\nsize: " <> display size - , "\nsha256: " <> display sha - ]) -completePackageLocation pl@(RPLIRepo repo rpm) = do - unless (isSHA1 (repoCommit repo)) $ throwIO $ CannotCompleteRepoNonSHA1 repo - completePM repo pl rpm - where - isSHA1 t = T.length t == 40 && T.all isHexDigit t - -completePM - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => Repo - -> RawPackageLocationImmutable - -> RawPackageMetadata - -> RIO env CompletePackageLocation -completePM repo plOrig rpm@(RawPackageMetadata mn mv mtk) - | Just n <- mn, Just v <- mv, Just tk <- mtk = do - let pm = PackageMetadata (PackageIdentifier n v) tk - pure CompletePackageLocation - { cplComplete = PLIRepo repo pm - -- This next bit is a hack: we don't know for certain that this is the case. - -- However, for the use case where complete package metadata has been supplied, - -- we'll assume there's a cabal file for purposes of generating a deprecation warning. - , cplHasCabalFile = True - } - | otherwise = do - package <- loadPackageRaw plOrig - let pm = packagePM package - let isSame x (Just y) = x == y - isSame _ _ = True - - allSame = - isSame (pkgName $ pmIdent pm) (rpmName rpm) && - isSame (pkgVersion $ pmIdent pm) (rpmVersion rpm) && - isSame (pmTreeKey pm) (rpmTreeKey rpm) - if allSame - then pure CompletePackageLocation - { cplComplete = PLIRepo repo pm - , cplHasCabalFile = - case packageCabalEntry package of - PCCabalFile{} -> True - PCHpack{} -> False - } - else throwIO $ CompletePackageMetadataMismatch plOrig pm - -packagePM :: Package -> PackageMetadata -packagePM package = PackageMetadata - { pmIdent = packageIdent package - , pmTreeKey = packageTreeKey package - } - --- | Add in hashes to make a 'SnapshotLocation' reproducible. --- --- @since 0.1.0.0 -completeSnapshotLocation - :: (HasPantryConfig env, HasLogFunc env) - => RawSnapshotLocation - -> RIO env SnapshotLocation -completeSnapshotLocation (RSLCompiler c) = pure $ SLCompiler c -completeSnapshotLocation (RSLFilePath f) = pure $ SLFilePath f -completeSnapshotLocation (RSLUrl url (Just blobKey)) = pure $ SLUrl url blobKey -completeSnapshotLocation (RSLUrl url Nothing) = do - bs <- loadFromURL url Nothing - pure $ SLUrl url (bsToBlobKey bs) -completeSnapshotLocation (RSLSynonym syn) = - completeSnapshotLocation =<< snapshotLocation syn - -traverseConcurrently_ - :: (Foldable f, HasPantryConfig env) - => (a -> RIO env ()) -- ^ action to perform - -> f a -- ^ input values - -> RIO env () -traverseConcurrently_ f t0 = do - cnt <- view $ pantryConfigL.to pcConnectionCount - traverseConcurrentlyWith_ cnt f t0 - -traverseConcurrentlyWith_ - :: (MonadUnliftIO m, Foldable f) - => Int -- ^ concurrent workers - -> (a -> m ()) -- ^ action to perform - -> f a -- ^ input values - -> m () -traverseConcurrentlyWith_ count f t0 = do - queue <- newTVarIO $ toList t0 - - replicateConcurrently_ count $ - fix $ \loop -> join $ atomically $ do - toProcess <- readTVar queue - case toProcess of - [] -> pure (pure ()) - (x:rest) -> do - writeTVar queue rest - pure $ do - f x - loop - --- | Parse a 'RawSnapshot' (all layers) from a 'RawSnapshotLocation'. --- --- @since 0.1.0.0 -loadSnapshotRaw - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => RawSnapshotLocation - -> RIO env RawSnapshot -loadSnapshotRaw loc = do - eres <- loadRawSnapshotLayer loc - case eres of - Left wc -> - pure RawSnapshot - { rsCompiler = wc - , rsPackages = mempty - , rsDrop = mempty - } - Right (rsl, _) -> do - snap0 <- loadSnapshotRaw $ rslParent rsl - (packages, unused) <- - addPackagesToSnapshot - (display loc) - (rslLocations rsl) - AddPackagesConfig - { apcDrop = rslDropPackages rsl - , apcFlags = rslFlags rsl - , apcHiddens = rslHidden rsl - , apcGhcOptions = rslGhcOptions rsl - } - (rsPackages snap0) - warnUnusedAddPackagesConfig (display loc) unused - pure RawSnapshot - { rsCompiler = fromMaybe (rsCompiler snap0) (rslCompiler rsl) - , rsPackages = packages - , rsDrop = apcDrop unused - } - --- | Parse a 'RawSnapshot' (all layers) from a 'SnapshotLocation'. --- --- @since 0.1.0.0 -loadSnapshot - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => SnapshotLocation - -> RIO env RawSnapshot -loadSnapshot loc = do - eres <- loadSnapshotLayer loc - case eres of - Left wc -> - pure RawSnapshot - { rsCompiler = wc - , rsPackages = mempty - , rsDrop = mempty - } - Right rsl -> do - snap0 <- loadSnapshotRaw $ rslParent rsl - (packages, unused) <- - addPackagesToSnapshot - (display loc) - (rslLocations rsl) - AddPackagesConfig - { apcDrop = rslDropPackages rsl - , apcFlags = rslFlags rsl - , apcHiddens = rslHidden rsl - , apcGhcOptions = rslGhcOptions rsl - } - (rsPackages snap0) - warnUnusedAddPackagesConfig (display loc) unused - pure RawSnapshot - { rsCompiler = fromMaybe (rsCompiler snap0) (rslCompiler rsl) - , rsPackages = packages - , rsDrop = apcDrop unused - } - --- | A completed package location, including the original raw and completed information. --- --- @since 0.1.0.0 -data CompletedPLI = CompletedPLI !RawPackageLocationImmutable !PackageLocationImmutable - --- | A completed snapshot location, including the original raw and completed information. --- --- @since 0.1.0.0 -data CompletedSL = CompletedSL !RawSnapshotLocation !SnapshotLocation - --- | Parse a 'Snapshot' (all layers) from a 'SnapshotLocation' noting --- any incomplete package locations. Debug output will include the raw snapshot --- layer. --- --- @since 0.1.0.0 -loadAndCompleteSnapshot - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => SnapshotLocation - -> Map RawSnapshotLocation SnapshotLocation -- ^ Cached snapshot locations from lock file - -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached locations from lock file - -> RIO env (Snapshot, [CompletedSL], [CompletedPLI]) -loadAndCompleteSnapshot = loadAndCompleteSnapshot' True - --- | As for 'loadAndCompleteSnapshot' but allows toggling of the debug output of --- the raw snapshot layer. --- --- @since 0.5.7 -loadAndCompleteSnapshot' - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => Bool -- ^ Debug output includes the raw snapshot layer - -> SnapshotLocation - -> Map RawSnapshotLocation SnapshotLocation -- ^ Cached snapshot locations from lock file - -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached locations from lock file - -> RIO env (Snapshot, [CompletedSL], [CompletedPLI]) -loadAndCompleteSnapshot' debugRSL loc cachedSL cachedPL = - loadAndCompleteSnapshotRaw' debugRSL (toRawSL loc) cachedSL cachedPL - --- | Parse a 'Snapshot' (all layers) from a 'RawSnapshotLocation' completing --- any incomplete package locations. Debug output will include the raw snapshot --- layer. --- --- @since 0.1.0.0 -loadAndCompleteSnapshotRaw - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => RawSnapshotLocation - -> Map RawSnapshotLocation SnapshotLocation -- ^ Cached snapshot locations from lock file - -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached locations from lock file - -> RIO env (Snapshot, [CompletedSL], [CompletedPLI]) -loadAndCompleteSnapshotRaw = loadAndCompleteSnapshotRaw' True - --- | As for 'loadAndCompleteSnapshotRaw' but allows toggling of the debug output --- of the raw snapshot layer. --- --- @since 0.5.7 -loadAndCompleteSnapshotRaw' - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => Bool -- ^ Debug output includes the raw snapshot layer - -> RawSnapshotLocation - -> Map RawSnapshotLocation SnapshotLocation -- ^ Cached snapshot locations from lock file - -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached locations from lock file - -> RIO env (Snapshot, [CompletedSL], [CompletedPLI]) -loadAndCompleteSnapshotRaw' debugRSL rawLoc cacheSL cachePL = do - eres <- case Map.lookup rawLoc cacheSL of - Just loc -> right (\rsl -> (rsl, (CompletedSL rawLoc loc))) <$> loadSnapshotLayer loc - Nothing -> loadRawSnapshotLayer rawLoc - case eres of - Left wc -> - let snapshot = Snapshot - { snapshotCompiler = wc - , snapshotPackages = mempty - , snapshotDrop = mempty - } - in pure (snapshot, [CompletedSL (RSLCompiler wc) (SLCompiler wc)], []) - Right (rsl, sloc) -> do - (snap0, slocs, completed0) <- loadAndCompleteSnapshotRaw' debugRSL (rslParent rsl) cacheSL cachePL - when debugRSL $ logDebug $ fromString $ show rsl - (packages, completed, unused) <- - addAndCompletePackagesToSnapshot - rawLoc - cachePL - (rslLocations rsl) - AddPackagesConfig - { apcDrop = rslDropPackages rsl - , apcFlags = rslFlags rsl - , apcHiddens = rslHidden rsl - , apcGhcOptions = rslGhcOptions rsl - } - (snapshotPackages snap0) - warnUnusedAddPackagesConfig (display rawLoc) unused - let snapshot = Snapshot - { snapshotCompiler = fromMaybe (snapshotCompiler snap0) (rslCompiler rsl) - , snapshotPackages = packages - , snapshotDrop = apcDrop unused - } - return (snapshot, sloc : slocs,completed0 ++ completed) - -data SingleOrNot a - = Single !a - | Multiple !a !a !([a] -> [a]) -instance Semigroup (SingleOrNot a) where - Single a <> Single b = Multiple a b id - Single a <> Multiple b c d = Multiple a b ((c:) . d) - Multiple a b c <> Single d = Multiple a b (c . (d:)) - Multiple a b c <> Multiple d e f = - Multiple a b (c . (d:) . (e:) . f) - -sonToEither :: (k, SingleOrNot a) -> Either (k, a) (k, [a]) -sonToEither (k, Single a) = Left (k, a) -sonToEither (k, Multiple a b c) = Right (k, (a : b : c [])) - --- | Package settings to be passed to 'addPackagesToSnapshot'. --- --- @since 0.1.0.0 -data AddPackagesConfig = AddPackagesConfig - { apcDrop :: !(Set PackageName) - , apcFlags :: !(Map PackageName (Map FlagName Bool)) - , apcHiddens :: !(Map PackageName Bool) - , apcGhcOptions :: !(Map PackageName [Text]) - } - --- | Does not warn about drops, those are allowed in order to ignore global --- packages. -warnUnusedAddPackagesConfig - :: HasLogFunc env - => Utf8Builder -- ^ source - -> AddPackagesConfig - -> RIO env () -warnUnusedAddPackagesConfig source (AddPackagesConfig _drops flags hiddens options) = do - unless (null ls) $ do - logWarn $ "Some warnings discovered when adding packages to snapshot (" <> source <> ")" - traverse_ logWarn ls - where - ls = concat [flags', hiddens', options'] - - flags' = - map - (\pn -> - "Setting flags for nonexistent package: " <> - fromString (packageNameString pn)) - (Map.keys flags) - - hiddens' = - map - (\pn -> - "Hiding nonexistent package: " <> - fromString (packageNameString pn)) - (Map.keys hiddens) - - options' = - map - (\pn -> - "Setting options for nonexistent package: " <> - fromString (packageNameString pn)) - (Map.keys options) - --- | Add more packages to a snapshot --- --- Note that any settings on a parent flag which is being replaced will be --- ignored. For example, if package @foo@ is in the parent and has flag @bar@ --- set, and @foo@ also appears in new packages, then @bar@ will no longer be --- set. --- --- Returns any of the 'AddPackagesConfig' values not used. --- --- @since 0.1.0.0 -addPackagesToSnapshot - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => Utf8Builder - -- ^ Text description of where these new packages are coming from, for error - -- messages only - -> [RawPackageLocationImmutable] -- ^ new packages - -> AddPackagesConfig - -> Map PackageName RawSnapshotPackage -- ^ packages from parent - -> RIO env (Map PackageName RawSnapshotPackage, AddPackagesConfig) -addPackagesToSnapshot source newPackages (AddPackagesConfig drops flags hiddens options) old = do - new' <- for newPackages $ \loc -> do - name <- getPackageLocationName loc - pure (name, RawSnapshotPackage - { rspLocation = loc - , rspFlags = Map.findWithDefault mempty name flags - , rspHidden = Map.findWithDefault False name hiddens - , rspGhcOptions = Map.findWithDefault [] name options - }) - let (newSingles, newMultiples) - = partitionEithers - $ map sonToEither - $ Map.toList - $ Map.fromListWith (<>) - $ map (second Single) new' - unless (null $ newMultiples) $ throwIO $ - DuplicatePackageNames source $ map (second (map rspLocation)) newMultiples - let new = Map.fromList newSingles - allPackages0 = new `Map.union` (old `Map.difference` Map.fromSet (const ()) drops) - allPackages = flip Map.mapWithKey allPackages0 $ \name rsp -> - rsp - { rspFlags = Map.findWithDefault (rspFlags rsp) name flags - , rspHidden = Map.findWithDefault (rspHidden rsp) name hiddens - , rspGhcOptions = Map.findWithDefault (rspGhcOptions rsp) name options - } - - unused = AddPackagesConfig - (drops `Set.difference` Map.keysSet old) - (flags `Map.difference` allPackages) - (hiddens `Map.difference` allPackages) - (options `Map.difference` allPackages) - - pure (allPackages, unused) - -cachedSnapshotCompletePackageLocation :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => Map RawPackageLocationImmutable PackageLocationImmutable - -> RawPackageLocationImmutable - -> RIO env (Maybe PackageLocationImmutable) -cachedSnapshotCompletePackageLocation cachePackages rpli = do - let xs = Map.lookup rpli cachePackages - case xs of - Nothing -> do - cpl <- completePackageLocation rpli - pure $ if cplHasCabalFile cpl then Just (cplComplete cpl) else Nothing - Just x -> pure $ Just x - --- | Add more packages to a snapshot completing their locations if needed --- --- Note that any settings on a parent flag which is being replaced will be --- ignored. For example, if package @foo@ is in the parent and has flag @bar@ --- set, and @foo@ also appears in new packages, then @bar@ will no longer be --- set. --- --- Returns any of the 'AddPackagesConfig' values not used and also all --- non-trivial package location completions. --- --- @since 0.1.0.0 -addAndCompletePackagesToSnapshot - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => RawSnapshotLocation - -- ^ Text description of where these new packages are coming from, for error - -- messages only - -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached data from snapshot lock file - -> [RawPackageLocationImmutable] -- ^ new packages - -> AddPackagesConfig - -> Map PackageName SnapshotPackage -- ^ packages from parent - -> RIO env (Map PackageName SnapshotPackage, [CompletedPLI], AddPackagesConfig) -addAndCompletePackagesToSnapshot loc cachedPL newPackages (AddPackagesConfig drops flags hiddens options) old = do - let source = display loc - addPackage :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => ([(PackageName, SnapshotPackage)],[CompletedPLI]) - -> RawPackageLocationImmutable - -> RIO env ([(PackageName, SnapshotPackage)], [CompletedPLI]) - addPackage (ps, completed) rawLoc = do - mcomplLoc <- cachedSnapshotCompletePackageLocation cachedPL rawLoc - case mcomplLoc of - Nothing -> do - warnMissingCabalFile rawLoc - pure (ps, completed) - Just complLoc -> do - let PackageIdentifier name _ = packageLocationIdent complLoc - p = (name, SnapshotPackage - { spLocation = complLoc - , spFlags = Map.findWithDefault mempty name flags - , spHidden = Map.findWithDefault False name hiddens - , spGhcOptions = Map.findWithDefault [] name options - }) - completed' = if toRawPLI complLoc == rawLoc - then completed - else CompletedPLI rawLoc complLoc:completed - pure (p:ps, completed') - (revNew, revCompleted) <- foldM addPackage ([], []) newPackages - let (newSingles, newMultiples) - = partitionEithers - $ map sonToEither - $ Map.toList - $ Map.fromListWith (<>) - $ map (second Single) (reverse revNew) - unless (null $ newMultiples) $ throwIO $ - DuplicatePackageNames source $ map (second (map (toRawPLI . spLocation))) newMultiples - let new = Map.fromList newSingles - allPackages0 = new `Map.union` (old `Map.difference` Map.fromSet (const ()) drops) - allPackages = flip Map.mapWithKey allPackages0 $ \name sp -> - sp - { spFlags = Map.findWithDefault (spFlags sp) name flags - , spHidden = Map.findWithDefault (spHidden sp) name hiddens - , spGhcOptions = Map.findWithDefault (spGhcOptions sp) name options - } - - unused = AddPackagesConfig - (drops `Set.difference` Map.keysSet old) - (flags `Map.difference` allPackages) - (hiddens `Map.difference` allPackages) - (options `Map.difference` allPackages) - - pure (allPackages, reverse revCompleted, unused) - --- | Parse a 'SnapshotLayer' value from a 'SnapshotLocation'. --- --- Returns a 'Left' value if provided an 'SLCompiler' --- constructor. Otherwise, returns a 'Right' value providing both the --- 'Snapshot' and a hash of the input configuration file. --- --- @since 0.1.0.0 -loadRawSnapshotLayer - :: (HasPantryConfig env, HasLogFunc env) - => RawSnapshotLocation - -> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL)) -loadRawSnapshotLayer (RSLCompiler compiler) = pure $ Left compiler -loadRawSnapshotLayer rsl@(RSLUrl url blob) = - handleAny (throwIO . InvalidSnapshot rsl) $ do - bs <- loadFromURL url blob - value <- Yaml.decodeThrow bs - snapshot <- warningsParserHelperRaw rsl value Nothing - pure $ Right (snapshot, (CompletedSL rsl (SLUrl url (bsToBlobKey bs)))) -loadRawSnapshotLayer rsl@(RSLFilePath fp) = - handleAny (throwIO . InvalidSnapshot rsl) $ do - value <- Yaml.decodeFileThrow $ toFilePath $ resolvedAbsolute fp - snapshot <- warningsParserHelperRaw rsl value $ Just $ parent $ resolvedAbsolute fp - pure $ Right (snapshot, CompletedSL rsl (SLFilePath fp)) -loadRawSnapshotLayer rsl@(RSLSynonym syn) = do - loc <- snapshotLocation syn - comp <- loadRawSnapshotLayer loc - pure $ case comp of - Left wc -> Left wc - Right (l, CompletedSL _ n) -> Right (l, CompletedSL rsl n) - --- | Parse a 'SnapshotLayer' value from a 'SnapshotLocation'. --- --- Returns a 'Left' value if provided an 'SLCompiler' --- constructor. Otherwise, returns a 'Right' value providing both the --- 'Snapshot' and a hash of the input configuration file. --- --- @since 0.1.0.0 -loadSnapshotLayer - :: (HasPantryConfig env, HasLogFunc env) - => SnapshotLocation - -> RIO env (Either WantedCompiler RawSnapshotLayer) -loadSnapshotLayer (SLCompiler compiler) = pure $ Left compiler -loadSnapshotLayer sl@(SLUrl url blob) = - handleAny (throwIO . InvalidSnapshot (toRawSL sl)) $ do - bs <- loadFromURL url (Just blob) - value <- Yaml.decodeThrow bs - snapshot <- warningsParserHelper sl value Nothing - pure $ Right snapshot -loadSnapshotLayer sl@(SLFilePath fp) = - handleAny (throwIO . InvalidSnapshot (toRawSL sl)) $ do - value <- Yaml.decodeFileThrow $ toFilePath $ resolvedAbsolute fp - snapshot <- warningsParserHelper sl value $ Just $ parent $ resolvedAbsolute fp - pure $ Right snapshot - -loadFromURL - :: (HasPantryConfig env, HasLogFunc env) - => Text -- ^ url - -> Maybe BlobKey - -> RIO env ByteString -loadFromURL url Nothing = do - mcached <- withStorage $ loadURLBlob url - case mcached of - Just bs -> return bs - Nothing -> loadWithCheck url Nothing -loadFromURL url (Just bkey) = do - mcached <- withStorage $ loadBlob bkey - case mcached of - Just bs -> do - logDebug "Loaded snapshot from Pantry database." - return bs - Nothing -> loadUrlViaCasaOrWithCheck url bkey - -loadUrlViaCasaOrWithCheck - :: (HasPantryConfig env, HasLogFunc env) - => Text -- ^ url - -> BlobKey - -> RIO env ByteString -loadUrlViaCasaOrWithCheck url blobKey = do - mblobFromCasa <- casaLookupKey blobKey - case mblobFromCasa of - Just blob -> do - logDebug - ("Loaded snapshot from Casa (" <> display blobKey <> ") for URL: " <> - display url) - pure blob - Nothing -> loadWithCheck url (Just blobKey) - -loadWithCheck - :: (HasPantryConfig env, HasLogFunc env) - => Text -- ^ url - -> Maybe BlobKey - -> RIO env ByteString -loadWithCheck url mblobkey = do - let (msha, msize) = - case mblobkey of - Nothing -> (Nothing, Nothing) - Just (BlobKey sha size) -> (Just sha, Just size) - (_, _, bss) <- httpSinkChecked url msha msize sinkList - let bs = B.concat bss - withStorage $ storeURLBlob url bs - logDebug ("Loaded snapshot from third party: " <> display url) - return bs - -warningsParserHelperRaw - :: HasLogFunc env - => RawSnapshotLocation - -> Value - -> Maybe (Path Abs Dir) - -> RIO env RawSnapshotLayer -warningsParserHelperRaw rsl val mdir = - case parseEither Yaml.parseJSON val of - Left e -> throwIO $ Couldn'tParseSnapshot rsl e - Right (WithJSONWarnings x ws) -> do - unless (null ws) $ do - logWarn $ "Warnings when parsing snapshot " <> display rsl - for_ ws $ logWarn . display - resolvePaths mdir x - -warningsParserHelper - :: HasLogFunc env - => SnapshotLocation - -> Value - -> Maybe (Path Abs Dir) - -> RIO env RawSnapshotLayer -warningsParserHelper sl val mdir = - case parseEither Yaml.parseJSON val of - Left e -> throwIO $ Couldn'tParseSnapshot (toRawSL sl) e - Right (WithJSONWarnings x ws) -> do - unless (null ws) $ do - logWarn $ "Warnings when parsing snapshot " <> display sl - for_ ws $ logWarn . display - resolvePaths mdir x - --- | Get the 'PackageName' of the package at the given location. --- --- @since 0.1.0.0 -getPackageLocationName - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => RawPackageLocationImmutable - -> RIO env PackageName -getPackageLocationName = fmap pkgName . getRawPackageLocationIdent - --- | Get the 'PackageIdentifier' of the package at the given location. --- --- @since 0.1.0.0 -packageLocationIdent - :: PackageLocationImmutable - -> PackageIdentifier -packageLocationIdent (PLIHackage ident _ _) = ident -packageLocationIdent (PLIRepo _ pm) = pmIdent pm -packageLocationIdent (PLIArchive _ pm) = pmIdent pm - --- | Get version of the package at the given location. --- --- @since 0.1.0.0 -packageLocationVersion - :: PackageLocationImmutable - -> Version -packageLocationVersion (PLIHackage pident _ _) = pkgVersion pident -packageLocationVersion (PLIRepo _ pm) = pkgVersion (pmIdent pm) -packageLocationVersion (PLIArchive _ pm) = pkgVersion (pmIdent pm) - --- | Get the 'PackageIdentifier' of the package at the given location. --- --- @since 0.1.0.0 -getRawPackageLocationIdent - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => RawPackageLocationImmutable - -> RIO env PackageIdentifier -getRawPackageLocationIdent (RPLIHackage (PackageIdentifierRevision name version _) _) = pure $ PackageIdentifier name version -getRawPackageLocationIdent (RPLIRepo _ RawPackageMetadata { rpmName = Just name, rpmVersion = Just version }) = pure $ PackageIdentifier name version -getRawPackageLocationIdent (RPLIArchive _ RawPackageMetadata { rpmName = Just name, rpmVersion = Just version }) = pure $ PackageIdentifier name version -getRawPackageLocationIdent rpli = packageIdent <$> loadPackageRaw rpli - --- | Get the 'TreeKey' of the package at the given location. --- --- @since 0.1.0.0 -getRawPackageLocationTreeKey - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => RawPackageLocationImmutable - -> RIO env TreeKey -getRawPackageLocationTreeKey pl = - case getRawTreeKey pl of - Just treeKey' -> pure treeKey' - Nothing -> - case pl of - RPLIHackage pir _ -> getHackageTarballKey pir - RPLIArchive archive pm -> getArchiveKey pl archive pm - RPLIRepo repo pm -> getRepoKey repo pm - --- | Get the 'TreeKey' of the package at the given location. --- --- @since 0.1.0.0 -getPackageLocationTreeKey - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => PackageLocationImmutable - -> RIO env TreeKey -getPackageLocationTreeKey pl = pure $ getTreeKey pl - -getRawTreeKey :: RawPackageLocationImmutable -> Maybe TreeKey -getRawTreeKey (RPLIHackage _ mtree) = mtree -getRawTreeKey (RPLIArchive _ rpm) = rpmTreeKey rpm -getRawTreeKey (RPLIRepo _ rpm) = rpmTreeKey rpm - -getTreeKey :: PackageLocationImmutable -> TreeKey -getTreeKey (PLIHackage _ _ tree) = tree -getTreeKey (PLIArchive _ pm) = pmTreeKey pm -getTreeKey (PLIRepo _ pm) = pmTreeKey pm - --- | Convenient data type that allows you to work with pantry more --- easily than using 'withPantryConfig' directly. Uses basically sane --- settings, like sharing a pantry directory with Stack. --- --- You can use 'runPantryApp' to use this. --- --- @since 0.1.0.0 -data PantryApp = PantryApp - { paSimpleApp :: !SimpleApp - , paPantryConfig :: !PantryConfig - , paUseColor :: !Bool - , paTermWidth :: !Int - , paStylesUpdate :: !StylesUpdate - } - -simpleAppL :: Lens' PantryApp SimpleApp -simpleAppL = lens paSimpleApp (\x y -> x { paSimpleApp = y }) - --- | Lens to view or modify the 'HpackExecutable' of a 'PantryConfig' --- --- @since 0.1.0.0 -hpackExecutableL :: Lens' PantryConfig HpackExecutable -hpackExecutableL k pconfig = fmap (\hpExe -> pconfig { pcHpackExecutable = hpExe }) (k (pcHpackExecutable pconfig)) - -instance HasLogFunc PantryApp where - logFuncL = simpleAppL.logFuncL -instance HasPantryConfig PantryApp where - pantryConfigL = lens paPantryConfig (\x y -> x { paPantryConfig = y }) -instance HasProcessContext PantryApp where - processContextL = simpleAppL.processContextL -instance HasStylesUpdate PantryApp where - stylesUpdateL = lens paStylesUpdate (\x y -> x { paStylesUpdate = y }) -instance HasTerm PantryApp where - useColorL = lens paUseColor (\x y -> x { paUseColor = y }) - termWidthL = lens paTermWidth (\x y -> x { paTermWidth = y }) - --- | Run some code against pantry using basic sane settings. --- --- For testing, see 'runPantryAppClean'. --- --- @since 0.1.0.0 -runPantryApp :: MonadIO m => RIO PantryApp a -> m a -runPantryApp = runPantryAppWith 8 defaultCasaRepoPrefix defaultCasaMaxPerRequest - --- | Run some code against pantry using basic sane settings. --- --- For testing, see 'runPantryAppClean'. --- --- @since 0.1.1.1 -runPantryAppWith :: MonadIO m => Int -> CasaRepoPrefix -> Int -> RIO PantryApp a -> m a -runPantryAppWith maxConnCount casaRepoPrefix casaMaxPerRequest f = runSimpleApp $ do - sa <- ask - stack <- getAppUserDataDirectory "stack" - root <- parseAbsDir $ stack FilePath.</> "pantry" - withPantryConfig - root - defaultPackageIndexConfig - HpackBundled - maxConnCount - casaRepoPrefix - casaMaxPerRequest - defaultSnapshotLocation - $ \pc -> - runRIO - PantryApp - { paSimpleApp = sa - , paPantryConfig = pc - , paTermWidth = 100 - , paUseColor = True - , paStylesUpdate = mempty - } - f - --- | Like 'runPantryApp', but uses an empty pantry directory instead --- of sharing with Stack. Useful for testing. --- --- @since 0.1.0.0 -runPantryAppClean :: MonadIO m => RIO PantryApp a -> m a -runPantryAppClean f = liftIO $ withSystemTempDirectory "pantry-clean" $ \dir -> runSimpleApp $ do - sa <- ask - root <- resolveDir' dir - withPantryConfig - root - defaultPackageIndexConfig - HpackBundled - 8 - defaultCasaRepoPrefix - defaultCasaMaxPerRequest - defaultSnapshotLocation - $ \pc -> - runRIO - PantryApp - { paSimpleApp = sa - , paPantryConfig = pc - , paTermWidth = 100 - , paUseColor = True - , paStylesUpdate = mempty - } - f - --- | Load the global hints from GitHub. --- --- @since 0.1.0.0 -loadGlobalHints - :: (HasTerm env, HasPantryConfig env) - => WantedCompiler - -> RIO env (Maybe (Map PackageName Version)) -loadGlobalHints wc = - inner False - where - inner alreadyDownloaded = do - dest <- getGlobalHintsFile - req <- parseRequest "https://raw.githubusercontent.com/fpco/stackage-content/master/stack/global-hints.yaml" - downloaded <- download req dest - eres <- tryAny (inner2 dest) - mres <- - case eres of - Left e -> Nothing <$ logError - ( "Error: [S-912]\n" - <> "Error when parsing global hints: " - <> displayShow e - ) - Right x -> pure x - case mres of - Nothing | not alreadyDownloaded && not downloaded -> do - logInfo $ - "Could not find local global hints for " <> - RIO.display wc <> - ", forcing a redownload" - x <- redownload req dest - if x - then inner True - else do - logInfo "Redownload didn't happen" - pure Nothing - _ -> pure mres - - inner2 dest - = liftIO - $ Map.lookup wc . fmap (fmap unCabalString . unCabalStringMap) - <$> Yaml.decodeFileThrow (toFilePath dest) - --- | Partition a map of global packages with its versions into a Set of --- replaced packages and its dependencies and a map of remaining (untouched) packages. --- --- @since 0.1.0.0 -partitionReplacedDependencies :: - Ord id - => Map PackageName a -- ^ global packages - -> (a -> PackageName) -- ^ package name getter - -> (a -> id) -- ^ returns unique package id used for dependency pruning - -> (a -> [id]) -- ^ returns unique package ids of direct package dependencies - -> Set PackageName -- ^ overrides which global dependencies should get pruned - -> (Map PackageName [PackageName], Map PackageName a) -partitionReplacedDependencies globals getName getId getDeps overrides = - flip execState (replaced, mempty) $ - for (Map.toList globals) $ prunePackageWithDeps globals' getName getDeps - where - globals' = Map.fromList $ map (getId &&& id) (Map.elems globals) - replaced = Map.map (const []) $ Map.restrictKeys globals overrides - -prunePackageWithDeps :: - Ord id - => Map id a - -> (a -> PackageName) - -> (a -> [id]) - -> (PackageName, a) - -> State (Map PackageName [PackageName], Map PackageName a) Bool -prunePackageWithDeps pkgs getName getDeps (pname, a) = do - (pruned, kept) <- get - if Map.member pname pruned - then return True - else if Map.member pname kept - then return False - else do - let deps = Map.elems $ Map.restrictKeys pkgs (Set.fromList $ getDeps a) - prunedDeps <- forMaybeM deps $ \dep -> do - let depName = getName dep - isPruned <- prunePackageWithDeps pkgs getName getDeps (depName, dep) - pure $ if isPruned then Just depName else Nothing - if null prunedDeps - then do - modify' $ second (Map.insert pname a) - else do - modify' $ first (Map.insert pname prunedDeps) - return $ not (null prunedDeps) - --- | Use a snapshot cache, which caches which modules are in which --- packages in a given snapshot. This is mostly intended for usage by --- Stack. --- --- @since 0.1.0.0 -withSnapshotCache - :: (HasPantryConfig env, HasLogFunc env) - => SnapshotCacheHash - -> RIO env (Map PackageName (Set ModuleName)) - -> ((ModuleName -> RIO env [PackageName]) -> RIO env a) - -> RIO env a -withSnapshotCache hash getModuleMapping f = do - mres <- withStorage $ getSnapshotCacheByHash hash - cacheId <- case mres of - Nothing -> do - logWarn "Populating snapshot module name cache" - packageModules <- getModuleMapping - withStorage $ do - scId <- getSnapshotCacheId hash - storeSnapshotModuleCache scId packageModules - return scId - Just scId -> pure scId - f $ withStorage . loadExposedModulePackages cacheId - --- | Add an s to the builder if n!=1. -plural :: Int -> Utf8Builder -> Utf8Builder -plural n text = - display n <> " " <> text <> - (if n == 1 - then "" - else "s") +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +-- | Content addressable Haskell package management, providing for +-- secure, reproducible acquisition of Haskell package contents and +-- metadata. +-- +-- @since 0.1.0.0 +module Pantry + ( -- * Running + PantryConfig + , PackageIndexConfig (..) + , HackageSecurityConfig (..) + , defaultPackageIndexConfig + , defaultDownloadPrefix + , defaultHackageSecurityConfig + , defaultCasaRepoPrefix + , defaultCasaMaxPerRequest + , defaultSnapshotLocation + , HasPantryConfig (..) + , withPantryConfig + , withPantryConfig' + , HpackExecutable (..) + + -- ** Convenience + , PantryApp + , runPantryApp + , runPantryAppClean + , runPantryAppWith + , hpackExecutableL + + -- * Types + + -- ** Exceptions + , PantryException (..) + , Mismatch (..) + , FuzzyResults (..) + + -- ** Cabal types + , PackageName + , Version + , FlagName + , PackageIdentifier (..) + + -- ** Files + , FileSize (..) + , RelFilePath (..) + , ResolvedPath (..) + , Unresolved + , SafeFilePath + , mkSafeFilePath + + -- ** Cryptography + , SHA256 + , TreeKey (..) + , BlobKey (..) + + -- ** Packages + , RawPackageMetadata (..) + , PackageMetadata (..) + , Package (..) + + -- ** Hackage + , CabalFileInfo (..) + , Revision (..) + , PackageIdentifierRevision (..) + , UsePreferredVersions (..) + + -- ** Archives + , RawArchive (..) + , Archive (..) + , ArchiveLocation (..) + + -- ** Repos + , Repo (..) + , RepoType (..) + , SimpleRepo (..) + , withRepo + , fetchRepos + , fetchReposRaw + + -- ** Package location + , RawPackageLocation (..) + , PackageLocation (..) + , toRawPL + , RawPackageLocationImmutable (..) + , PackageLocationImmutable (..) + + -- ** Snapshots + , RawSnapshotLocation (..) + , SnapshotLocation (..) + , toRawSL + , RawSnapshot (..) + , Snapshot (..) + , RawSnapshotPackage (..) + , SnapshotPackage (..) + , RawSnapshotLayer (..) + , SnapshotLayer (..) + , toRawSnapshotLayer + , WantedCompiler (..) + , SnapName (..) + , snapshotLocation + + -- * Loading values + , resolvePaths + , loadPackageRaw + , tryLoadPackageRawViaCasa + , loadPackage + , loadRawSnapshotLayer + , loadSnapshotLayer + , loadSnapshot + , loadAndCompleteSnapshot + , loadAndCompleteSnapshot' + , loadAndCompleteSnapshotRaw + , loadAndCompleteSnapshotRaw' + , CompletedSL (..) + , CompletedPLI (..) + , addPackagesToSnapshot + , AddPackagesConfig (..) + + -- * Completion functions + , CompletePackageLocation (..) + , completePackageLocation + , completeSnapshotLocation + , warnMissingCabalFile + + -- * Parsers + , parseWantedCompiler + , parseSnapName + , parseRawSnapshotLocation + , parsePackageIdentifierRevision + , parseHackageText + + -- ** Cabal values + , parsePackageIdentifier + , parsePackageName + , parsePackageNameThrowing + , parseFlagName + , parseVersion + , parseVersionThrowing + + -- * Cabal helpers + , packageIdentifierString + , packageNameString + , flagNameString + , versionString + , moduleNameString + , CabalString (..) + , toCabalStringMap + , unCabalStringMap + , gpdPackageIdentifier + , gpdPackageName + , gpdVersion + + -- * Package location + , fetchPackages + , unpackPackageLocationRaw + , unpackPackageLocation + , getPackageLocationName + , getRawPackageLocationIdent + , packageLocationIdent + , packageLocationVersion + , getRawPackageLocationTreeKey + , getPackageLocationTreeKey + + -- * Cabal files + , loadCabalFileRaw + , loadCabalFile + , loadCabalFileRawImmutable + , loadCabalFileImmutable + , loadCabalFilePath + , findOrGenerateCabalFile + , PrintWarnings (..) + + -- * Hackage index + , updateHackageIndex + , DidUpdateOccur (..) + , RequireHackageIndex (..) + , hackageIndexTarballL + , getHackagePackageVersions + , getLatestHackageVersion + , getLatestHackageLocation + , getLatestHackageRevision + , getHackageTypoCorrections + , loadGlobalHints + , partitionReplacedDependencies + + -- * Snapshot cache + , SnapshotCacheHash (..) + , withSnapshotCache + ) where + +import Casa.Client ( CasaRepoPrefix, thParserCasaRepo ) +import Conduit +import Control.Arrow ( right ) +import Control.Monad.State.Strict ( State, execState, get, modify' ) +import Data.Aeson.Types ( parseEither ) +#if !MIN_VERSION_rio(0,1,17) +import Data.Bifunctor ( bimap ) +#endif +import Data.Char ( isHexDigit ) +import Data.Monoid ( Endo (..) ) +import Data.Time ( diffUTCTime, getCurrentTime ) +import qualified Data.Yaml as Yaml +import Data.Yaml.Include ( decodeFileWithWarnings ) +import Database.Persist ( entityKey ) +import Distribution.PackageDescription + ( FlagName, GenericPackageDescription ) +import qualified Distribution.PackageDescription as D +import Distribution.Parsec ( PWarning (..), showPos ) +import qualified Hpack +import qualified Hpack.Config as Hpack +import Hpack.Error ( formatHpackError ) +import Hpack.Yaml ( formatWarning ) +import Network.HTTP.Download +import Pantry.Archive +import Pantry.Casa +import Pantry.HTTP +import Pantry.Hackage +import Pantry.Internal.AesonExtended ( Value, WithJSONWarnings (..) ) +import Pantry.Repo +import qualified Pantry.SHA256 as SHA256 +import Pantry.Storage hiding + ( TreeEntry, PackageName, Version, findOrGenerateCabalFile ) +import Pantry.Tree +import Pantry.Types as P +import Path + ( Abs, Dir, File, Path, (</>), filename, parent, parseAbsDir + , parseRelFile, toFilePath + ) +import Path.IO ( doesFileExist, listDir, resolveDir' ) +import RIO +import qualified RIO.ByteString as B +import RIO.Directory ( getAppUserDataDirectory ) +import qualified RIO.FilePath as FilePath +import qualified RIO.List as List +import qualified RIO.Map as Map +import RIO.PrettyPrint +import RIO.PrettyPrint.StylesUpdate +import RIO.Process +import qualified RIO.Set as Set +import RIO.Text ( unpack ) +import qualified RIO.Text as T +import System.IO.Error ( isDoesNotExistError ) + +decodeYaml :: FilePath -> IO (Either String ([String], Value)) +decodeYaml file = do + bimap displayException (first formatWarnings) <$> decodeFileWithWarnings file + where + formatWarnings = map (formatWarning file) + +formatYamlParseError :: FilePath -> Yaml.ParseException -> String +formatYamlParseError file e = + "In respect of an Hpack defaults file:\n" + <> file + <> ":\n\n" + <> displayException e + +-- | Create a new 'PantryConfig' with the given settings. For a version where +-- the use of Casa (content-addressable storage archive) is optional, see +-- 'withPantryConfig''. +-- +-- For something easier to use in simple cases, see 'runPantryApp'. +-- +-- @since 0.1.0.0 +withPantryConfig :: + HasLogFunc env + => Path Abs Dir + -- ^ pantry root directory, where the SQLite database and Hackage + -- downloads are kept. + -> PackageIndexConfig + -- ^ Package index configuration. You probably want + -- 'defaultPackageIndexConfig'. + -> HpackExecutable + -- ^ When converting an hpack @package.yaml@ file to a cabal file, what + -- version of hpack should we use? + -> Int + -- ^ Maximum connection count + -> CasaRepoPrefix + -- ^ The casa pull URL e.g. https://casa.fpcomplete.com/v1/pull. + -> Int + -- ^ Max casa keys to pull per request. + -> (SnapName -> RawSnapshotLocation) + -- ^ The location of snapshot synonyms + -> (PantryConfig -> RIO env a) + -- ^ What to do with the config + -> RIO env a +withPantryConfig root pic he count pullURL maxPerRequest = + withPantryConfig' root pic he count (Just (pullURL, maxPerRequest)) + +-- | Create a new 'PantryConfig' with the given settings. +-- +-- For something easier to use in simple cases, see 'runPantryApp'. +-- +-- @since 0.8.3 +withPantryConfig' + :: HasLogFunc env + => Path Abs Dir + -- ^ pantry root directory, where the SQLite database and Hackage + -- downloads are kept. + -> PackageIndexConfig + -- ^ Package index configuration. You probably want + -- 'defaultPackageIndexConfig'. + -> HpackExecutable + -- ^ When converting an hpack @package.yaml@ file to a cabal file, + -- what version of hpack should we use? + -> Int + -- ^ Maximum connection count + -> Maybe (CasaRepoPrefix, Int) + -- ^ Optionally, the Casa pull URL e.g. @https://casa.fpcomplete.com@ and the + -- maximum number of Casa keys to pull per request. + -> (SnapName -> RawSnapshotLocation) + -- ^ The location of snapshot synonyms + -> (PantryConfig -> RIO env a) + -- ^ What to do with the config + -> RIO env a +withPantryConfig' root pic he count mCasaConfig snapLoc inner = do + env <- ask + pantryRelFile <- parseRelFile "pantry.sqlite3" + -- Silence persistent's logging output, which is really noisy + runRIO (mempty :: LogFunc) $ initStorage (root </> pantryRelFile) $ \storage -> runRIO env $ do + ur <- newMVar True + ref1 <- newIORef mempty + ref2 <- newIORef mempty + inner PantryConfig + { pcPackageIndex = pic + , pcHpackExecutable = he + , pcRootDir = root + , pcStorage = storage + , pcUpdateRef = ur + , pcConnectionCount = count + , pcParsedCabalFilesRawImmutable = ref1 + , pcParsedCabalFilesMutable = ref2 + , pcCasaConfig = mCasaConfig + , pcSnapshotLocation = snapLoc + } + +-- | Default pull URL for Casa. +-- +-- @since 0.1.1.1 +defaultCasaRepoPrefix :: CasaRepoPrefix +defaultCasaRepoPrefix = $(thParserCasaRepo "https://casa.fpcomplete.com") + +-- | Default max keys to pull per request. +-- +-- @since 0.1.1.1 +defaultCasaMaxPerRequest :: Int +defaultCasaMaxPerRequest = 1280 + +-- | Default 'PackageIndexConfig' value using the official Hackage server. +-- +-- @since 0.6.0 +defaultPackageIndexConfig :: PackageIndexConfig +defaultPackageIndexConfig = PackageIndexConfig + { picDownloadPrefix = defaultDownloadPrefix + , picHackageSecurityConfig = defaultHackageSecurityConfig + } + +-- | The download prefix for the official Hackage server. +-- +-- @since 0.6.0 +defaultDownloadPrefix :: Text +defaultDownloadPrefix = "https://hackage.haskell.org/" + +-- | Returns the latest version of the given package available from +-- Hackage. +-- +-- @since 0.1.0.0 +getLatestHackageVersion :: + (HasPantryConfig env, HasLogFunc env) + => RequireHackageIndex + -> PackageName -- ^ package name + -> UsePreferredVersions + -> RIO env (Maybe PackageIdentifierRevision) +getLatestHackageVersion req name preferred = + ((fmap fst . Map.maxViewWithKey) >=> go) <$> getHackagePackageVersions req preferred name + where + go (version, m) = do + (_rev, BlobKey sha size) <- fst <$> Map.maxViewWithKey m + pure $ PackageIdentifierRevision name version $ CFIHash sha $ Just size + +-- | Returns location of the latest version of the given package available from +-- Hackage. +-- +-- @since 0.1.0.0 +getLatestHackageLocation :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RequireHackageIndex + -> PackageName -- ^ package name + -> UsePreferredVersions + -> RIO env (Maybe PackageLocationImmutable) +getLatestHackageLocation req name preferred = do + mversion <- + fmap fst . Map.maxViewWithKey <$> getHackagePackageVersions req preferred name + let mVerCfKey = do + (version, revisions) <- mversion + (_rev, cfKey) <- fst <$> Map.maxViewWithKey revisions + pure (version, cfKey) + + forM mVerCfKey $ \(version, cfKey@(BlobKey sha size)) -> do + let pir = PackageIdentifierRevision name version (CFIHash sha (Just size)) + treeKey' <- getHackageTarballKey pir + pure $ PLIHackage (PackageIdentifier name version) cfKey treeKey' + +-- | Returns the latest revision of the given package version available from +-- Hackage. +-- +-- @since 0.1.0.0 +getLatestHackageRevision :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RequireHackageIndex + -> PackageName -- ^ package name + -> Version + -> RIO env (Maybe (Revision, BlobKey, TreeKey)) +getLatestHackageRevision req name version = do + revisions <- getHackagePackageVersionRevisions req name version + case fst <$> Map.maxViewWithKey revisions of + Nothing -> pure Nothing + Just (revision, cfKey@(BlobKey sha size)) -> do + let cfi = CFIHash sha (Just size) + treeKey' <- getHackageTarballKey (PackageIdentifierRevision name version cfi) + pure $ Just (revision, cfKey, treeKey') + +-- | Fetch keys and blobs and insert into the database where possible. +fetchTreeKeys :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => [RawPackageLocationImmutable] + -> RIO env () +fetchTreeKeys treeKeys = do + -- Find all tree keys that are missing from the database. + packageLocationsMissing :: [RawPackageLocationImmutable] <- + withStorage + (filterM + (fmap isNothing . maybe (pure Nothing) getTreeForKey . getRawTreeKey) + treeKeys) + pullTreeStart <- liftIO getCurrentTime + -- Pull down those tree keys from Casa, automatically inserting into + -- our local database. + treeKeyBlobs :: Map TreeKey P.Tree <- + handleAny (const mempty) + (fmap + Map.fromList + (withStorage + (runConduitRes + (casaBlobSource + (fmap unTreeKey (mapMaybe getRawTreeKey packageLocationsMissing)) .| + mapMC parseTreeM .| + sinkList)))) + pullTreeEnd <- liftIO getCurrentTime + let pulledPackages = + mapMaybe + (\treeKey' -> + List.find + ((== Just treeKey') . getRawTreeKey) + packageLocationsMissing) + (Map.keys treeKeyBlobs) + -- Pull down all unique file blobs. + let uniqueFileBlobKeys :: Set BlobKey + uniqueFileBlobKeys = + foldMap + (\(P.TreeMap files) -> Set.fromList (map teBlob (toList files))) + treeKeyBlobs + pullBlobStart <- liftIO getCurrentTime + mpulledBlobKeys :: Maybe Int <- + handleAny (const (pure Nothing)) + (fmap Just (withStorage + (runConduitRes + (casaBlobSource uniqueFileBlobKeys .| mapC (const 1) .| sumC)))) + for_ mpulledBlobKeys $ \pulledBlobKeys -> do + pullBlobEnd <- liftIO getCurrentTime + logDebug + ("Pulled from Casa: " <> + mconcat (List.intersperse ", " (map display pulledPackages)) <> + " (" <> + display (T.pack (show (diffUTCTime pullTreeEnd pullTreeStart))) <> + "), " <> + plural pulledBlobKeys "file" <> + " (" <> + display (T.pack (show (diffUTCTime pullBlobEnd pullBlobStart))) <> + ")") + -- Store the tree for each missing package. + for_ + packageLocationsMissing + (\rawPackageLocationImmutable -> + let mkey = getRawTreeKey rawPackageLocationImmutable + in case mkey of + Nothing -> + logDebug + ("Ignoring package with no tree key " <> + display rawPackageLocationImmutable <> + ", can't look in Casa for it.") + Just key -> + case Map.lookup key treeKeyBlobs of + Nothing -> + logDebug + ("Package key " <> display key <> " (" <> + display rawPackageLocationImmutable <> + ") not returned from Casa.") + Just tree -> do + identifier <- + getRawPackageLocationIdent rawPackageLocationImmutable + case findCabalOrHpackFile rawPackageLocationImmutable tree of + Just buildFile -> withStorage $ do + ecachedTree <- loadCachedTree tree + case ecachedTree of + Left e -> + lift $ logWarn + ("Loading cached tree after download from Casa failed on " <> + display rawPackageLocationImmutable <> ": " <> + displayShow e) + Right cachedTree -> + void $ storeTree + rawPackageLocationImmutable + identifier + cachedTree + buildFile + Nothing -> + logWarn + ("Unable to find build file for package: " <> + display rawPackageLocationImmutable)) + where + unTreeKey :: TreeKey -> BlobKey + unTreeKey (P.TreeKey blobKey) = blobKey + +-- | Download all of the packages provided into the local cache without +-- performing any unpacking. Can be useful for build tools wanting to prefetch +-- or provide an offline mode. +-- +-- @since 0.1.0.0 +fetchPackages :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env, Foldable f) + => f PackageLocationImmutable + -> RIO env () +fetchPackages pls = do + fetchTreeKeys (fmap toRawPLI (toList pls)) + traverseConcurrently_ (void . uncurry getHackageTarball) hackages + -- TODO in the future, be concurrent in these as well + fetchArchives archives + fetchRepos repos + where + s x = Endo (x:) + run (Endo f) = f [] + (hackagesE, archivesE, reposE) = foldMap go pls + hackages = run hackagesE + archives = run archivesE + repos = run reposE + + go (PLIHackage ident cfHash tree) = (s (toPir ident cfHash, Just tree), mempty, mempty) + go (PLIArchive archive pm) = (mempty, s (archive, pm), mempty) + go (PLIRepo repo pm) = (mempty, mempty, s (repo, pm)) + + toPir (PackageIdentifier name ver) (BlobKey sha size) = + PackageIdentifierRevision name ver (CFIHash sha (Just size)) + +-- | Unpack a given 'RawPackageLocationImmutable' into the given directory. Does +-- not generate any extra subdirectories. +-- +-- @since 0.1.0.0 +unpackPackageLocationRaw :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Path Abs Dir -- ^ unpack directory + -> RawPackageLocationImmutable + -> RIO env () +unpackPackageLocationRaw fp loc = + loadPackageRaw loc >>= unpackTree loc fp . packageTree + +-- | Unpack a given 'PackageLocationImmutable' into the given directory. Does +-- not generate any extra subdirectories. +-- +-- @since 0.1.0.0 +unpackPackageLocation :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Path Abs Dir -- ^ unpack directory + -> PackageLocationImmutable + -> RIO env () +unpackPackageLocation fp loc = + loadPackage loc >>= unpackTree (toRawPLI loc) fp . packageTree + +-- | Load the cabal file for the given 'PackageLocationImmutable'. +-- +-- This function ignores all warnings. +-- +-- @since 0.1.0.0 +loadCabalFileImmutable :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => PackageLocationImmutable + -> RIO env GenericPackageDescription +loadCabalFileImmutable loc = withCache $ do + logDebug $ "Parsing cabal file for " <> display loc + bs <- loadCabalFileBytes loc + (_warnings, gpd) <- rawParseGPD (Left $ toRawPLI loc) bs + let pm = + case loc of + PLIHackage (PackageIdentifier name version) _cfHash mtree -> PackageMetadata + { pmIdent = PackageIdentifier name version + , pmTreeKey = mtree + } + PLIArchive _ pm' -> pm' + PLIRepo _ pm' -> pm' + let exc = MismatchedPackageMetadata (toRawPLI loc) (toRawPM pm) Nothing + (gpdPackageIdentifier gpd) + PackageIdentifier name ver = pmIdent pm + maybe (throwIO exc) pure $ do + guard $ name == gpdPackageName gpd + guard $ ver == gpdVersion gpd + pure gpd + where + withCache inner = do + let rawLoc = toRawPLI loc + ref <- view $ pantryConfigL.to pcParsedCabalFilesRawImmutable + m0 <- readIORef ref + case Map.lookup rawLoc m0 of + Just x -> pure x + Nothing -> do + x <- inner + atomicModifyIORef' ref $ \m -> (Map.insert rawLoc x m, x) + +-- | Load the cabal file for the given 'RawPackageLocationImmutable'. +-- +-- This function ignores all warnings. +-- +-- Note that, for now, this will not allow support for hpack files in these +-- package locations. Instead, all @PackageLocationImmutable@s will require a +-- .cabal file. This may be relaxed in the future. +-- +-- @since 0.1.0.0 +loadCabalFileRawImmutable :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawPackageLocationImmutable + -> RIO env GenericPackageDescription +loadCabalFileRawImmutable loc = withCache $ do + logDebug $ "Parsing cabal file for " <> display loc + bs <- loadRawCabalFileBytes loc + (_warnings, gpd) <- rawParseGPD (Left loc) bs + let rpm = + case loc of + RPLIHackage (PackageIdentifierRevision name version _cfi) mtree -> RawPackageMetadata + { rpmName = Just name + , rpmVersion = Just version + , rpmTreeKey = mtree + } + RPLIArchive _ rpm' -> rpm' + RPLIRepo _ rpm' -> rpm' + let exc = MismatchedPackageMetadata loc rpm Nothing (gpdPackageIdentifier gpd) + maybe (throwIO exc) pure $ do + guard $ maybe True (== gpdPackageName gpd) (rpmName rpm) + guard $ maybe True (== gpdVersion gpd) (rpmVersion rpm) + pure gpd + where + withCache inner = do + ref <- view $ pantryConfigL.to pcParsedCabalFilesRawImmutable + m0 <- readIORef ref + case Map.lookup loc m0 of + Just x -> pure x + Nothing -> do + x <- inner + atomicModifyIORef' ref $ \m -> (Map.insert loc x m, x) + +-- | Same as 'loadCabalFileRawImmutable', but takes a 'RawPackageLocation'. +-- Never prints warnings, see 'loadCabalFilePath' for that. +-- +-- @since 0.8.0 +loadCabalFileRaw :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Maybe Text + -- ^ The program name used by Hpack (the library), defaults to \"hpack\". + -> RawPackageLocation + -> RIO env GenericPackageDescription +loadCabalFileRaw _ (RPLImmutable loc) = loadCabalFileRawImmutable loc +loadCabalFileRaw progName (RPLMutable rfp) = do + (gpdio, _, _) <- loadCabalFilePath progName (resolvedAbsolute rfp) + liftIO $ gpdio NoPrintWarnings + +-- | Same as 'loadCabalFileImmutable', but takes a 'PackageLocation'. Never +-- prints warnings, see 'loadCabalFilePath' for that. +-- +-- @since 0.8.0 +loadCabalFile :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Maybe Text + -- ^ The program name used by Hpack (the library), defaults to \"hpack\". + -> PackageLocation + -> RIO env GenericPackageDescription +loadCabalFile _ (PLImmutable loc) = loadCabalFileImmutable loc +loadCabalFile progName (PLMutable rfp) = do + (gpdio, _, _) <- loadCabalFilePath progName (resolvedAbsolute rfp) + liftIO $ gpdio NoPrintWarnings + +-- | Parse the Cabal file for the package inside the given directory. Performs +-- various sanity checks, such as the file name being correct and having only a +-- single Cabal file. +-- +-- @since 0.8.0 +loadCabalFilePath :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Maybe Text + -- ^ The program name used by Hpack (the library), defaults to \"hpack\". + -> Path Abs Dir -- ^ project directory, with a cabal file or hpack file + -> RIO env + ( PrintWarnings -> IO GenericPackageDescription + , PackageName + , Path Abs File + ) +loadCabalFilePath progName dir = do + ref <- view $ pantryConfigL.to pcParsedCabalFilesMutable + mcached <- Map.lookup dir <$> readIORef ref + case mcached of + Just triple -> pure triple + Nothing -> do + (name, cabalfp) <- findOrGenerateCabalFile progName dir + gpdRef <- newIORef Nothing + run <- askRunInIO + let gpdio = run . getGPD cabalfp gpdRef + triple = (gpdio, name, cabalfp) + atomicModifyIORef' ref $ \m -> (Map.insert dir triple m, triple) + where + getGPD cabalfp gpdRef printWarnings = do + mpair <- readIORef gpdRef + (warnings0, gpd) <- + case mpair of + Just pair -> pure pair + Nothing -> do + bs <- liftIO $ B.readFile $ toFilePath cabalfp + (warnings0, gpd) <- rawParseGPD (Right cabalfp) bs + checkCabalFileName (gpdPackageName gpd) cabalfp + pure (warnings0, gpd) + warnings <- + case printWarnings of + YesPrintWarnings -> mapM_ (logWarn . toPretty cabalfp) warnings0 $> [] + NoPrintWarnings -> pure warnings0 + writeIORef gpdRef $ Just (warnings, gpd) + pure gpd + + toPretty :: Path Abs File -> PWarning -> Utf8Builder + toPretty src (PWarning _type pos msg) = + "Cabal file warning in " <> + fromString (toFilePath src) <> "@" <> + fromString (showPos pos) <> ": " <> + fromString msg + + -- | Check if the given name in the @Package@ matches the name of the .cabal + -- file + checkCabalFileName :: MonadThrow m => PackageName -> Path Abs File -> m () + checkCabalFileName name cabalfp = do + -- Previously, we just use parsePackageNameFromFilePath. However, that can + -- lead to confusing error messages. See: + -- https://github.com/commercialhaskell/stack/issues/895 + let expected = T.unpack $ unSafeFilePath $ cabalFileName name + when (expected /= toFilePath (filename cabalfp)) $ + throwM $ MismatchedCabalName cabalfp name + +-- | Get the file name for the Cabal file in the given directory. +-- +-- If no Cabal file is present, or more than one is present, an exception is +-- thrown via 'throwM'. +-- +-- If the directory contains a file named package.yaml, Hpack is used to +-- generate a Cabal file from it. +-- +-- @since 0.8.0 +findOrGenerateCabalFile :: + forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Maybe Text + -- ^ The program name used by Hpack (the library), defaults to \"hpack\". + -> Path Abs Dir -- ^ package directory + -> RIO env (PackageName, Path Abs File) +findOrGenerateCabalFile progName pkgDir = do + let hpackProgName = fromString . unpack <$> progName + hpack hpackProgName pkgDir + (_, allFiles) <- listDir pkgDir `catchIO` \e -> if isDoesNotExistError e + then throwIO $ NoLocalPackageDirFound pkgDir + else throwIO e + let files = filter (flip hasExtension "cabal" . toFilePath) allFiles + -- If there are multiple files, ignore files that start with + -- ".". On unixlike environments these are hidden, and this + -- character is not valid in package names. The main goal is + -- to ignore emacs lock files - see + -- https://github.com/commercialhaskell/stack/issues/1897. + let isHidden ('.':_) = True + isHidden _ = False + case filter (not . isHidden . toFilePath . filename) files of + [] -> throwIO $ NoCabalFileFound pkgDir + [x] -> maybe + (throwIO $ InvalidCabalFilePath x) + (\pn -> pure (pn, x)) $ + List.stripSuffix ".cabal" (toFilePath (filename x)) >>= + parsePackageName + _:_ -> throwIO $ MultipleCabalFilesFound pkgDir files + where + hasExtension fp x = FilePath.takeExtension fp == "." ++ x + +-- | Generate Cabal file from package.yaml, if necessary. +hpack :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Maybe Hpack.ProgramName -- ^ The program name used by Hpack (the library). + -> Path Abs Dir + -> RIO env () +hpack progName pkgDir = do + packageConfigRelFile <- parseRelFile Hpack.packageConfig + let hpackFile = pkgDir </> packageConfigRelFile + mHpackProgName = maybe id Hpack.setProgramName progName + exists <- liftIO $ doesFileExist hpackFile + when exists $ do + logDebug $ "Running Hpack on " <> fromString (toFilePath hpackFile) + he <- view $ pantryConfigL.to pcHpackExecutable + case he of + HpackBundled -> + liftIO + ( Hpack.hpackResultWithError + $ mHpackProgName + $ Hpack.setDecode decodeYaml + $ Hpack.setFormatYamlParseError formatYamlParseError + $ Hpack.setTarget + (toFilePath hpackFile) Hpack.defaultOptions + ) + >>= \ case + Left err -> throwIO (HpackLibraryException hpackFile $ formatHpackError (fromMaybe "hpack" progName) err) + Right r -> do + forM_ (Hpack.resultWarnings r) (logWarn . fromString) + let cabalFile = fromString . Hpack.resultCabalFile $ r + case Hpack.resultStatus r of + Hpack.Generated -> logDebug $ + "Hpack generated a modified version of " + <> cabalFile + Hpack.OutputUnchanged -> + logDebug $ "Hpack output unchanged in " <> cabalFile + Hpack.AlreadyGeneratedByNewerHpack -> logWarn $ + cabalFile + <> " was generated with a newer version of Hpack. Ignoring " + <> fromString (toFilePath hpackFile) + <> " in favor of the Cabal file.\n" + <> "Either please upgrade and try again or, if you want to use the " + <> fromString (toFilePath (filename hpackFile)) + <> " file instead of the Cabal file,\n" + <> "then please delete the Cabal file." + Hpack.ExistingCabalFileWasModifiedManually -> logWarn $ + cabalFile + <> " was modified manually. Ignoring " + <> fromString (toFilePath hpackFile) + <> " in favor of the Cabal file.\n" + <> "If you want to use the " + <> fromString (toFilePath (filename hpackFile)) + <> " file instead of the Cabal file,\n" + <> "then please delete the Cabal file." + HpackCommand command -> catchAny + ( withWorkingDir (toFilePath pkgDir) $ + proc command [] runProcess_ + ) + ( throwIO . HpackExeException command pkgDir) + +-- | Get the 'PackageIdentifier' from a 'GenericPackageDescription'. +-- +-- @since 0.1.0.0 +gpdPackageIdentifier :: GenericPackageDescription -> PackageIdentifier +gpdPackageIdentifier = D.package . D.packageDescription + +-- | Get the 'PackageName' from a 'GenericPackageDescription'. +-- +-- @since 0.1.0.0 +gpdPackageName :: GenericPackageDescription -> PackageName +gpdPackageName = pkgName . gpdPackageIdentifier + +-- | Get the 'Version' from a 'GenericPackageDescription'. +-- +-- @since 0.1.0.0 +gpdVersion :: GenericPackageDescription -> Version +gpdVersion = pkgVersion . gpdPackageIdentifier + +loadCabalFileBytes :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => PackageLocationImmutable + -> RIO env ByteString + +-- Just ignore the mtree for this. Safe assumption: someone who filled in the +-- TreeKey also filled in the cabal file hash, and that's a more efficient +-- lookup mechanism. +loadCabalFileBytes (PLIHackage pident cfHash _mtree) = + getHackageCabalFile (pirForHash pident cfHash) + +loadCabalFileBytes pl = do + package <- loadPackage pl + let sfp = cabalFileName $ pkgName $ packageIdent package + cabalBlobKey <- case packageCabalEntry package of + PCHpack pcHpack -> pure $ teBlob . phGenerated $ pcHpack + PCCabalFile (TreeEntry blobKey _) -> pure blobKey + mbs <- withStorage $ loadBlob cabalBlobKey + case mbs of + Nothing -> do + throwIO $ TreeReferencesMissingBlob (toRawPLI pl) sfp cabalBlobKey + Just bs -> pure bs + +-- FIXME: to be removed +loadRawCabalFileBytes :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawPackageLocationImmutable + -> RIO env ByteString + +-- Just ignore the mtree for this. Safe assumption: someone who filled +-- in the TreeKey also filled in the cabal file hash, and that's a +-- more efficient lookup mechanism. +loadRawCabalFileBytes (RPLIHackage pir _mtree) = getHackageCabalFile pir + +loadRawCabalFileBytes pl = do + package <- loadPackageRaw pl + let sfp = cabalFileName $ pkgName $ packageIdent package + TreeEntry cabalBlobKey _ft = case packageCabalEntry package of + PCCabalFile cabalTE -> cabalTE + PCHpack hpackCE -> phGenerated hpackCE + mbs <- withStorage $ loadBlob cabalBlobKey + case mbs of + Nothing -> do + throwIO $ TreeReferencesMissingBlob pl sfp cabalBlobKey + Just bs -> pure bs + +-- | Load a 'Package' from a 'PackageLocationImmutable'. +-- +-- @since 0.1.0.0 +loadPackage :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => PackageLocationImmutable + -> RIO env Package +loadPackage = loadPackageRaw . toRawPLI + +-- | Load a 'Package' from a 'RawPackageLocationImmutable'. +-- +-- Load the package either from the local DB, Casa, or as a last resort, the +-- third party (hackage, archive or repo). +-- +-- @since 0.1.0.0 +loadPackageRaw :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawPackageLocationImmutable + -> RIO env Package +loadPackageRaw rpli = do + case getRawTreeKey rpli of + Just treeKey' -> do + mpackage <- tryLoadPackageRawViaDbOrCasa rpli treeKey' + maybe loadPackageRawViaThirdParty pure mpackage + Nothing -> loadPackageRawViaThirdParty + where + loadPackageRawViaThirdParty = do + logDebug ("Loading package from third-party: " <> display rpli) + case rpli of + RPLIHackage pir mtree -> htrPackage <$> getHackageTarball pir mtree + RPLIArchive archive pm -> getArchivePackage rpli archive pm + RPLIRepo repo rpm -> getRepo repo rpm + +-- | Try to load a package via the database or Casa. +tryLoadPackageRawViaDbOrCasa :: + (HasLogFunc env, HasPantryConfig env, HasProcessContext env) + => RawPackageLocationImmutable + -> TreeKey + -> RIO env (Maybe Package) +tryLoadPackageRawViaDbOrCasa rpli treeKey' = do + mviaDb <- tryLoadPackageRawViaLocalDb rpli treeKey' + case mviaDb of + Just package -> do + logDebug ("Loaded package from Pantry: " <> display rpli) + pure (Just package) + Nothing -> do + mCasaConfig <- view $ pantryConfigL . to pcCasaConfig + case mCasaConfig of + Nothing -> pure Nothing + Just _ -> do + mviaCasa <- tryLoadPackageRawViaCasa rpli treeKey' + case mviaCasa of + Just package -> do + logDebug ("Loaded package from Casa: " <> display rpli) + pure (Just package) + Nothing -> pure Nothing + +-- | Maybe load the package from Casa. +tryLoadPackageRawViaCasa :: + (HasLogFunc env, HasPantryConfig env, HasProcessContext env) + => RawPackageLocationImmutable + -> TreeKey + -> RIO env (Maybe Package) +tryLoadPackageRawViaCasa rlpi treeKey' = do + mtreePair <- casaLookupTree treeKey' + case mtreePair of + Nothing -> pure Nothing + Just (treeKey'', _tree) -> do + fetchTreeKeys [rlpi] + mdb <- tryLoadPackageRawViaLocalDb rlpi treeKey'' + case mdb of + Nothing -> do + logWarn + ("Did not find tree key in DB after pulling it from Casa: " <> + display treeKey'' <> + " (for " <> + display rlpi <> + ")") + pure Nothing + Just package -> pure (Just package) + +-- | Maybe load the package from the local database. +tryLoadPackageRawViaLocalDb :: + (HasLogFunc env, HasPantryConfig env, HasProcessContext env) + => RawPackageLocationImmutable + -> TreeKey + -> RIO env (Maybe Package) +tryLoadPackageRawViaLocalDb rlpi treeKey' = do + mtreeEntity <- withStorage (getTreeForKey treeKey') + case mtreeEntity of + Nothing -> pure Nothing + Just treeId -> + fmap Just (withStorage (loadPackageById rlpi (entityKey treeId))) + +-- | Complete package location, plus whether the package has a cabal file. This +-- is relevant to reproducibility, see +-- <https://tech.fpcomplete.com/blog/storing-generated-cabal-files> +-- +-- @since 0.4.0.0 +data CompletePackageLocation = CompletePackageLocation + { cplComplete :: !PackageLocationImmutable + , cplHasCabalFile :: !Bool + } + +-- | Fill in optional fields in a 'PackageLocationImmutable' for more reproducible builds. +-- +-- @since 0.1.0.0 +completePackageLocation :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawPackageLocationImmutable + -> RIO env CompletePackageLocation +completePackageLocation (RPLIHackage (PackageIdentifierRevision n v (CFIHash sha (Just size))) (Just tk)) = + pure CompletePackageLocation + { cplComplete = PLIHackage (PackageIdentifier n v) (BlobKey sha size) tk + , cplHasCabalFile = True + } +completePackageLocation (RPLIHackage pir0@(PackageIdentifierRevision name version cfi0) _) = do + logDebug $ "Completing package location information from " <> display pir0 + (pir, cfKey) <- + case cfi0 of + CFIHash sha (Just size) -> pure (pir0, BlobKey sha size) + _ -> do + bs <- getHackageCabalFile pir0 + let size = FileSize (fromIntegral (B.length bs)) + sha = SHA256.hashBytes bs + cfi = CFIHash sha (Just size) + pir = PackageIdentifierRevision name version cfi + logDebug $ "Added in cabal file hash: " <> display pir + pure (pir, BlobKey sha size) + treeKey' <- getHackageTarballKey pir + pure CompletePackageLocation + { cplComplete = PLIHackage (PackageIdentifier name version) cfKey treeKey' + , cplHasCabalFile = True + } +completePackageLocation pl@(RPLIArchive archive rpm) = do + mpackage <- + case rpmTreeKey rpm of + Just treeKey' -> tryLoadPackageRawViaDbOrCasa pl treeKey' + Nothing -> pure Nothing + case (,,) <$> raHash archive <*> raSize archive <*> mpackage of + Just (sha256, fileSize, package) -> do + let RawArchive loc _ _ subdir = archive + pure CompletePackageLocation + { cplComplete = PLIArchive (Archive loc sha256 fileSize subdir) (packagePM package) + , cplHasCabalFile = + case packageCabalEntry package of + PCCabalFile{} -> True + PCHpack{} -> False + } + Nothing -> byThirdParty (isJust mpackage) + where + byThirdParty warnAboutMissingSizeSha = do + (sha, size, package, _cachedTree) <- getArchive pl archive rpm + when warnAboutMissingSizeSha (warnWith sha size) + -- (getArchive checks archive and package metadata) + let RawArchive loc _ _ subdir = archive + logDebug $ fromString $ show (pl, sha, size, package) + pure CompletePackageLocation + { cplComplete = PLIArchive (Archive loc sha size subdir) (packagePM package) + , cplHasCabalFile = + case packageCabalEntry package of + PCCabalFile{} -> True + PCHpack{} -> False + } + warnWith sha size = + logWarn + (mconcat + [ "The package " + , display pl + , " is available from the local content-addressable storage database, \n" + , "but we can't use it unless you specify the size and hash for this package.\n" + , "Add the following to your package description:\n" + , "\nsize: " <> display size + , "\nsha256: " <> display sha + ]) +completePackageLocation pl@(RPLIRepo repo rpm) = do + unless (isSHA1 (repoCommit repo)) $ throwIO $ CannotCompleteRepoNonSHA1 repo + completePM repo pl rpm + where + isSHA1 t = T.length t == 40 && T.all isHexDigit t + +completePM :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Repo + -> RawPackageLocationImmutable + -> RawPackageMetadata + -> RIO env CompletePackageLocation +completePM repo plOrig rpm@(RawPackageMetadata mn mv mtk) + | Just n <- mn, Just v <- mv, Just tk <- mtk = do + let pm = PackageMetadata (PackageIdentifier n v) tk + pure CompletePackageLocation + { cplComplete = PLIRepo repo pm + -- This next bit is a hack: we don't know for certain that this is the + -- case. However, for the use case where complete package metadata has + -- been supplied, we'll assume there's a cabal file for purposes of + -- generating a deprecation warning. + , cplHasCabalFile = True + } + | otherwise = do + package <- loadPackageRaw plOrig + let pm = packagePM package + let isSame x (Just y) = x == y + isSame _ _ = True + + allSame = + isSame (pkgName $ pmIdent pm) (rpmName rpm) && + isSame (pkgVersion $ pmIdent pm) (rpmVersion rpm) && + isSame (pmTreeKey pm) (rpmTreeKey rpm) + if allSame + then pure CompletePackageLocation + { cplComplete = PLIRepo repo pm + , cplHasCabalFile = + case packageCabalEntry package of + PCCabalFile{} -> True + PCHpack{} -> False + } + else throwIO $ CompletePackageMetadataMismatch plOrig pm + +packagePM :: Package -> PackageMetadata +packagePM package = PackageMetadata + { pmIdent = packageIdent package + , pmTreeKey = packageTreeKey package + } + +-- | Add in hashes to make a 'SnapshotLocation' reproducible. +-- +-- @since 0.1.0.0 +completeSnapshotLocation :: + (HasPantryConfig env, HasLogFunc env) + => RawSnapshotLocation + -> RIO env SnapshotLocation +completeSnapshotLocation (RSLCompiler c) = pure $ SLCompiler c +completeSnapshotLocation (RSLFilePath f) = pure $ SLFilePath f +completeSnapshotLocation (RSLUrl url (Just blobKey)) = pure $ SLUrl url blobKey +completeSnapshotLocation (RSLUrl url Nothing) = do + bs <- loadFromURL url Nothing + pure $ SLUrl url (bsToBlobKey bs) +completeSnapshotLocation (RSLSynonym syn) = + completeSnapshotLocation =<< snapshotLocation syn + +traverseConcurrently_ :: + (Foldable f, HasPantryConfig env) + => (a -> RIO env ()) -- ^ action to perform + -> f a -- ^ input values + -> RIO env () +traverseConcurrently_ f t0 = do + cnt <- view $ pantryConfigL.to pcConnectionCount + traverseConcurrentlyWith_ cnt f t0 + +traverseConcurrentlyWith_ :: + (MonadUnliftIO m, Foldable f) + => Int -- ^ concurrent workers + -> (a -> m ()) -- ^ action to perform + -> f a -- ^ input values + -> m () +traverseConcurrentlyWith_ count f t0 = do + queue <- newTVarIO $ toList t0 + + replicateConcurrently_ count $ + fix $ \loop -> join $ atomically $ do + toProcess <- readTVar queue + case toProcess of + [] -> pure (pure ()) + (x:rest) -> do + writeTVar queue rest + pure $ do + f x + loop + +-- | Parse a 'RawSnapshot' (all layers) from a 'RawSnapshotLocation'. +-- +-- @since 0.1.0.0 +loadSnapshotRaw :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawSnapshotLocation + -> RIO env RawSnapshot +loadSnapshotRaw loc = do + eres <- loadRawSnapshotLayer loc + case eres of + Left wc -> + pure RawSnapshot + { rsCompiler = wc + , rsPackages = mempty + , rsDrop = mempty + } + Right (rsl, _) -> do + snap0 <- loadSnapshotRaw $ rslParent rsl + (packages, unused) <- + addPackagesToSnapshot + (display loc) + (rslLocations rsl) + AddPackagesConfig + { apcDrop = rslDropPackages rsl + , apcFlags = rslFlags rsl + , apcHiddens = rslHidden rsl + , apcGhcOptions = rslGhcOptions rsl + } + (rsPackages snap0) + warnUnusedAddPackagesConfig (display loc) unused + pure RawSnapshot + { rsCompiler = fromMaybe (rsCompiler snap0) (rslCompiler rsl) + , rsPackages = packages + , rsDrop = apcDrop unused + } + +-- | Parse a 'RawSnapshot' (all layers) from a 'SnapshotLocation'. +-- +-- @since 0.1.0.0 +loadSnapshot :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => SnapshotLocation + -> RIO env RawSnapshot +loadSnapshot loc = do + eres <- loadSnapshotLayer loc + case eres of + Left wc -> + pure RawSnapshot + { rsCompiler = wc + , rsPackages = mempty + , rsDrop = mempty + } + Right rsl -> do + snap0 <- loadSnapshotRaw $ rslParent rsl + (packages, unused) <- + addPackagesToSnapshot + (display loc) + (rslLocations rsl) + AddPackagesConfig + { apcDrop = rslDropPackages rsl + , apcFlags = rslFlags rsl + , apcHiddens = rslHidden rsl + , apcGhcOptions = rslGhcOptions rsl + } + (rsPackages snap0) + warnUnusedAddPackagesConfig (display loc) unused + pure RawSnapshot + { rsCompiler = fromMaybe (rsCompiler snap0) (rslCompiler rsl) + , rsPackages = packages + , rsDrop = apcDrop unused + } + +-- | A completed package location, including the original raw and completed +-- information. +-- +-- @since 0.1.0.0 +data CompletedPLI + = CompletedPLI !RawPackageLocationImmutable !PackageLocationImmutable + +-- | A completed snapshot location, including the original raw and completed +-- information. +-- +-- @since 0.1.0.0 +data CompletedSL = CompletedSL !RawSnapshotLocation !SnapshotLocation + +-- | Parse a 'Snapshot' (all layers) from a 'SnapshotLocation' noting any +-- incomplete package locations. Debug output will include the raw snapshot +-- layer. +-- +-- @since 0.1.0.0 +loadAndCompleteSnapshot :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => SnapshotLocation + -> Map RawSnapshotLocation SnapshotLocation + -- ^ Cached snapshot locations from lock file + -> Map RawPackageLocationImmutable PackageLocationImmutable + -- ^ Cached locations from lock file + -> RIO env (Snapshot, [CompletedSL], [CompletedPLI]) +loadAndCompleteSnapshot = loadAndCompleteSnapshot' True + +-- | As for 'loadAndCompleteSnapshot' but allows toggling of the debug output of +-- the raw snapshot layer. +-- +-- @since 0.5.7 +loadAndCompleteSnapshot' :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Bool -- ^ Debug output includes the raw snapshot layer + -> SnapshotLocation + -> Map RawSnapshotLocation SnapshotLocation + -- ^ Cached snapshot locations from lock file + -> Map RawPackageLocationImmutable PackageLocationImmutable + -- ^ Cached locations from lock file + -> RIO env (Snapshot, [CompletedSL], [CompletedPLI]) +loadAndCompleteSnapshot' debugRSL loc = + loadAndCompleteSnapshotRaw' debugRSL (toRawSL loc) + +-- | Parse a 'Snapshot' (all layers) from a 'RawSnapshotLocation' completing +-- any incomplete package locations. Debug output will include the raw snapshot +-- layer. +-- +-- @since 0.1.0.0 +loadAndCompleteSnapshotRaw :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawSnapshotLocation + -> Map RawSnapshotLocation SnapshotLocation + -- ^ Cached snapshot locations from lock file + -> Map RawPackageLocationImmutable PackageLocationImmutable + -- ^ Cached locations from lock file + -> RIO env (Snapshot, [CompletedSL], [CompletedPLI]) +loadAndCompleteSnapshotRaw = loadAndCompleteSnapshotRaw' True + +-- | As for 'loadAndCompleteSnapshotRaw' but allows toggling of the debug output +-- of the raw snapshot layer. +-- +-- @since 0.5.7 +loadAndCompleteSnapshotRaw' :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Bool -- ^ Debug output includes the raw snapshot layer + -> RawSnapshotLocation + -> Map RawSnapshotLocation SnapshotLocation + -- ^ Cached snapshot locations from lock file + -> Map RawPackageLocationImmutable PackageLocationImmutable + -- ^ Cached locations from lock file + -> RIO env (Snapshot, [CompletedSL], [CompletedPLI]) +loadAndCompleteSnapshotRaw' debugRSL rawLoc cacheSL cachePL = do + eres <- case Map.lookup rawLoc cacheSL of + Just loc -> right (, CompletedSL rawLoc loc) <$> loadSnapshotLayer loc + Nothing -> loadRawSnapshotLayer rawLoc + case eres of + Left wc -> + let snapshot = Snapshot + { snapshotCompiler = wc + , snapshotPackages = mempty + , snapshotDrop = mempty + } + in pure (snapshot, [CompletedSL (RSLCompiler wc) (SLCompiler wc)], []) + Right (rsl, sloc) -> do + (snap0, slocs, completed0) <- loadAndCompleteSnapshotRaw' debugRSL (rslParent rsl) cacheSL cachePL + when debugRSL $ logDebug $ fromString $ show rsl + (packages, completed, unused) <- + addAndCompletePackagesToSnapshot + rawLoc + cachePL + (rslLocations rsl) + AddPackagesConfig + { apcDrop = rslDropPackages rsl + , apcFlags = rslFlags rsl + , apcHiddens = rslHidden rsl + , apcGhcOptions = rslGhcOptions rsl + } + (snapshotPackages snap0) + warnUnusedAddPackagesConfig (display rawLoc) unused + let snapshot = Snapshot + { snapshotCompiler = fromMaybe (snapshotCompiler snap0) (rslCompiler rsl) + , snapshotPackages = packages + , snapshotDrop = apcDrop unused + } + pure (snapshot, sloc : slocs,completed0 ++ completed) + +data SingleOrNot a + = Single !a + | Multiple !a !a !([a] -> [a]) + +instance Semigroup (SingleOrNot a) where + Single a <> Single b = Multiple a b id + Single a <> Multiple b c d = Multiple a b ((c:) . d) + Multiple a b c <> Single d = Multiple a b (c . (d:)) + Multiple a b c <> Multiple d e f = + Multiple a b (c . (d:) . (e:) . f) + +sonToEither :: (k, SingleOrNot a) -> Either (k, a) (k, [a]) +sonToEither (k, Single a) = Left (k, a) +sonToEither (k, Multiple a b c) = Right (k, a : b : c []) + +-- | Package settings to be passed to 'addPackagesToSnapshot'. +-- +-- @since 0.1.0.0 +data AddPackagesConfig = AddPackagesConfig + { apcDrop :: !(Set PackageName) + , apcFlags :: !(Map PackageName (Map FlagName Bool)) + , apcHiddens :: !(Map PackageName Bool) + , apcGhcOptions :: !(Map PackageName [Text]) + } + +-- | Does not warn about drops, those are allowed in order to ignore global +-- packages. +warnUnusedAddPackagesConfig :: + HasLogFunc env + => Utf8Builder -- ^ source + -> AddPackagesConfig + -> RIO env () +warnUnusedAddPackagesConfig source (AddPackagesConfig _drops flags hiddens options) = do + unless (null ls) $ do + logWarn $ "Some warnings discovered when adding packages to snapshot (" <> source <> ")" + traverse_ logWarn ls + where + ls = concat [flags', hiddens', options'] + + flags' = + map + (\pn -> + "Setting flags for nonexistent package: " <> + fromString (packageNameString pn)) + (Map.keys flags) + + hiddens' = + map + (\pn -> + "Hiding nonexistent package: " <> + fromString (packageNameString pn)) + (Map.keys hiddens) + + options' = + map + (\pn -> + "Setting options for nonexistent package: " <> + fromString (packageNameString pn)) + (Map.keys options) + +-- | Add more packages to a snapshot +-- +-- Note that any settings on a parent flag which is being replaced will be +-- ignored. For example, if package @foo@ is in the parent and has flag @bar@ +-- set, and @foo@ also appears in new packages, then @bar@ will no longer be +-- set. +-- +-- Returns any of the 'AddPackagesConfig' values not used. +-- +-- @since 0.1.0.0 +addPackagesToSnapshot :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Utf8Builder + -- ^ Text description of where these new packages are coming from, for + -- error messages only + -> [RawPackageLocationImmutable] -- ^ new packages + -> AddPackagesConfig + -> Map PackageName RawSnapshotPackage -- ^ packages from parent + -> RIO env (Map PackageName RawSnapshotPackage, AddPackagesConfig) +addPackagesToSnapshot source newPackages (AddPackagesConfig drops flags hiddens options) old = do + new' <- for newPackages $ \loc -> do + name <- getPackageLocationName loc + pure (name, RawSnapshotPackage + { rspLocation = loc + , rspFlags = Map.findWithDefault mempty name flags + , rspHidden = Map.findWithDefault False name hiddens + , rspGhcOptions = Map.findWithDefault [] name options + }) + let (newSingles, newMultiples) + = partitionEithers + $ map sonToEither + $ Map.toList + $ Map.fromListWith (<>) + $ map (second Single) new' + unless (null newMultiples) $ throwIO $ + DuplicatePackageNames source $ map (second (map rspLocation)) newMultiples + let new = Map.fromList newSingles + allPackages0 = new `Map.union` (old `Map.difference` Map.fromSet (const ()) drops) + allPackages = flip Map.mapWithKey allPackages0 $ \name rsp -> + rsp + { rspFlags = Map.findWithDefault (rspFlags rsp) name flags + , rspHidden = Map.findWithDefault (rspHidden rsp) name hiddens + , rspGhcOptions = Map.findWithDefault (rspGhcOptions rsp) name options + } + + unused = AddPackagesConfig + (drops `Set.difference` Map.keysSet old) + (flags `Map.difference` allPackages) + (hiddens `Map.difference` allPackages) + (options `Map.difference` allPackages) + + pure (allPackages, unused) + +cachedSnapshotCompletePackageLocation :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Map RawPackageLocationImmutable PackageLocationImmutable + -> RawPackageLocationImmutable + -> RIO env (Maybe PackageLocationImmutable) +cachedSnapshotCompletePackageLocation cachePackages rpli = do + let xs = Map.lookup rpli cachePackages + case xs of + Nothing -> do + cpl <- completePackageLocation rpli + pure $ if cplHasCabalFile cpl then Just (cplComplete cpl) else Nothing + Just x -> pure $ Just x + +-- | Add more packages to a snapshot completing their locations if needed +-- +-- Note that any settings on a parent flag which is being replaced will be +-- ignored. For example, if package @foo@ is in the parent and has flag @bar@ +-- set, and @foo@ also appears in new packages, then @bar@ will no longer be +-- set. +-- +-- Returns any of the 'AddPackagesConfig' values not used and also all +-- non-trivial package location completions. +-- +-- @since 0.1.0.0 +addAndCompletePackagesToSnapshot :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawSnapshotLocation + -- ^ Text description of where these new packages are coming from, for + -- error messages only + -> Map RawPackageLocationImmutable PackageLocationImmutable + -- ^ Cached data from snapshot lock file + -> [RawPackageLocationImmutable] -- ^ new packages + -> AddPackagesConfig + -> Map PackageName SnapshotPackage -- ^ packages from parent + -> RIO + env + (Map PackageName SnapshotPackage, [CompletedPLI], AddPackagesConfig) +addAndCompletePackagesToSnapshot loc cachedPL newPackages (AddPackagesConfig drops flags hiddens options) old = do + let source = display loc + addPackage :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => ([(PackageName, SnapshotPackage)],[CompletedPLI]) + -> RawPackageLocationImmutable + -> RIO env ([(PackageName, SnapshotPackage)], [CompletedPLI]) + addPackage (ps, completed) rawLoc = do + mcomplLoc <- cachedSnapshotCompletePackageLocation cachedPL rawLoc + case mcomplLoc of + Nothing -> do + warnMissingCabalFile rawLoc + pure (ps, completed) + Just complLoc -> do + let PackageIdentifier name _ = packageLocationIdent complLoc + p = (name, SnapshotPackage + { spLocation = complLoc + , spFlags = Map.findWithDefault mempty name flags + , spHidden = Map.findWithDefault False name hiddens + , spGhcOptions = Map.findWithDefault [] name options + }) + completed' = if toRawPLI complLoc == rawLoc + then completed + else CompletedPLI rawLoc complLoc:completed + pure (p:ps, completed') + (revNew, revCompleted) <- foldM addPackage ([], []) newPackages + let (newSingles, newMultiples) + = partitionEithers + $ map sonToEither + $ Map.toList + $ Map.fromListWith (<>) + $ map (second Single) (reverse revNew) + unless (null newMultiples) $ throwIO $ + DuplicatePackageNames source $ map (second (map (toRawPLI . spLocation))) newMultiples + let new = Map.fromList newSingles + allPackages0 = new `Map.union` (old `Map.difference` Map.fromSet (const ()) drops) + allPackages = flip Map.mapWithKey allPackages0 $ \name sp -> + sp + { spFlags = Map.findWithDefault (spFlags sp) name flags + , spHidden = Map.findWithDefault (spHidden sp) name hiddens + , spGhcOptions = Map.findWithDefault (spGhcOptions sp) name options + } + + unused = AddPackagesConfig + (drops `Set.difference` Map.keysSet old) + (flags `Map.difference` allPackages) + (hiddens `Map.difference` allPackages) + (options `Map.difference` allPackages) + + pure (allPackages, reverse revCompleted, unused) + +-- | Parse a 'SnapshotLayer' value from a 'SnapshotLocation'. +-- +-- Returns a 'Left' value if provided an 'SLCompiler' constructor. Otherwise, +-- returns a 'Right' value providing both the 'Snapshot' and a hash of the input +-- configuration file. +-- +-- @since 0.1.0.0 +loadRawSnapshotLayer :: + (HasPantryConfig env, HasLogFunc env) + => RawSnapshotLocation + -> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL)) +loadRawSnapshotLayer (RSLCompiler compiler) = pure $ Left compiler +loadRawSnapshotLayer rsl@(RSLUrl url blob) = + handleAny (throwIO . InvalidSnapshot rsl) $ do + bs <- loadFromURL url blob + value <- Yaml.decodeThrow bs + snapshot <- warningsParserHelperRaw rsl value Nothing + pure $ Right (snapshot, CompletedSL rsl (SLUrl url (bsToBlobKey bs))) +loadRawSnapshotLayer rsl@(RSLFilePath fp) = + handleAny (throwIO . InvalidSnapshot rsl) $ do + value <- Yaml.decodeFileThrow $ toFilePath $ resolvedAbsolute fp + snapshot <- warningsParserHelperRaw rsl value $ Just $ parent $ resolvedAbsolute fp + pure $ Right (snapshot, CompletedSL rsl (SLFilePath fp)) +loadRawSnapshotLayer rsl@(RSLSynonym syn) = do + loc <- snapshotLocation syn + comp <- loadRawSnapshotLayer loc + pure $ case comp of + Left wc -> Left wc + Right (l, CompletedSL _ n) -> Right (l, CompletedSL rsl n) + +-- | Parse a 'SnapshotLayer' value from a 'SnapshotLocation'. +-- +-- Returns a 'Left' value if provided an 'SLCompiler' constructor. Otherwise, +-- returns a 'Right' value providing both the 'Snapshot' and a hash of the input +-- configuration file. +-- +-- @since 0.1.0.0 +loadSnapshotLayer :: + (HasPantryConfig env, HasLogFunc env) + => SnapshotLocation + -> RIO env (Either WantedCompiler RawSnapshotLayer) +loadSnapshotLayer (SLCompiler compiler) = pure $ Left compiler +loadSnapshotLayer sl@(SLUrl url blob) = + handleAny (throwIO . InvalidSnapshot (toRawSL sl)) $ do + bs <- loadFromURL url (Just blob) + value <- Yaml.decodeThrow bs + snapshot <- warningsParserHelper sl value Nothing + pure $ Right snapshot +loadSnapshotLayer sl@(SLFilePath fp) = + handleAny (throwIO . InvalidSnapshot (toRawSL sl)) $ do + value <- Yaml.decodeFileThrow $ toFilePath $ resolvedAbsolute fp + snapshot <- warningsParserHelper sl value $ Just $ parent $ resolvedAbsolute fp + pure $ Right snapshot + +loadFromURL :: + (HasPantryConfig env, HasLogFunc env) + => Text -- ^ url + -> Maybe BlobKey + -> RIO env ByteString +loadFromURL url Nothing = do + mcached <- withStorage $ loadURLBlob url + case mcached of + Just bs -> pure bs + Nothing -> loadWithCheck url Nothing +loadFromURL url (Just bkey) = do + mcached <- withStorage $ loadBlob bkey + case mcached of + Just bs -> do + logDebug "Loaded snapshot from Pantry database." + pure bs + Nothing -> loadUrlViaCasaOrWithCheck url bkey + +loadUrlViaCasaOrWithCheck :: + (HasPantryConfig env, HasLogFunc env) + => Text -- ^ url + -> BlobKey + -> RIO env ByteString +loadUrlViaCasaOrWithCheck url blobKey = do + mblobFromCasa <- casaLookupKey blobKey + case mblobFromCasa of + Just blob -> do + logDebug + ("Loaded snapshot from Casa (" <> display blobKey <> ") for URL: " <> + display url) + pure blob + Nothing -> loadWithCheck url (Just blobKey) + +loadWithCheck :: + (HasPantryConfig env, HasLogFunc env) + => Text -- ^ url + -> Maybe BlobKey + -> RIO env ByteString +loadWithCheck url mblobkey = do + let (msha, msize) = + case mblobkey of + Nothing -> (Nothing, Nothing) + Just (BlobKey sha size) -> (Just sha, Just size) + (_, _, bss) <- httpSinkChecked url msha msize sinkList + let bs = B.concat bss + withStorage $ storeURLBlob url bs + logDebug ("Loaded snapshot from third party: " <> display url) + pure bs + +warningsParserHelperRaw :: + HasLogFunc env + => RawSnapshotLocation + -> Value + -> Maybe (Path Abs Dir) + -> RIO env RawSnapshotLayer +warningsParserHelperRaw rsl val mdir = + case parseEither Yaml.parseJSON val of + Left e -> throwIO $ Couldn'tParseSnapshot rsl e + Right (WithJSONWarnings x ws) -> do + unless (null ws) $ do + logWarn $ "Warnings when parsing snapshot " <> display rsl + for_ ws $ logWarn . display + resolvePaths mdir x + +warningsParserHelper :: + HasLogFunc env + => SnapshotLocation + -> Value + -> Maybe (Path Abs Dir) + -> RIO env RawSnapshotLayer +warningsParserHelper sl val mdir = + case parseEither Yaml.parseJSON val of + Left e -> throwIO $ Couldn'tParseSnapshot (toRawSL sl) e + Right (WithJSONWarnings x ws) -> do + unless (null ws) $ do + logWarn $ "Warnings when parsing snapshot " <> display sl + for_ ws $ logWarn . display + resolvePaths mdir x + +-- | Get the 'PackageName' of the package at the given location. +-- +-- @since 0.1.0.0 +getPackageLocationName :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawPackageLocationImmutable + -> RIO env PackageName +getPackageLocationName = fmap pkgName . getRawPackageLocationIdent + +-- | Get the 'PackageIdentifier' of the package at the given location. +-- +-- @since 0.1.0.0 +packageLocationIdent :: + PackageLocationImmutable + -> PackageIdentifier +packageLocationIdent (PLIHackage ident _ _) = ident +packageLocationIdent (PLIRepo _ pm) = pmIdent pm +packageLocationIdent (PLIArchive _ pm) = pmIdent pm + +-- | Get version of the package at the given location. +-- +-- @since 0.1.0.0 +packageLocationVersion :: + PackageLocationImmutable + -> Version +packageLocationVersion (PLIHackage pident _ _) = pkgVersion pident +packageLocationVersion (PLIRepo _ pm) = pkgVersion (pmIdent pm) +packageLocationVersion (PLIArchive _ pm) = pkgVersion (pmIdent pm) + +-- | Get the 'PackageIdentifier' of the package at the given location. +-- +-- @since 0.1.0.0 +getRawPackageLocationIdent :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawPackageLocationImmutable + -> RIO env PackageIdentifier +getRawPackageLocationIdent (RPLIHackage (PackageIdentifierRevision name version _) _) = + pure $ PackageIdentifier name version +getRawPackageLocationIdent (RPLIRepo _ RawPackageMetadata { rpmName = Just name, rpmVersion = Just version }) = + pure $ PackageIdentifier name version +getRawPackageLocationIdent (RPLIArchive _ RawPackageMetadata { rpmName = Just name, rpmVersion = Just version }) = + pure $ PackageIdentifier name version +getRawPackageLocationIdent rpli = packageIdent <$> loadPackageRaw rpli + +-- | Get the 'TreeKey' of the package at the given location. +-- +-- @since 0.1.0.0 +getRawPackageLocationTreeKey + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawPackageLocationImmutable + -> RIO env TreeKey +getRawPackageLocationTreeKey pl = + case getRawTreeKey pl of + Just treeKey' -> pure treeKey' + Nothing -> + case pl of + RPLIHackage pir _ -> getHackageTarballKey pir + RPLIArchive archive pm -> getArchiveKey pl archive pm + RPLIRepo repo pm -> getRepoKey repo pm + +-- | Get the 'TreeKey' of the package at the given location. +-- +-- @since 0.1.0.0 +getPackageLocationTreeKey + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => PackageLocationImmutable + -> RIO env TreeKey +getPackageLocationTreeKey pl = pure $ getTreeKey pl + +getRawTreeKey :: RawPackageLocationImmutable -> Maybe TreeKey +getRawTreeKey (RPLIHackage _ mtree) = mtree +getRawTreeKey (RPLIArchive _ rpm) = rpmTreeKey rpm +getRawTreeKey (RPLIRepo _ rpm) = rpmTreeKey rpm + +getTreeKey :: PackageLocationImmutable -> TreeKey +getTreeKey (PLIHackage _ _ tree) = tree +getTreeKey (PLIArchive _ pm) = pmTreeKey pm +getTreeKey (PLIRepo _ pm) = pmTreeKey pm + +-- | Convenient data type that allows you to work with pantry more easily than +-- using 'withPantryConfig' or 'withPantryConfig'' directly. Uses basically sane +-- settings, like sharing a pantry directory with Stack. +-- +-- You can use 'runPantryApp' to use this. +-- +-- @since 0.1.0.0 +data PantryApp = PantryApp + { paSimpleApp :: !SimpleApp + , paPantryConfig :: !PantryConfig + , paUseColor :: !Bool + , paTermWidth :: !Int + , paStylesUpdate :: !StylesUpdate + } + +simpleAppL :: Lens' PantryApp SimpleApp +simpleAppL = lens paSimpleApp (\x y -> x { paSimpleApp = y }) + +-- | Lens to view or modify the 'HpackExecutable' of a 'PantryConfig' +-- +-- @since 0.1.0.0 +hpackExecutableL :: Lens' PantryConfig HpackExecutable +hpackExecutableL k pconfig = + fmap (\hpExe -> pconfig { pcHpackExecutable = hpExe }) (k (pcHpackExecutable pconfig)) + +instance HasLogFunc PantryApp where + logFuncL = simpleAppL.logFuncL + +instance HasPantryConfig PantryApp where + pantryConfigL = lens paPantryConfig (\x y -> x { paPantryConfig = y }) + +instance HasProcessContext PantryApp where + processContextL = simpleAppL.processContextL + +instance HasStylesUpdate PantryApp where + stylesUpdateL = lens paStylesUpdate (\x y -> x { paStylesUpdate = y }) + +instance HasTerm PantryApp where + useColorL = lens paUseColor (\x y -> x { paUseColor = y }) + termWidthL = lens paTermWidth (\x y -> x { paTermWidth = y }) + +-- | Run some code against pantry using basic sane settings. +-- +-- For testing, see 'runPantryAppClean'. +-- +-- @since 0.1.0.0 +runPantryApp :: MonadIO m => RIO PantryApp a -> m a +runPantryApp = runPantryAppWith 8 defaultCasaRepoPrefix defaultCasaMaxPerRequest + +-- | Run some code against pantry using basic sane settings. +-- +-- For testing, see 'runPantryAppClean'. +-- +-- @since 0.1.1.1 +runPantryAppWith :: + MonadIO m + => Int + -> CasaRepoPrefix + -> Int + -> RIO PantryApp a + -> m a +runPantryAppWith maxConnCount casaRepoPrefix casaMaxPerRequest f = runSimpleApp $ do + sa <- ask + stack <- getAppUserDataDirectory "stack" + root <- parseAbsDir $ stack FilePath.</> "pantry" + withPantryConfig' + root + defaultPackageIndexConfig + HpackBundled + maxConnCount + (Just (casaRepoPrefix, casaMaxPerRequest)) + defaultSnapshotLocation + $ \pc -> + runRIO + PantryApp + { paSimpleApp = sa + , paPantryConfig = pc + , paTermWidth = 100 + , paUseColor = True + , paStylesUpdate = mempty + } + f + +-- | Like 'runPantryApp', but uses an empty pantry directory instead of sharing +-- with Stack. Useful for testing. +-- +-- @since 0.1.0.0 +runPantryAppClean :: MonadIO m => RIO PantryApp a -> m a +runPantryAppClean f = + liftIO $ withSystemTempDirectory "pantry-clean" $ \dir -> runSimpleApp $ do + sa <- ask + root <- resolveDir' dir + withPantryConfig' + root + defaultPackageIndexConfig + HpackBundled + 8 + (Just (defaultCasaRepoPrefix, defaultCasaMaxPerRequest)) + defaultSnapshotLocation + $ \pc -> + runRIO + PantryApp + { paSimpleApp = sa + , paPantryConfig = pc + , paTermWidth = 100 + , paUseColor = True + , paStylesUpdate = mempty + } + f + +-- | Load the global hints from GitHub. +-- +-- @since 0.1.0.0 +loadGlobalHints :: + (HasTerm env, HasPantryConfig env) + => WantedCompiler + -> RIO env (Maybe (Map PackageName Version)) +loadGlobalHints wc = + inner False + where + inner alreadyDownloaded = do + dest <- getGlobalHintsFile + req <- parseRequest "https://raw.githubusercontent.com/commercialhaskell/stackage-content/master/stack/global-hints.yaml" + downloaded <- download req dest + eres <- tryAny (inner2 dest) + mres <- + case eres of + Left e -> Nothing <$ logError + ( "Error: [S-912]\n" + <> "Error when parsing global hints: " + <> displayShow e + ) + Right x -> pure x + case mres of + Nothing | not alreadyDownloaded && not downloaded -> do + logInfo $ + "Could not find local global hints for " <> + RIO.display wc <> + ", forcing a redownload" + x <- redownload req dest + if x + then inner True + else do + logInfo "Redownload didn't happen" + pure Nothing + _ -> pure mres + + inner2 dest = liftIO $ + Map.lookup wc . fmap (fmap unCabalString . unCabalStringMap) + <$> Yaml.decodeFileThrow (toFilePath dest) + +-- | Partition a map of global packages with its versions into a Set of replaced +-- packages and its dependencies and a map of remaining (untouched) packages. +-- +-- @since 0.1.0.0 +partitionReplacedDependencies :: + Ord id + => Map PackageName a -- ^ global packages + -> (a -> PackageName) -- ^ package name getter + -> (a -> id) -- ^ returns unique package id used for dependency pruning + -> (a -> [id]) -- ^ returns unique package ids of direct package dependencies + -> Set PackageName -- ^ overrides which global dependencies should get pruned + -> (Map PackageName [PackageName], Map PackageName a) +partitionReplacedDependencies globals getName getId getDeps overrides = + flip execState (replaced, mempty) $ + for (Map.toList globals) $ prunePackageWithDeps globals' getName getDeps + where + globals' = Map.fromList $ map (getId &&& id) (Map.elems globals) + replaced = Map.map (const []) $ Map.restrictKeys globals overrides + +prunePackageWithDeps :: + Ord id + => Map id a + -> (a -> PackageName) + -> (a -> [id]) + -> (PackageName, a) + -> State (Map PackageName [PackageName], Map PackageName a) Bool +prunePackageWithDeps pkgs getName getDeps (pname, a) = do + (pruned, kept) <- get + if Map.member pname pruned + then pure True + else if Map.member pname kept + then pure False + else do + let deps = Map.elems $ Map.restrictKeys pkgs (Set.fromList $ getDeps a) + prunedDeps <- forMaybeM deps $ \dep -> do + let depName = getName dep + isPruned <- prunePackageWithDeps pkgs getName getDeps (depName, dep) + pure $ if isPruned then Just depName else Nothing + if null prunedDeps + then do + modify' $ second (Map.insert pname a) + else do + modify' $ first (Map.insert pname prunedDeps) + pure $ not (null prunedDeps) + +-- | Use a snapshot cache, which caches which modules are in which packages in a +-- given snapshot. This is mostly intended for usage by Stack. +-- +-- @since 0.1.0.0 +withSnapshotCache :: + (HasPantryConfig env, HasLogFunc env) + => SnapshotCacheHash + -> RIO env (Map PackageName (Set ModuleName)) + -> ((ModuleName -> RIO env [PackageName]) -> RIO env a) + -> RIO env a +withSnapshotCache hash getModuleMapping f = do + mres <- withStorage $ getSnapshotCacheByHash hash + cacheId <- case mres of + Nothing -> do + logWarn "Populating snapshot module name cache" + packageModules <- getModuleMapping + withStorage $ do + scId <- getSnapshotCacheId hash + storeSnapshotModuleCache scId packageModules + pure scId + Just scId -> pure scId + f $ withStorage . loadExposedModulePackages cacheId + +-- | Add an s to the builder if n!=1. +plural :: Int -> Utf8Builder -> Utf8Builder +plural n text = + display n + <> " " + <> text + <> (if n == 1 + then "" + else "s")
src/Pantry/Archive.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + -- | Logic for loading up trees from HTTPS archives. module Pantry.Archive ( getArchivePackage @@ -12,50 +13,50 @@ , findCabalOrHpackFile ) where -import RIO +import qualified Codec.Archive.Zip as Zip +import Conduit +import Data.Bits ( (.&.), shiftR ) +import qualified Data.Conduit.Tar as Tar +import Data.Conduit.Zlib ( ungzip ) +import qualified Data.Digest.CRC32 as CRC32 +import Distribution.PackageDescription ( package, packageDescription ) +import qualified Hpack.Config as Hpack +import Pantry.HPack ( hpackVersion ) +import Pantry.HTTP +import Pantry.Internal ( makeTarRelative, normalizeParents ) import qualified Pantry.SHA256 as SHA256 -import Pantry.Storage hiding (Tree, TreeEntry, findOrGenerateCabalFile) -import Pantry.Tree -import Pantry.Types -import RIO.Process -import Pantry.Internal (normalizeParents, makeTarRelative) -import qualified RIO.Text as T -import qualified RIO.Text.Partial as T -import qualified RIO.List as List +import Pantry.Storage hiding + ( Tree, TreeEntry, findOrGenerateCabalFile ) +import Pantry.Tree +import Pantry.Types +import Path ( toFilePath ) +import RIO import qualified RIO.ByteString.Lazy as BL +import qualified RIO.List as List import qualified RIO.Map as Map +import RIO.Process import qualified RIO.Set as Set -import qualified Hpack.Config as Hpack -import Pantry.HPack (hpackVersion) -import Data.Bits ((.&.), shiftR) -import Path (toFilePath) -import qualified Codec.Archive.Zip as Zip -import qualified Data.Digest.CRC32 as CRC32 -import Distribution.PackageDescription (packageDescription, package) - -import Conduit -import Data.Conduit.Zlib (ungzip) -import qualified Data.Conduit.Tar as Tar -import Pantry.HTTP +import qualified RIO.Text as T +import qualified RIO.Text.Partial as T -fetchArchivesRaw - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) +fetchArchivesRaw :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => [(RawArchive, RawPackageMetadata)] -> RIO env () fetchArchivesRaw pairs = for_ pairs $ \(ra, rpm) -> getArchive (RPLIArchive ra rpm) ra rpm -fetchArchives - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) +fetchArchives :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => [(Archive, PackageMetadata)] -> RIO env () fetchArchives pairs = -- TODO be more efficient, group together shared archives fetchArchivesRaw [(toRawArchive a, toRawPM pm) | (a, pm) <- pairs] -getArchiveKey - :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) +getArchiveKey :: + forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawPackageLocationImmutable -- ^ for exceptions -> RawArchive -> RawPackageMetadata @@ -66,16 +67,16 @@ thd4 :: (a, b, c, d) -> c thd4 (_, _, z, _) = z -getArchivePackage - :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env, HasCallStack) +getArchivePackage :: + forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env, HasCallStack) => RawPackageLocationImmutable -- ^ for exceptions -> RawArchive -> RawPackageMetadata -> RIO env Package getArchivePackage rpli archive rpm = thd4 <$> getArchive rpli archive rpm -getArchive - :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env, HasCallStack) +getArchive :: + forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env, HasCallStack) => RawPackageLocationImmutable -- ^ for exceptions -> RawArchive -> RawPackageMetadata @@ -92,26 +93,30 @@ etree <- withStorage $ loadCachedTree $ packageTree pa case etree of Left e -> do - logDebug $ "getArchive of " <> displayShow rpli <> ": loadCachedTree failed: " <> displayShow e + logDebug $ + "getArchive of " + <> displayShow rpli + <> ": loadCachedTree failed: " + <> displayShow e pure Nothing Right x -> pure $ Just x cached@(_, _, pa, _) <- case (mcached, mtree) of (Just (a, b, c), Just d) -> pure (a, b, c, d) -- Not in the archive. Load the archive. Completely ignore the - -- PackageMetadata for now, we'll check that the Package - -- info matches next. + -- PackageMetadata for now, we'll check that the Package info matches + -- next. _ -> withArchiveLoc archive $ \fp sha size -> do (pa, tree) <- parseArchive rpli archive fp - -- Storing in the cache exclusively uses information we have - -- about the archive itself, not metadata from the user. + -- Storing in the cache exclusively uses information we have about the + -- archive itself, not metadata from the user. storeCache archive sha size pa pure (sha, size, pa, tree) either throwIO (\_ -> pure cached) $ checkPackageMetadata rpli rpm pa -storeCache - :: forall env. (HasPantryConfig env, HasLogFunc env) +storeCache :: + forall env. (HasPantryConfig env, HasLogFunc env) => RawArchive -> SHA256 -> FileSize @@ -119,11 +124,12 @@ -> RIO env () storeCache archive sha size pa = case raLocation archive of - ALUrl url -> withStorage $ storeArchiveCache url (raSubdir archive) sha size (packageTreeKey pa) + ALUrl url -> withStorage $ + storeArchiveCache url (raSubdir archive) sha size (packageTreeKey pa) ALFilePath _ -> pure () -- TODO cache local as well -loadCache - :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) +loadCache :: + forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawPackageLocationImmutable -> RawArchive -> RIO env (Maybe (SHA256, FileSize, Package)) @@ -131,49 +137,64 @@ case loc of ALFilePath _ -> pure Nothing -- TODO can we do something intelligent here? ALUrl url -> withStorage (loadArchiveCache url (raSubdir archive)) >>= loop - where - loc = raLocation archive - msha = raHash archive - msize = raSize archive + where + loc = raLocation archive + msha = raHash archive + msize = raSize archive - loadFromCache :: TreeId -> RIO env (Maybe Package) - loadFromCache tid = fmap Just $ withStorage $ loadPackageById rpli tid + loadFromCache :: TreeId -> RIO env (Maybe Package) + loadFromCache tid = fmap Just $ withStorage $ loadPackageById rpli tid - loop [] = pure Nothing - loop ((sha, size, tid):rest) = - case msha of - Nothing -> do - case msize of - Just size' | size /= size' -> loop rest - _ -> do - case loc of - ALUrl url -> do + loop [] = pure Nothing + loop ((sha, size, tid):rest) = + case msha of + Nothing -> do + case msize of + Just size' | size /= size' -> loop rest + _ -> do + case loc of + ALUrl url -> do + -- Only debug level, let lock files solve this + logDebug $ + "Using archive from " + <> display url + <> " without a specified cryptographic hash" + logDebug $ + "Cached hash is " + <> display sha + <> ", file size " + <> display size + ALFilePath _ -> pure () + fmap (sha, size,) <$> loadFromCache tid + Just sha' + | sha == sha' -> + case msize of + Nothing -> do + case loc of -- Only debug level, let lock files solve this - logDebug $ "Using archive from " <> display url <> " without a specified cryptographic hash" - logDebug $ "Cached hash is " <> display sha <> ", file size " <> display size - ALFilePath _ -> pure () - fmap (sha, size,) <$> loadFromCache tid - Just sha' - | sha == sha' -> - case msize of - Nothing -> do - case loc of - -- Only debug level, let lock files solve this - ALUrl url -> logDebug $ "Archive from " <> display url <> " does not specify a size" - ALFilePath _ -> pure () - fmap (sha, size,) <$> loadFromCache tid - Just size' - | size == size' -> fmap (sha, size,) <$> loadFromCache tid - | otherwise -> do - -- This is an actual warning, since we have a concrete mismatch - logWarn $ "Archive from " <> display loc <> " has a matching hash but mismatched size" - logWarn "Please verify that your configuration provides the correct size" - loop rest - | otherwise -> loop rest + ALUrl url -> logDebug $ + "Archive from " + <> display url + <> " does not specify a size" + ALFilePath _ -> pure () + fmap (sha, size,) <$> loadFromCache tid + Just size' + | size == size' -> fmap (sha, size,) <$> loadFromCache tid + | otherwise -> do + -- This is an actual warning, since we have a concrete + -- mismatch + logWarn $ + "Archive from " + <> display loc + <> " has a matching hash but mismatched size" + logWarn "Please verify that your configuration provides \ + \the correct size" + loop rest + | otherwise -> loop rest -- ensure name, version, etc are correct -checkPackageMetadata - :: RawPackageLocationImmutable +checkPackageMetadata :: + RawPackageLocationImmutable -> RawPackageMetadata -> Package -> Either PantryException Package @@ -197,11 +218,10 @@ in if and tests then Right pa else Left err --- | Provide a local file with the contents of the archive, regardless --- of where it comes from. Perform SHA256 and file size validation if --- downloading. -withArchiveLoc - :: HasLogFunc env +-- | Provide a local file with the contents of the archive, regardless of where +-- it comes from. Perform SHA256 and file size validation if downloading. +withArchiveLoc :: + HasLogFunc env => RawArchive -> (FilePath -> SHA256 -> FileSize -> RIO env a) -> RIO env a @@ -210,16 +230,20 @@ fp = toFilePath abs' (sha, size) <- withBinaryFile fp ReadMode $ \h -> do size <- FileSize . fromIntegral <$> hFileSize h - for_ msize $ \size' -> when (size /= size') $ throwIO $ LocalInvalidSize abs' Mismatch - { mismatchExpected = size' - , mismatchActual = size - } + for_ msize $ \size' -> + when (size /= size') $ + throwIO $ LocalInvalidSize abs' Mismatch + { mismatchExpected = size' + , mismatchActual = size + } sha <- runConduit (sourceHandle h .| SHA256.sinkHash) - for_ msha $ \sha' -> when (sha /= sha') $ throwIO $ LocalInvalidSHA256 abs' Mismatch - { mismatchExpected = sha' - , mismatchActual = sha - } + for_ msha $ \sha' -> + when (sha /= sha') $ + throwIO $ LocalInvalidSHA256 abs' Mismatch + { mismatchExpected = sha' + , mismatchActual = sha + } pure (sha, size) f fp sha size @@ -250,8 +274,8 @@ } deriving Show -foldArchive - :: (HasPantryConfig env, HasLogFunc env) +foldArchive :: + (HasPantryConfig env, HasLogFunc env) => ArchiveLocation -- ^ for error reporting -> FilePath -> ArchiveType @@ -290,41 +314,41 @@ lbs <- BL.hGetContents h foldM go accum0 (filter (not . isDir) $ Zip.zEntries $ Zip.toArchive lbs) -foldTar - :: (HasPantryConfig env, HasLogFunc env) +foldTar :: + (HasPantryConfig env, HasLogFunc env) => ArchiveLocation -- ^ for exceptions -> a -> (a -> MetaEntry -> ConduitT ByteString o (RIO env) a) -> ConduitT ByteString o (RIO env) a foldTar loc accum0 f = do ref <- newIORef accum0 - Tar.untar $ \fi -> toME fi >>= traverse_ (\me -> do + Tar.untar $ toME >=> traverse_ (\me -> do accum <- readIORef ref accum' <- f accum me writeIORef ref $! accum') readIORef ref - where - toME :: MonadIO m => Tar.FileInfo -> m (Maybe MetaEntry) - toME fi = do - let exc = InvalidTarFileType loc (Tar.getFileInfoPath fi) (Tar.fileType fi) - mmet <- - case Tar.fileType fi of - Tar.FTSymbolicLink bs -> - case decodeUtf8' bs of - Left _ -> throwIO exc - Right text -> pure $ Just $ METLink $ T.unpack text - Tar.FTNormal -> pure $ Just $ - if Tar.fileMode fi .&. 0o100 /= 0 - then METExecutable - else METNormal - Tar.FTDirectory -> pure Nothing - _ -> throwIO exc - pure $ - (\met -> MetaEntry - { mePath = Tar.getFileInfoPath fi - , meType = met - }) - <$> mmet + where + toME :: MonadIO m => Tar.FileInfo -> m (Maybe MetaEntry) + toME fi = do + let exc = InvalidTarFileType loc (Tar.getFileInfoPath fi) (Tar.fileType fi) + mmet <- + case Tar.fileType fi of + Tar.FTSymbolicLink bs -> + case decodeUtf8' bs of + Left _ -> throwIO exc + Right text -> pure $ Just $ METLink $ T.unpack text + Tar.FTNormal -> pure $ Just $ + if Tar.fileMode fi .&. 0o100 /= 0 + then METExecutable + else METNormal + Tar.FTDirectory -> pure Nothing + _ -> throwIO exc + pure $ + (\met -> MetaEntry + { mePath = Tar.getFileInfoPath fi + , meType = met + }) + <$> mmet data SimpleEntry = SimpleEntry { seSource :: !FilePath @@ -332,18 +356,16 @@ } deriving Show - --- | Attempt to parse the contents of the given archive in the given --- subdir into a 'Tree'. This will not consult any caches. It will --- ensure that: +-- | Attempt to parse the contents of the given archive in the given subdir into +-- a 'Tree'. This will not consult any caches. It will ensure that: -- -- * The cabal file exists -- -- * The cabal file can be parsed -- -- * The name inside the cabal file matches the name of the cabal file itself -parseArchive - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) +parseArchive :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawPackageLocationImmutable -> RawArchive -> FilePath -- ^ file holding the archive @@ -362,8 +384,10 @@ let toSimple :: FilePath -> MetaEntry -> Either String (Map FilePath SimpleEntry) toSimple key me = case meType me of - METNormal -> Right $ Map.singleton key $ SimpleEntry (mePath me) FTNormal - METExecutable -> Right $ Map.singleton key $ SimpleEntry (mePath me) FTExecutable + METNormal -> + Right $ Map.singleton key $ SimpleEntry (mePath me) FTNormal + METExecutable -> + Right $ Map.singleton key $ SimpleEntry (mePath me) FTExecutable METLink relDest -> do case relDest of '/':_ -> Left $ concat @@ -402,15 +426,32 @@ Nothing -> -- Check if it's a symlink to a directory case findWithPrefix dest files of - [] -> Left $ "Symbolic link dest not found from " ++ mePath me ++ " to " ++ relDest ++ ", looking for " ++ dest ++ ".\n" - ++ "This may indicate that the source is a git archive which uses git-annex.\n" - ++ "See https://github.com/commercialhaskell/stack/issues/4579 for further information." - pairs -> fmap fold $ for pairs $ \(suffix, me') -> toSimple (key ++ '/' : suffix) me' + [] -> Left $ + "Symbolic link dest not found from " + ++ mePath me + ++ " to " + ++ relDest + ++ ", looking for " + ++ dest + ++ ".\n" + ++ "This may indicate that the source is a git \ + \archive which uses git-annex.\n" + ++ "See https://github.com/commercialhaskell/stack/issues/4579 \ + \for further information." + pairs -> + fmap fold $ for pairs $ \(suffix, me') -> toSimple (key ++ '/' : suffix) me' Just me' -> case meType me' of - METNormal -> Right $ Map.singleton key $ SimpleEntry dest FTNormal - METExecutable -> Right $ Map.singleton key $ SimpleEntry dest FTExecutable - METLink _ -> Left $ "Symbolic link dest cannot be a symbolic link, from " ++ mePath me ++ " to " ++ relDest + METNormal -> + Right $ Map.singleton key $ SimpleEntry dest FTNormal + METExecutable -> + Right $ Map.singleton key $ SimpleEntry dest FTExecutable + METLink _ -> + Left $ + "Symbolic link dest cannot be a symbolic link, from " + ++ mePath me + ++ " to " + ++ relDest case fold <$> Map.traverseWithKey toSimple files of Left e -> throwIO $ UnsupportedTarball loc $ T.pack e @@ -435,37 +476,47 @@ else pure m tree :: CachedTree <- fmap (CachedTreeMap . Map.fromList) $ for safeFiles $ \(sfp, se) -> case Map.lookup (seSource se) blobs of - Nothing -> error $ "Impossible: blob not found for: " ++ seSource se - Just (blobKey, blobId) -> pure (sfp, (TreeEntry blobKey (seType se), blobId)) + Nothing -> + error $ "Impossible: blob not found for: " ++ seSource se + Just (blobKey, blobId) -> + pure (sfp, (TreeEntry blobKey (seType se), blobId)) -- parse the cabal file and ensure it has the right name buildFile <- findCabalOrHpackFile rpli $ unCachedTree tree (buildFilePath, buildFileBlobKey, buildFileEntry) <- case buildFile of - BFCabal fpath te@(TreeEntry key _) -> pure (fpath, key, te) - BFHpack te@(TreeEntry key _) -> pure (hpackSafeFilePath, key, te) + BFCabal fpath te@(TreeEntry key _) -> pure (fpath, key, te) + BFHpack te@(TreeEntry key _) -> pure (hpackSafeFilePath, key, te) mbs <- withStorage $ loadBlob buildFileBlobKey - bs <- - case mbs of - Nothing -> throwIO $ TreeReferencesMissingBlob rpli buildFilePath buildFileBlobKey - Just bs -> pure bs + bs <- case mbs of + Nothing -> throwIO $ + TreeReferencesMissingBlob rpli buildFilePath buildFileBlobKey + Just bs -> pure bs cabalBs <- case buildFile of BFCabal _ _ -> pure bs BFHpack _ -> snd <$> hpackToCabal rpli (unCachedTree tree) (_warnings, gpd) <- rawParseGPD (Left rpli) cabalBs let ident@(PackageIdentifier name _) = package $ packageDescription gpd case buildFile of - BFCabal _ _ -> when (buildFilePath /= cabalFileName name) $ throwIO $ WrongCabalFileName rpli buildFilePath name - _ -> return () + BFCabal _ _ -> + when (buildFilePath /= cabalFileName name) $ + throwIO $ WrongCabalFileName rpli buildFilePath name + _ -> pure () -- It's good! Store the tree, let's bounce (tid, treeKey') <- withStorage $ storeTree rpli ident tree buildFile packageCabal <- case buildFile of - BFCabal _ _ -> pure $ PCCabalFile buildFileEntry - BFHpack _ -> do - cabalKey <- withStorage $ do - hpackId <- storeHPack rpli tid - loadCabalBlobKey hpackId - hpackSoftwareVersion <- hpackVersion - let cabalTreeEntry = TreeEntry cabalKey (teType buildFileEntry) - pure $ PCHpack $ PHpack { phOriginal = buildFileEntry, phGenerated = cabalTreeEntry, phVersion = hpackSoftwareVersion} + BFCabal _ _ -> pure $ PCCabalFile buildFileEntry + BFHpack _ -> do + cabalKey <- withStorage $ do + hpackId <- storeHPack rpli tid + loadCabalBlobKey hpackId + hpackSoftwareVersion <- hpackVersion + let cabalTreeEntry = TreeEntry cabalKey (teType buildFileEntry) + pure + $ PCHpack + $ PHpack + { phOriginal = buildFileEntry + , phGenerated = cabalTreeEntry + , phVersion = hpackSoftwareVersion + } pure (Package { packageTreeKey = treeKey' , packageTree = unCachedTree tree @@ -473,17 +524,17 @@ , packageIdent = ident }, tree) --- | Find all of the files in the Map with the given directory as a --- prefix. Directory is given without trailing slash. Returns the --- suffix after stripping the given prefix. +-- | Find all of the files in the Map with the given directory as a prefix. +-- Directory is given without trailing slash. Returns the suffix after stripping +-- the given prefix. findWithPrefix :: FilePath -> Map FilePath MetaEntry -> [(FilePath, MetaEntry)] findWithPrefix dir = mapMaybe go . Map.toList - where - prefix = dir ++ "/" - go (x, y) = (, y) <$> List.stripPrefix prefix x + where + prefix = dir ++ "/" + go (x, y) = (, y) <$> List.stripPrefix prefix x -findCabalOrHpackFile - :: MonadThrow m +findCabalOrHpackFile :: + MonadThrow m => RawPackageLocationImmutable -- ^ for exceptions -> Tree -> m BuildFile @@ -493,22 +544,22 @@ in not ("/" `T.isInfixOf` txt) && (".cabal" `T.isSuffixOf` txt) isHpackFile (sfp, _) = let txt = unSafeFilePath sfp - in T.pack (Hpack.packageConfig) == txt + in T.pack Hpack.packageConfig == txt isBFCabal (BFCabal _ _) = True isBFCabal _ = False sfpBuildFile (BFCabal sfp _) = sfp sfpBuildFile (BFHpack _) = hpackSafeFilePath - toBuildFile xs@(sfp, te) = let cbFile = if (isCabalFile xs) - then Just $ BFCabal sfp te - else Nothing - hpFile = if (isHpackFile xs) - then Just $ BFHpack te - else Nothing - in cbFile <|> hpFile + toBuildFile xs@(sfp, te) = let cbFile = if isCabalFile xs + then Just $ BFCabal sfp te + else Nothing + hpFile = if isHpackFile xs + then Just $ BFHpack te + else Nothing + in cbFile <|> hpFile case mapMaybe toBuildFile $ Map.toList m of [] -> throwM $ TreeWithoutCabalFile loc [bfile] -> pure bfile - xs -> case (filter isBFCabal xs) of + xs -> case filter isBFCabal xs of [] -> throwM $ TreeWithoutCabalFile loc [bfile] -> pure bfile xs' -> throwM $ TreeWithMultipleCabalFiles loc $ map sfpBuildFile xs' @@ -523,8 +574,8 @@ stripCommonPrefix <$> traverse strip pairs -- | Take us down to the specified subdirectory -takeSubdir - :: Text -- ^ subdir +takeSubdir :: + Text -- ^ subdir -> [(FilePath, a)] -- ^ files after stripping common prefix -> [(Text, a)] takeSubdir subdir = mapMaybe $ \(fp, a) -> do
src/Pantry/Casa.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DisambiguateRecordFields #-} -- | Integration with the Casa server. @@ -10,7 +9,7 @@ import Conduit import qualified Data.HashMap.Strict as HM import qualified Pantry.SHA256 as SHA256 -import Pantry.Storage hiding (findOrGenerateCabalFile) +import Pantry.Storage hiding ( findOrGenerateCabalFile ) import Pantry.Types as P import RIO import qualified RIO.ByteString as B @@ -25,9 +24,9 @@ (withStorage (runConduitRes (casaBlobSource (Identity key) .| mapMC parseTreeM .| await))) --- | Lookup a single blob. If possible, prefer 'casaBlobSource', and --- query a group of keys at once, rather than one at a time. This will --- have better network performance. +-- | Lookup a single blob. If possible, prefer 'casaBlobSource', and query a +-- group of keys at once, rather than one at a time. This will have better +-- network performance. casaLookupKey :: (HasPantryConfig env, HasLogFunc env) => BlobKey @@ -38,42 +37,49 @@ (fmap snd) (withStorage (runConduitRes (casaBlobSource (Identity key) .| await)))) --- | A source of blobs given a set of keys. All blobs are --- automatically stored in the local pantry database. +-- | A source of blobs given a set of keys. All blobs are automatically stored +-- in the local pantry database. casaBlobSource :: (Foldable f, HasPantryConfig env, HasLogFunc env) => f BlobKey - -> ConduitT i (BlobKey, ByteString) (ResourceT (ReaderT SqlBackend (RIO env))) () + -> ConduitT + i + (BlobKey, ByteString) + (ResourceT (ReaderT SqlBackend (RIO env))) + () casaBlobSource keys = source .| convert .| store - where - source = do - pullUrl <- lift $ lift $ lift $ view $ pantryConfigL . to pcCasaRepoPrefix - maxPerRequest <- lift $ lift $ lift $ view $ pantryConfigL . to pcCasaMaxPerRequest - Casa.blobsSource - (Casa.SourceConfig - { sourceConfigUrl = pullUrl - , sourceConfigBlobs = toBlobKeyMap keys - , sourceConfigMaxBlobsPerRequest = maxPerRequest - }) - where - toBlobKeyMap :: Foldable f => f BlobKey -> HashMap Casa.BlobKey Int - toBlobKeyMap = HM.fromList . map unpackBlobKey . toList - unpackBlobKey (P.BlobKey sha256 (FileSize fileSize)) = - (Casa.BlobKey (SHA256.toRaw sha256), fromIntegral fileSize) - convert = mapMC toBlobKeyAndBlob - where - toBlobKeyAndBlob :: - MonadThrow m - => (Casa.BlobKey, ByteString) - -> m (BlobKey, ByteString) - toBlobKeyAndBlob (Casa.BlobKey keyBytes, blob) = do - sha256 <- - case SHA256.fromRaw keyBytes of - Left e -> throwM e - Right sha -> pure sha - pure (BlobKey sha256 (FileSize (fromIntegral (B.length blob))), blob) - store = mapMC insertBlob - where - insertBlob original@(_key, binary) = do - _ <- lift (storeBlob binary) - pure original + where + source = do + mCasaConfig <- lift $ lift $ lift $ view $ pantryConfigL . to pcCasaConfig + case mCasaConfig of + Just (pullUrl, maxPerRequest) -> do + Casa.blobsSource + ( Casa.SourceConfig + { sourceConfigUrl = pullUrl + , sourceConfigBlobs = toBlobKeyMap keys + , sourceConfigMaxBlobsPerRequest = maxPerRequest + } + ) + Nothing -> throwM NoCasaConfig + where + toBlobKeyMap :: Foldable f => f BlobKey -> HashMap Casa.BlobKey Int + toBlobKeyMap = HM.fromList . map unpackBlobKey . toList + unpackBlobKey (P.BlobKey sha256 (FileSize fileSize)) = + (Casa.BlobKey (SHA256.toRaw sha256), fromIntegral fileSize) + convert = mapMC toBlobKeyAndBlob + where + toBlobKeyAndBlob :: + MonadThrow m + => (Casa.BlobKey, ByteString) + -> m (BlobKey, ByteString) + toBlobKeyAndBlob (Casa.BlobKey keyBytes, blob) = do + sha256 <- + case SHA256.fromRaw keyBytes of + Left e -> throwM e + Right sha -> pure sha + pure (BlobKey sha256 (FileSize (fromIntegral (B.length blob))), blob) + store = mapMC insertBlob + where + insertBlob original@(_key, binary) = do + _ <- lift (storeBlob binary) + pure original
src/Pantry/HPack.hs view
@@ -1,78 +1,81 @@-{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} module Pantry.HPack - ( - hpack - , hpackVersion - ) where + ( hpack + , hpackVersion + ) where -import RIO -import RIO.Process -import Pantry.Types import qualified Data.ByteString.Lazy.Char8 as BL +import Data.Char ( isDigit, isSpace ) import qualified Hpack import qualified Hpack.Config as Hpack -import Data.Char (isSpace, isDigit) -import Path (Path, Abs, toFilePath, Dir, (</>), filename, parseRelFile) -import Path.IO (doesFileExist) - +import Pantry.Types +import Path + ( Abs, Dir, Path, (</>), filename, parseRelFile, toFilePath ) +import Path.IO ( doesFileExist ) +import RIO +import RIO.Process -hpackVersion - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) +hpackVersion :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RIO env Version hpackVersion = do he <- view $ pantryConfigL.to pcHpackExecutable case he of HpackBundled -> do - let bundledHpackVersion :: String = VERSION_hpack - parseVersionThrowing bundledHpackVersion + let bundledHpackVersion :: String = VERSION_hpack + parseVersionThrowing bundledHpackVersion HpackCommand command -> do - version <- BL.unpack <$> proc command ["--version"] readProcessStdout_ - let version' = dropWhile (not . isDigit) version - version'' = filter (not . isSpace) version' - parseVersionThrowing version'' + version <- BL.unpack <$> proc command ["--version"] readProcessStdout_ + let version' = dropWhile (not . isDigit) version + version'' = filter (not . isSpace) version' + parseVersionThrowing version'' -- | Generate .cabal file from package.yaml, if necessary. -hpack - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) +hpack :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Path Abs Dir -> RIO env () hpack pkgDir = do - packageConfigRelFile <- parseRelFile Hpack.packageConfig - let hpackFile = pkgDir Path.</> packageConfigRelFile - whenM (doesFileExist hpackFile) $ do - logDebug $ "Running hpack on " <> fromString (toFilePath hpackFile) - - he <- view $ pantryConfigL.to pcHpackExecutable - case he of - HpackBundled -> do - r <- liftIO $ Hpack.hpackResult $ Hpack.setProgramName "stack" $ Hpack.setTarget (toFilePath hpackFile) Hpack.defaultOptions - forM_ (Hpack.resultWarnings r) (logWarn . fromString) - let cabalFile = fromString . Hpack.resultCabalFile $ r - case Hpack.resultStatus r of - Hpack.Generated -> logDebug $ "hpack generated a modified version of " <> cabalFile - Hpack.OutputUnchanged -> logDebug $ "hpack output unchanged in " <> cabalFile - Hpack.AlreadyGeneratedByNewerHpack -> logWarn $ - cabalFile <> - " was generated with a newer version of hpack. Ignoring " <> - fromString (toFilePath hpackFile) <> - " in favor of the Cabal file.\n" <> - "Either please upgrade and try again or, if you want to use the " <> - fromString (toFilePath (filename hpackFile)) <> - " file instead of the Cabal file,\n" <> - "then please delete the Cabal file." - Hpack.ExistingCabalFileWasModifiedManually -> logWarn $ - cabalFile <> - " was modified manually. Ignoring " <> - fromString (toFilePath hpackFile) <> - " in favor of the Cabal file.\n" <> - "If you want to use the " <> - fromString (toFilePath (filename hpackFile)) <> - " file instead of the Cabal file,\n" <> - "then please delete the Cabal file." - HpackCommand command -> - withWorkingDir (toFilePath pkgDir) $ - proc command [] runProcess_ + packageConfigRelFile <- parseRelFile Hpack.packageConfig + let hpackFile = pkgDir Path.</> packageConfigRelFile + whenM (doesFileExist hpackFile) $ do + logDebug $ "Running hpack on " <> fromString (toFilePath hpackFile) + he <- view $ pantryConfigL.to pcHpackExecutable + case he of + HpackBundled -> do + r <- liftIO $ Hpack.hpackResult $ Hpack.setProgramName "stack" $ + Hpack.setTarget (toFilePath hpackFile) Hpack.defaultOptions + forM_ (Hpack.resultWarnings r) (logWarn . fromString) + let cabalFile = fromString . Hpack.resultCabalFile $ r + case Hpack.resultStatus r of + Hpack.Generated -> logDebug $ + "hpack generated a modified version of " + <> cabalFile + Hpack.OutputUnchanged -> logDebug $ + "hpack output unchanged in " + <> cabalFile + Hpack.AlreadyGeneratedByNewerHpack -> logWarn $ + cabalFile + <> " was generated with a newer version of hpack. Ignoring " + <> fromString (toFilePath hpackFile) + <> " in favor of the Cabal file.\n" + <> "Either please upgrade and try again or, if you want to use the " + <> fromString (toFilePath (filename hpackFile)) + <> " file instead of the Cabal file,\n" + <> "then please delete the Cabal file." + Hpack.ExistingCabalFileWasModifiedManually -> logWarn $ + cabalFile + <> " was modified manually. Ignoring " + <> fromString (toFilePath hpackFile) + <> " in favor of the Cabal file.\n" + <> "If you want to use the " + <> fromString (toFilePath (filename hpackFile)) + <> " file instead of the Cabal file,\n" + <> "then please delete the Cabal file." + HpackCommand command -> + withWorkingDir (toFilePath pkgDir) $ + proc command [] runProcess_
src/Pantry/HTTP.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} + module Pantry.HTTP ( module Export , withResponse @@ -8,31 +9,28 @@ ) where import Conduit -import Network.HTTP.Client as Export (parseRequest) -import Network.HTTP.Client as Export (parseUrlThrow) -import Network.HTTP.Client as Export (BodyReader, HttpExceptionContent (StatusCodeException)) -import qualified Network.HTTP.Client as HTTP (withResponse) -import Network.HTTP.Client.Internal as Export (setUri) -import Network.HTTP.Client.TLS (getGlobalManager) -import Network.HTTP.Simple as Export (HttpException (..), - Request, Response, - addRequestHeader, - defaultRequest, - getResponseBody, - getResponseHeaders, - getResponseStatus, - setRequestHeader) -import qualified Network.HTTP.Simple as HTTP hiding (withResponse) -import Network.HTTP.Types as Export (Header, HeaderName, - Status, hCacheControl, - hRange, ok200, - partialContent206, - statusCode) -import qualified Pantry.SHA256 as SHA256 +import Network.HTTP.Client as Export + ( BodyReader, HttpExceptionContent (StatusCodeException) + , parseRequest, parseUrlThrow + ) +import qualified Network.HTTP.Client as HTTP ( withResponse ) +import Network.HTTP.Client.Internal as Export ( setUri ) +import Network.HTTP.Client.TLS ( getGlobalManager ) +import Network.HTTP.Simple as Export + ( HttpException (..), Request, Response, addRequestHeader + , defaultRequest, getResponseBody, getResponseHeaders + , getResponseStatus, setRequestHeader + ) +import qualified Network.HTTP.Simple as HTTP hiding ( withResponse ) +import Network.HTTP.Types as Export + ( Header, HeaderName, Status, hCacheControl, hRange, ok200 + , partialContent206, statusCode + ) +import qualified Pantry.SHA256 as SHA256 import Pantry.Types import RIO -import qualified RIO.ByteString as B -import qualified RIO.Text as T +import qualified RIO.ByteString as B +import qualified RIO.Text as T setUserAgent :: Request -> Request setUserAgent = setRequestHeader "User-Agent" ["Haskell pantry package"] @@ -51,7 +49,7 @@ => Request -> (Response () -> ConduitT ByteString Void m a) -> m a -httpSink req inner = HTTP.httpSink (setUserAgent req) inner +httpSink req = HTTP.httpSink (setUserAgent req) httpSinkChecked :: MonadUnliftIO m @@ -61,41 +59,41 @@ -> ConduitT ByteString Void m a -> m (SHA256, FileSize, a) httpSinkChecked url msha msize sink = do - req <- liftIO $ parseUrlThrow $ T.unpack url - httpSink req $ const $ getZipSink $ (,,) - <$> ZipSink (checkSha msha) - <*> ZipSink (checkSize msize) - <*> ZipSink sink - where - checkSha mexpected = do - actual <- SHA256.sinkHash - for_ mexpected $ \expected -> unless (actual == expected) $ - throwIO $ DownloadInvalidSHA256 url Mismatch - { mismatchExpected = expected - , mismatchActual = actual - } - pure actual - checkSize mexpected = - loop 0 - where - loop accum = do - mbs <- await - case mbs of - Nothing -> - case mexpected of - Just (FileSize expected) | expected /= accum -> - throwIO $ DownloadInvalidSize url Mismatch - { mismatchExpected = FileSize expected - , mismatchActual = FileSize accum - } - _ -> pure (FileSize accum) - Just bs -> do - let accum' = accum + fromIntegral (B.length bs) - case mexpected of - Just (FileSize expected) - | accum' > expected -> - throwIO $ DownloadTooLarge url Mismatch - { mismatchExpected = FileSize expected - , mismatchActual = FileSize accum' - } - _ -> loop accum' + req <- liftIO $ parseUrlThrow $ T.unpack url + httpSink req $ const $ getZipSink $ (,,) + <$> ZipSink (checkSha msha) + <*> ZipSink (checkSize msize) + <*> ZipSink sink + where + checkSha mexpected = do + actual <- SHA256.sinkHash + for_ mexpected $ \expected -> unless (actual == expected) $ + throwIO $ DownloadInvalidSHA256 url Mismatch + { mismatchExpected = expected + , mismatchActual = actual + } + pure actual + checkSize mexpected = + loop 0 + where + loop accum = do + mbs <- await + case mbs of + Nothing -> + case mexpected of + Just (FileSize expected) | expected /= accum -> + throwIO $ DownloadInvalidSize url Mismatch + { mismatchExpected = FileSize expected + , mismatchActual = FileSize accum + } + _ -> pure (FileSize accum) + Just bs -> do + let accum' = accum + fromIntegral (B.length bs) + case mexpected of + Just (FileSize expected) + | accum' > expected -> + throwIO $ DownloadTooLarge url Mismatch + { mismatchExpected = FileSize expected + , mismatchActual = FileSize accum' + } + _ -> loop accum'
src/Pantry/Hackage.hs view
@@ -1,9 +1,10 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TupleSections #-} + module Pantry.Hackage ( updateHackageIndex , forceUpdateHackageIndex @@ -20,45 +21,47 @@ , HackageTarballResult(..) ) where -import RIO -import RIO.Process -import Pantry.Casa -import Data.Aeson -import Conduit -import Data.Conduit.Tar -import qualified RIO.Text as T -import qualified RIO.Map as Map -import Data.Text.Unsafe (unsafeTail) -import qualified RIO.ByteString as B -import qualified RIO.ByteString.Lazy as BL -import Pantry.Archive -import Pantry.Types hiding (FileType (..)) -import Pantry.Storage - hiding (TreeEntry, PackageName, Version, findOrGenerateCabalFile) -import Pantry.Tree -import qualified Pantry.SHA256 as SHA256 -import Network.URI (parseURI) -import Data.Time (getCurrentTime) -import Path ((</>), Path, Abs, Rel, Dir, File, toFilePath, parseRelDir, parseRelFile) -import qualified Distribution.Text -import qualified Distribution.PackageDescription as Cabal +import Conduit +import Data.Aeson +import Data.Conduit.Tar import qualified Data.List.NonEmpty as NE -import Data.Text.Metrics (damerauLevenshtein) -#if !MIN_VERSION_rio(0,1,16) --- Now provided by RIO from the rio package. Resolvers before lts-15.16 --- (GHC 8.8.3) had rio < 0.1.16. -import System.IO (SeekMode (..)) -#endif -import Distribution.PackageDescription (GenericPackageDescription) -import Distribution.Types.Version (versionNumbers) -import Distribution.Types.VersionRange (withinRange) - +import Data.Text.Metrics (damerauLevenshtein) +import Data.Text.Unsafe ( unsafeTail ) +import Data.Time ( getCurrentTime ) +import Distribution.PackageDescription ( GenericPackageDescription ) +import qualified Distribution.PackageDescription as Cabal +import qualified Distribution.Text +import Distribution.Types.Version (versionNumbers) +import Distribution.Types.VersionRange (withinRange) import qualified Hackage.Security.Client as HS import qualified Hackage.Security.Client.Repository.Cache as HS -import qualified Hackage.Security.Client.Repository.Remote as HS import qualified Hackage.Security.Client.Repository.HttpLib.HttpClient as HS +import qualified Hackage.Security.Client.Repository.Remote as HS import qualified Hackage.Security.Util.Path as HS import qualified Hackage.Security.Util.Pretty as HS +import Network.URI ( parseURI ) +import Pantry.Archive +import Pantry.Casa +import qualified Pantry.SHA256 as SHA256 +import Pantry.Storage hiding + ( PackageName, TreeEntry, Version, findOrGenerateCabalFile ) +import Pantry.Tree +import Pantry.Types hiding ( FileType (..) ) +import Path + ( Abs, Dir, File, Path, Rel, (</>), parseRelDir, parseRelFile + , toFilePath + ) +import RIO +import qualified RIO.ByteString as B +import qualified RIO.ByteString.Lazy as BL +import qualified RIO.Map as Map +import RIO.Process +import qualified RIO.Text as T +#if !MIN_VERSION_rio(0,1,16) +-- Now provided by RIO from the rio package. Resolvers before lts-15.16 +-- (GHC 8.8.3) had rio < 0.1.16. +import System.IO ( SeekMode (..) ) +#endif hackageRelDir :: Path Rel Dir hackageRelDir = either impureThrow id $ parseRelDir "hackage" @@ -86,16 +89,17 @@ -- @since 0.1.0.0 data HackageTarballResult = HackageTarballResult { htrPackage :: !Package - -- ^ Package that was loaded from Hackage tarball + -- ^ Package that was loaded from Hackage tarball , htrFreshPackageInfo :: !(Maybe (GenericPackageDescription, TreeId)) - -- ^ This information is only available whenever package was just loaded into pantry. + -- ^ This information is only available whenever package was just loaded + -- into pantry. } --- | Download the most recent 01-index.tar file from Hackage and --- update the database tables. +-- | Download the most recent 01-index.tar file from Hackage and update the +-- database tables. -- --- This function will only perform an update once per 'PantryConfig' --- for user sanity. See the return value to find out if it happened. +-- This function will only perform an update once per 'PantryConfig' for user +-- sanity. See the return value to find out if it happened. -- -- @since 0.1.0.0 updateHackageIndex @@ -130,33 +134,34 @@ root <- view hackageDirL tarball <- view hackageIndexTarballL baseURI <- - case parseURI $ T.unpack url of - Nothing -> throwString $ "Invalid Hackage Security base URL: " ++ T.unpack url - Just x -> return x + case parseURI $ T.unpack url of + Nothing -> + throwString $ "Invalid Hackage Security base URL: " ++ T.unpack url + Just x -> pure x run <- askRunInIO let logTUF = run . logInfo . fromString . HS.pretty withRepo = HS.withRepository - HS.httpLib - [baseURI] - HS.defaultRepoOpts - HS.Cache - { HS.cacheRoot = HS.fromAbsoluteFilePath $ toFilePath root - , HS.cacheLayout = HS.cabalCacheLayout - } - HS.hackageRepoLayout - HS.hackageIndexLayout - logTUF + HS.httpLib + [baseURI] + HS.defaultRepoOpts + HS.Cache + { HS.cacheRoot = HS.fromAbsoluteFilePath $ toFilePath root + , HS.cacheLayout = HS.cabalCacheLayout + } + HS.hackageRepoLayout + HS.hackageIndexLayout + logTUF didUpdate <- liftIO $ withRepo $ \repo -> HS.uncheckClientErrors $ do - needBootstrap <- HS.requiresBootstrap repo - when needBootstrap $ do - HS.bootstrap - repo - (map (HS.KeyId . T.unpack) keyIds) - (HS.KeyThreshold $ fromIntegral threshold) - maybeNow <- if ignoreExpiry - then pure Nothing - else Just <$> getCurrentTime - HS.checkForUpdates repo maybeNow + needBootstrap <- HS.requiresBootstrap repo + when needBootstrap $ do + HS.bootstrap + repo + (map (HS.KeyId . T.unpack) keyIds) + (HS.KeyThreshold $ fromIntegral threshold) + maybeNow <- if ignoreExpiry + then pure Nothing + else Just <$> getCurrentTime + HS.checkForUpdates repo maybeNow case didUpdate of _ | forceUpdate -> do @@ -173,101 +178,103 @@ logInfo "Updated package index downloaded" updateCache tarball logStickyDone "Package index cache populated" - where - -- The size of the new index tarball, ignoring the required - -- (by the tar spec) 1024 null bytes at the end, which will be - -- mutated in the future by other updates. - getTarballSize :: MonadIO m => Handle -> m Word - getTarballSize h = (fromIntegral . max 0 . subtract 1024) <$> hFileSize h + where + -- The size of the new index tarball, ignoring the required (by the tar spec) + -- 1024 null bytes at the end, which will be mutated in the future by other + -- updates. + getTarballSize :: MonadIO m => Handle -> m Word + getTarballSize h = fromIntegral . max 0 . subtract 1024 <$> hFileSize h - -- Check if the size of the tarball on the disk matches the value - -- in CacheUpdate. If not, we need to perform a cache update, even - -- if we didn't download any new information. This can be caused - -- by canceling an updateCache call. - needsCacheUpdate tarball = do - mres <- withStorage loadLatestCacheUpdate - case mres of - Nothing -> pure True - Just (FileSize cachedSize, _sha256) -> do - actualSize <- withBinaryFile (toFilePath tarball) ReadMode getTarballSize - pure $ cachedSize /= actualSize + -- Check if the size of the tarball on the disk matches the value in + -- CacheUpdate. If not, we need to perform a cache update, even if we didn't + -- download any new information. This can be caused by canceling an + -- updateCache call. + needsCacheUpdate tarball = do + mres <- withStorage loadLatestCacheUpdate + case mres of + Nothing -> pure True + Just (FileSize cachedSize, _sha256) -> do + actualSize <- withBinaryFile (toFilePath tarball) ReadMode getTarballSize + pure $ cachedSize /= actualSize - -- This is the one action in the Pantry codebase known to hold a - -- write lock on the database for an extended period of time. To - -- avoid failures due to SQLite locks failing, we take our own - -- lock outside of SQLite for this action. + -- This is the one action in the Pantry codebase known to hold a write lock on + -- the database for an extended period of time. To avoid failures due to + -- SQLite locks failing, we take our own lock outside of SQLite for this + -- action. + -- + -- See https://github.com/commercialhaskell/stack/issues/4471 + updateCache tarball = withStorage $ do + -- Alright, here's the story. In theory, we only ever append to a tarball. + -- Therefore, we can store the last place we populated our cache from, and + -- fast forward to that point. But there are two issues with that: -- - -- See https://github.com/commercialhaskell/stack/issues/4471 - updateCache tarball = withStorage $ do - -- Alright, here's the story. In theory, we only ever append to - -- a tarball. Therefore, we can store the last place we - -- populated our cache from, and fast forward to that point. But - -- there are two issues with that: - -- - -- 1. Hackage may rebase, in which case we need to recalculate - -- everything from the beginning. Unfortunately, - -- hackage-security doesn't let us know when that happens. - -- - -- 2. Some paranoia about files on the filesystem getting - -- modified out from under us. - -- - -- Therefore, we store both the last read-to index, _and_ the - -- SHA256 of all of the contents until that point. When updating - -- the cache, we calculate the new SHA256 of the whole file, and - -- the SHA256 of the previous read-to point. If the old hashes - -- match, we can do an efficient fast forward. Otherwise, we - -- clear the old cache and repopulate. - minfo <- loadLatestCacheUpdate - (offset, newHash, newSize) <- lift $ withBinaryFile (toFilePath tarball) ReadMode $ \h -> do - logInfo "Calculating hashes to check for hackage-security rebases or filesystem changes" + -- 1. Hackage may rebase, in which case we need to recalculate everything + -- from the beginning. Unfortunately, hackage-security doesn't let us know + -- when that happens. + -- + -- 2. Some paranoia about files on the filesystem getting modified out from + -- under us. + -- + -- Therefore, we store both the last read-to index, _and_ the SHA256 of all + -- of the contents until that point. When updating the cache, we calculate + -- the new SHA256 of the whole file, and the SHA256 of the previous read-to + -- point. If the old hashes match, we can do an efficient fast forward. + -- Otherwise, we clear the old cache and repopulate. + minfo <- loadLatestCacheUpdate + (offset, newHash, newSize) <- lift $ withBinaryFile (toFilePath tarball) ReadMode $ \h -> do + logInfo "Calculating hashes to check for hackage-security rebases or filesystem changes" - newSize <- getTarballSize h - let sinkSHA256 len = takeCE (fromIntegral len) .| SHA256.sinkHash + newSize <- getTarballSize h + let sinkSHA256 len = takeCE (fromIntegral len) .| SHA256.sinkHash - case minfo of - Nothing -> do - logInfo "No old cache found, populating cache from scratch" - newHash <- runConduit $ sourceHandle h .| sinkSHA256 newSize - pure (0, newHash, newSize) - Just (FileSize oldSize, oldHash) -> do - -- oldSize and oldHash come from the database, and tell - -- us what we cached already. Compare against - -- oldHashCheck, which assuming the tarball has not been - -- rebased will be the same as oldHash. At the same - -- time, calculate newHash, which is the hash of the new - -- content as well. - (oldHashCheck, newHash) <- runConduit $ sourceHandle h .| getZipSink ((,) - <$> ZipSink (sinkSHA256 oldSize) - <*> ZipSink (sinkSHA256 newSize) - ) - offset <- - if oldHash == oldHashCheck - then oldSize <$ logInfo "Updating preexisting cache, should be quick" - else 0 <$ do - logWarn $ mconcat [ - "Package index change detected, that's pretty unusual: " - , "\n Old size: " <> display oldSize - , "\n Old hash (orig) : " <> display oldHash - , "\n New hash (check): " <> display oldHashCheck - , "\n Forcing a recache" - ] - pure (offset, newHash, newSize) + case minfo of + Nothing -> do + logInfo "No old cache found, populating cache from scratch" + newHash <- runConduit $ sourceHandle h .| sinkSHA256 newSize + pure (0, newHash, newSize) + Just (FileSize oldSize, oldHash) -> do + -- oldSize and oldHash come from the database, and tell + -- us what we cached already. Compare against + -- oldHashCheck, which assuming the tarball has not been + -- rebased will be the same as oldHash. At the same + -- time, calculate newHash, which is the hash of the new + -- content as well. + (oldHashCheck, newHash) <- runConduit $ sourceHandle h .| getZipSink ((,) + <$> ZipSink (sinkSHA256 oldSize) + <*> ZipSink (sinkSHA256 newSize) + ) + offset <- + if oldHash == oldHashCheck + then oldSize <$ logInfo "Updating preexisting cache, should be quick" + else 0 <$ do + logWarn $ mconcat [ + "Package index change detected, that's pretty unusual: " + , "\n Old size: " <> display oldSize + , "\n Old hash (orig) : " <> display oldHash + , "\n New hash (check): " <> display oldHashCheck + , "\n Forcing a recache" + ] + pure (offset, newHash, newSize) - lift $ logInfo $ "Populating cache from file size " <> display newSize <> ", hash " <> display newHash - when (offset == 0) clearHackageRevisions - populateCache tarball (fromIntegral offset) `onException` - lift (logStickyDone "Failed populating package index cache") - storeCacheUpdate (FileSize newSize) newHash - gateUpdate inner = do - pc <- view pantryConfigL - join $ modifyMVar (pcUpdateRef pc) $ \toUpdate -> pure $ - if toUpdate - then (False, UpdateOccurred <$ inner) - else (False, pure NoUpdateOccurred) + lift $ logInfo $ + "Populating cache from file size " + <> display newSize + <> ", hash " + <> display newHash + when (offset == 0) clearHackageRevisions + populateCache tarball (fromIntegral offset) `onException` + lift (logStickyDone "Failed populating package index cache") + storeCacheUpdate (FileSize newSize) newHash + gateUpdate inner = do + pc <- view pantryConfigL + join $ modifyMVar (pcUpdateRef pc) $ \toUpdate -> pure $ + if toUpdate + then (False, UpdateOccurred <$ inner) + else (False, pure NoUpdateOccurred) -- | Populate the SQLite tables with Hackage index information. -populateCache - :: (HasPantryConfig env, HasLogFunc env) +populateCache :: + (HasPantryConfig env, HasLogFunc env) => Path Abs File -- ^ tarball -> Integer -- ^ where to start processing from -> ReaderT SqlBackend (RIO env) () @@ -276,84 +283,83 @@ counter <- newIORef (0 :: Int) hSeek h AbsoluteSeek offset runConduit $ sourceHandle h .| untar (perFile counter) - where - - perFile counter fi - | FTNormal <- fileType fi - , Right path <- decodeUtf8' $ filePath fi - , Just (name, version, filename) <- parseNameVersionSuffix path = - if - | filename == "package.json" -> - sinkLazy >>= lift . addJSON name version - | filename == unSafeFilePath (cabalFileName name) -> do - (BL.toStrict <$> sinkLazy) >>= lift . addCabal name version - - count <- readIORef counter - let count' = count + 1 - writeIORef counter count' - when (count' `mod` 400 == 0) $ - lift $ lift $ - logSticky $ "Processed " <> display count' <> " cabal files" - | otherwise -> pure () - | FTNormal <- fileType fi - , Right path <- decodeUtf8' $ filePath fi - , (nameT, "/preferred-versions") <- T.break (== '/') path - , Just name <- parsePackageName $ T.unpack nameT = do - lbs <- sinkLazy - case decodeUtf8' $ BL.toStrict lbs of - Left _ -> pure () -- maybe warning - Right p -> lift $ storePreferredVersion name p - | otherwise = pure () + where + perFile counter fi + | FTNormal <- fileType fi + , Right path <- decodeUtf8' $ filePath fi + , Just (name, version, filename) <- parseNameVersionSuffix path = + if + | filename == "package.json" -> + sinkLazy >>= lift . addJSON name version + | filename == unSafeFilePath (cabalFileName name) -> do + sinkLazy >>= (lift . addCabal name version) . BL.toStrict + count <- readIORef counter + let count' = count + 1 + writeIORef counter count' + when (count' `mod` 400 == 0) $ + lift $ lift $ + logSticky $ "Processed " <> display count' <> " cabal files" + | otherwise -> pure () + | FTNormal <- fileType fi + , Right path <- decodeUtf8' $ filePath fi + , (nameT, "/preferred-versions") <- T.break (== '/') path + , Just name <- parsePackageName $ T.unpack nameT = do + lbs <- sinkLazy + case decodeUtf8' $ BL.toStrict lbs of + Left _ -> pure () -- maybe warning + Right p -> lift $ storePreferredVersion name p + | otherwise = pure () - addJSON name version lbs = - case eitherDecode' lbs of - Left e -> lift $ logError $ - "Error: [S-563]\n" - <> "Error processing Hackage security metadata for " - <> fromString (Distribution.Text.display name) <> "-" - <> fromString (Distribution.Text.display version) <> ": " - <> fromString e - Right (PackageDownload sha size) -> - storeHackageTarballInfo name version sha $ FileSize size + addJSON name version lbs = + case eitherDecode' lbs of + Left e -> lift $ logError $ + "Error: [S-563]\n" + <> "Error processing Hackage security metadata for " + <> fromString (Distribution.Text.display name) <> "-" + <> fromString (Distribution.Text.display version) <> ": " + <> fromString e + Right (PackageDownload sha size) -> + storeHackageTarballInfo name version sha $ FileSize size - addCabal name version bs = do - (blobTableId, _blobKey) <- storeBlob bs + addCabal name version bs = do + (blobTableId, _blobKey) <- storeBlob bs - storeHackageRevision name version blobTableId + storeHackageRevision name version blobTableId - breakSlash x - | T.null z = Nothing - | otherwise = Just (y, unsafeTail z) - where - (y, z) = T.break (== '/') x + breakSlash x + | T.null z = Nothing + | otherwise = Just (y, unsafeTail z) + where + (y, z) = T.break (== '/') x - parseNameVersionSuffix t1 = do - (name, t2) <- breakSlash t1 - (version, filename) <- breakSlash t2 + parseNameVersionSuffix t1 = do + (name, t2) <- breakSlash t1 + (version, filename) <- breakSlash t2 - name' <- Distribution.Text.simpleParse $ T.unpack name - version' <- Distribution.Text.simpleParse $ T.unpack version + name' <- Distribution.Text.simpleParse $ T.unpack name + version' <- Distribution.Text.simpleParse $ T.unpack version - Just (name', version', filename) + Just (name', version', filename) -- | Package download info from Hackage data PackageDownload = PackageDownload !SHA256 !Word + instance FromJSON PackageDownload where - parseJSON = withObject "PackageDownload" $ \o1 -> do - o2 <- o1 .: "signed" - Object o3 <- o2 .: "targets" - Object o4:_ <- return $ toList o3 - len <- o4 .: "length" - hashes <- o4 .: "hashes" - sha256' <- hashes .: "sha256" - sha256 <- - case SHA256.fromHexText sha256' of - Left e -> fail $ "Invalid sha256: " ++ show e - Right x -> return x - return $ PackageDownload sha256 len + parseJSON = withObject "PackageDownload" $ \o1 -> do + o2 <- o1 .: "signed" + Object o3 <- o2 .: "targets" + Object o4:_ <- pure $ toList o3 + len <- o4 .: "length" + hashes <- o4 .: "hashes" + sha256' <- hashes .: "sha256" + sha256 <- + case SHA256.fromHexText sha256' of + Left e -> fail $ "Invalid sha256: " ++ show e + Right x -> pure x + pure $ PackageDownload sha256 len -getHackageCabalFile - :: (HasPantryConfig env, HasLogFunc env) +getHackageCabalFile :: + (HasPantryConfig env, HasLogFunc env) => PackageIdentifierRevision -> RIO env ByteString getHackageCabalFile pir@(PackageIdentifierRevision _ _ cfi) = do @@ -371,8 +377,8 @@ _ -> pure () pure bs -resolveCabalFileInfo - :: (HasPantryConfig env, HasLogFunc env) +resolveCabalFileInfo :: + (HasPantryConfig env, HasLogFunc env) => PackageIdentifierRevision -> RIO env BlobId resolveCabalFileInfo pir@(PackageIdentifierRevision name ver cfi) = do @@ -380,7 +386,10 @@ case mres of Just res -> pure res Nothing -> do - updated <- updateHackageIndex $ Just $ "Cabal file info not found for " <> display pir <> ", updating" + updated <- updateHackageIndex $ Just + $ "Cabal file info not found for " + <> display pir + <> ", updating" mres' <- case updated of UpdateOccurred -> inner @@ -388,12 +397,14 @@ case mres' of Nothing -> fuzzyLookupCandidates name ver >>= throwIO . UnknownHackagePackage pir Just res -> pure res - where - inner = - case cfi of - CFIHash sha msize -> loadOrDownloadBlobBySHA pir sha msize - CFIRevision rev -> (fmap fst . Map.lookup rev) <$> withStorage (loadHackagePackageVersion name ver) - CFILatest -> (fmap (fst . fst) . Map.maxView) <$> withStorage (loadHackagePackageVersion name ver) + where + inner = + case cfi of + CFIHash sha msize -> loadOrDownloadBlobBySHA pir sha msize + CFIRevision rev -> + fmap fst . Map.lookup rev <$> withStorage (loadHackagePackageVersion name ver) + CFILatest -> + fmap (fst . fst) . Map.maxView <$> withStorage (loadHackagePackageVersion name ver) -- | Load or download a blob by its SHA. loadOrDownloadBlobBySHA :: @@ -428,14 +439,14 @@ Just blobId -> do logDebug ("Got blob from Pantry database for " <> display label) pure (Just blobId) - where - byDB = withStorage $ loadBlobBySHA sha256 + where + byDB = withStorage $ loadBlobBySHA sha256 --- | Given package identifier and package caches, return list of packages --- with the same name and the same two first version number components found --- in the caches. -fuzzyLookupCandidates - :: (HasPantryConfig env, HasLogFunc env) +-- | Given package identifier and package caches, return list of packages with +-- the same name and the same two first version number components found in the +-- caches. +fuzzyLookupCandidates :: + (HasPantryConfig env, HasLogFunc env) => PackageName -> Version -> RIO env FuzzyResults @@ -449,7 +460,8 @@ let withVers vers = pure $ FRVersionNotFound $ flip NE.map vers $ \(ver, revs) -> case Map.maxView revs of Nothing -> error "fuzzyLookupCandidates: no revisions" - Just (BlobKey sha size, _) -> PackageIdentifierRevision name ver (CFIHash sha (Just size)) + Just (BlobKey sha size, _) -> + PackageIdentifierRevision name ver (CFIHash sha (Just size)) case NE.nonEmpty $ filter (sameMajor . fst) $ Map.toList m of Just vers -> withVers vers Nothing -> @@ -458,13 +470,14 @@ Just vers -> withVers vers Just revisions -> let pirs = map - (\(BlobKey sha size) -> PackageIdentifierRevision name ver0 (CFIHash sha (Just size))) + (\(BlobKey sha size) -> + PackageIdentifierRevision name ver0 (CFIHash sha (Just size))) (Map.elems revisions) in case NE.nonEmpty pirs of Nothing -> error "fuzzyLookupCandidates: no revisions" Just pirs' -> pure $ FRRevisionNotFound pirs' - where - sameMajor v = toMajorVersion v == toMajorVersion ver0 + where + sameMajor v = toMajorVersion v == toMajorVersion ver0 toMajorVersion :: Version -> [Int] toMajorVersion v = @@ -473,26 +486,28 @@ [a] -> [a, 0] a:b:_ -> [a, b] --- | Try to come up with typo corrections for given package identifier --- using Hackage package names. This can provide more user-friendly --- information in error messages. +-- | Try to come up with typo corrections for given package identifier using +-- Hackage package names. This can provide more user-friendly information in +-- error messages. -- -- @since 0.1.0.0 -getHackageTypoCorrections - :: (HasPantryConfig env, HasLogFunc env) +getHackageTypoCorrections :: + (HasPantryConfig env, HasLogFunc env) => PackageName -> RIO env [PackageName] getHackageTypoCorrections name1 = - withStorage $ sinkHackagePackageNames - (\name2 -> name1 `distance` name2 < 4) - (takeC 10 .| sinkList) - where - distance = damerauLevenshtein `on` (T.pack . packageNameString) + withStorage $ sinkHackagePackageNames + (\name2 -> name1 `distance` name2 < 4) + (takeC 10 .| sinkList) + where + distance = damerauLevenshtein `on` (T.pack . packageNameString) -- | Should we pay attention to Hackage's preferred versions? -- -- @since 0.1.0.0 -data UsePreferredVersions = UsePreferredVersions | IgnorePreferredVersions +data UsePreferredVersions + = UsePreferredVersions + | IgnorePreferredVersions deriving Show -- | Require that the Hackage index is populated. @@ -505,21 +520,21 @@ -- ^ Do not perform an update deriving Show -initializeIndex - :: (HasPantryConfig env, HasLogFunc env) +initializeIndex :: + (HasPantryConfig env, HasLogFunc env) => RequireHackageIndex -> RIO env () initializeIndex NoRequireHackageIndex = pure () initializeIndex YesRequireHackageIndex = do cabalCount <- withStorage countHackageCabals when (cabalCount == 0) $ void $ - updateHackageIndex $ Just $ "No information from Hackage index, updating" + updateHackageIndex $ Just "No information from Hackage index, updating" -- | Returns the versions of the package available on Hackage. -- -- @since 0.1.0.0 -getHackagePackageVersions - :: (HasPantryConfig env, HasLogFunc env) +getHackagePackageVersions :: + (HasPantryConfig env, HasLogFunc env) => RequireHackageIndex -> UsePreferredVersions -> PackageName -- ^ package name @@ -542,8 +557,8 @@ -- | Returns the versions of the package available on Hackage. -- -- @since 0.1.0.0 -getHackagePackageVersionRevisions - :: (HasPantryConfig env, HasLogFunc env) +getHackagePackageVersionRevisions :: + (HasPantryConfig env, HasLogFunc env) => RequireHackageIndex -> PackageName -- ^ package name -> Version -- ^ package version @@ -553,8 +568,8 @@ withStorage $ Map.map snd <$> loadHackagePackageVersion name version -withCachedTree - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) +withCachedTree :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawPackageLocationImmutable -> PackageName -> Version @@ -571,8 +586,8 @@ storeHackageTree name ver bid $ packageTreeKey $ htrPackage htr pure htr -getHackageTarballKey - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) +getHackageTarballKey :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => PackageIdentifierRevision -> RIO env TreeKey getHackageTarballKey pir@(PackageIdentifierRevision name ver (CFIHash sha _msize)) = do @@ -580,10 +595,11 @@ case mres of Nothing -> packageTreeKey . htrPackage <$> getHackageTarball pir Nothing Just key -> pure key -getHackageTarballKey pir = packageTreeKey . htrPackage <$> getHackageTarball pir Nothing +getHackageTarballKey pir = + packageTreeKey . htrPackage <$> getHackageTarball pir Nothing -getHackageTarball - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) +getHackageTarball :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => PackageIdentifierRevision -> Maybe TreeKey -> RIO env HackageTarballResult @@ -630,7 +646,8 @@ RawPackageMetadata { rpmName = Just name , rpmVersion = Just ver - , rpmTreeKey = Nothing -- with a revision cabal file will differ giving a different tree + , rpmTreeKey = Nothing -- with a revision cabal file will differ + -- giving a different tree } case cachedTree of CachedTreeMap m -> do @@ -648,7 +665,8 @@ error $ "Invariant violated, cabal file key: " ++ show cabalFileKey Just bid -> (, bid) <$> loadBlobById bid - let tree' = CachedTreeMap $ Map.insert (cabalFileName name) (cabalEntry, cabalBlobId) m + let tree' = CachedTreeMap $ + Map.insert (cabalFileName name) (cabalEntry, cabalBlobId) m ident = PackageIdentifier name ver (_warnings, gpd) <- rawParseGPD (Left rpli) cabalBS let gpdIdent = Cabal.package $ Cabal.packageDescription gpd
src/Pantry/Internal.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} + -- | Exposed for testing, do not use! module Pantry.Internal ( parseTree @@ -17,12 +18,12 @@ , withStorage_ ) where -import Control.Exception (assert) -import Pantry.Types -import Pantry.SQLite (initStorage) -import Pantry.HPack (hpackVersion) +import Control.Exception ( assert ) +import Data.Maybe ( fromMaybe ) import qualified Data.Text as T -import Data.Maybe (fromMaybe) +import Pantry.HPack ( hpackVersion ) +import Pantry.SQLite ( initStorage ) +import Pantry.Types -- | Like @System.FilePath.normalise@, however: -- @@ -37,8 +38,8 @@ -- * Cannot begin with a parent directory (@../@) -- -- * Spelled like an American, sorry -normalizeParents - :: FilePath +normalizeParents :: + FilePath -> Either String FilePath normalizeParents "" = Left "empty file path" normalizeParents ('/':_) = Left "absolute path" @@ -67,10 +68,10 @@ [] -> Left "no non-empty components" c' -> Right $ T.unpack $ T.intercalate "/" c' --- | Following tar file rules (Unix file paths only), make the second --- file relative to the first file. -makeTarRelative - :: FilePath -- ^ base file +-- | Following tar file rules (Unix file paths only), make the second file +-- relative to the first file. +makeTarRelative :: + FilePath -- ^ base file -> FilePath -- ^ relative part -> Either String FilePath makeTarRelative _ ('/':_) = Left "absolute path found"
src/Pantry/Internal/AesonExtended.hs view
@@ -1,19 +1,19 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TupleSections #-} --- | Extensions to Aeson parsing of objects. This module is intended --- for internal use by Pantry and Stack only. The intention is to --- fully remove this module in the future. /DO NOT RELY ON IT/. -module Pantry.Internal.AesonExtended ( - module Export - -- * Extended failure messages +-- | Extensions to Aeson parsing of objects. This module is intended for +-- internal use by Pantry and Stack only. The intention is to fully remove this +-- module in the future. /DO NOT RELY ON IT/. +module Pantry.Internal.AesonExtended + ( module Export + -- * Extended failure messages , (.:) , (.:?) - -- * JSON Parser that emits warnings + -- * JSON Parser that emits warnings , JSONWarning (..) , WarningParser , WithJSONWarnings (..) @@ -32,16 +32,17 @@ , (..!=) ) where -import Control.Monad.Trans.Writer.Strict (WriterT, mapWriterT, runWriterT, tell) -import Data.Aeson as Export hiding ((.:), (.:?)) +import Control.Monad.Trans.Writer.Strict + ( WriterT, mapWriterT, runWriterT, tell ) +import Data.Aeson as Export hiding ( (.:), (.:?) ) import qualified Data.Aeson as A -import Data.Aeson.Types hiding ((.:), (.:?)) +import Data.Aeson.Types hiding ( (.:), (.:?) ) import qualified Data.Set as Set -import Data.Text (unpack) +import Data.Text ( unpack ) import qualified Data.Text as T -import Generics.Deriving.Monoid (mappenddefault, memptydefault) -import RIO -import RIO.PrettyPrint.StylesUpdate (StylesUpdate) +import Generics.Deriving.Monoid ( mappenddefault, memptydefault ) +import RIO +import RIO.PrettyPrint.StylesUpdate ( StylesUpdate ) #if MIN_VERSION_aeson(2, 0, 0) import qualified Data.Aeson.Key @@ -64,128 +65,145 @@ -- | Extends @.:@ warning to include field name. (.:) :: FromJSON a => Object -> Text -> Parser a -(.:) o p = modifyFailure (("failed to parse field '" <> unpack p <> "': ") <>) (o A..: textToKey p) +(.:) o p = modifyFailure + (("failed to parse field '" <> unpack p <> "': ") <>) + (o A..: textToKey p) {-# INLINE (.:) #-} -- | Extends @.:?@ warning to include field name. (.:?) :: FromJSON a => Object -> Text -> Parser (Maybe a) -(.:?) o p = modifyFailure (("failed to parse field '" <> unpack p <> "': ") <>) (o A..:? textToKey p) +(.:?) o p = modifyFailure + (("failed to parse field '" <> unpack p <> "': ") <>) + (o A..:? textToKey p) {-# INLINE (.:?) #-} -- | 'WarningParser' version of @.:@. -(..:) - :: FromJSON a - => Object -> Text -> WarningParser a +(..:) :: + FromJSON a + => Object + -> Text + -> WarningParser a o ..: k = tellJSONField k >> lift (o .: k) -- | 'WarningParser' version of @.:?@. -(..:?) - :: FromJSON a - => Object -> Text -> WarningParser (Maybe a) +(..:?) :: + FromJSON a + => Object + -> Text + -> WarningParser (Maybe a) o ..:? k = tellJSONField k >> lift (o .:? k) -- | 'WarningParser' version of @.!=@. (..!=) :: WarningParser (Maybe a) -> a -> WarningParser a wp ..!= d = - flip mapWriterT wp $ - \p -> - do a <- fmap snd p - fmap (, a) (fmap fst p .!= d) + flip mapWriterT wp $ + \p -> do + a <- fmap snd p + fmap (, a) (fmap fst p .!= d) presentCount :: Object -> [Text] -> Int -presentCount o ss = length . filter (\x -> HashMap.member (textToKey x) o) $ ss +presentCount o = length . filter (\x -> HashMap.member (textToKey x) o) -- | Synonym version of @..:@. (...:) :: FromJSON a => Object -> [Text] -> WarningParser a _ ...: [] = fail "failed to find an empty key" o ...: ss@(key:_) = apply - where pc = presentCount o ss - apply | pc == 0 = fail $ - "failed to parse field " ++ - show key ++ ": " ++ - "keys " ++ show ss ++ " not present" - | pc > 1 = fail $ - "failed to parse field " ++ - show key ++ ": " ++ - "two or more synonym keys " ++ - show ss ++ " present" - | otherwise = asum $ map (o..:) ss + where + pc = presentCount o ss + apply | pc == 0 = fail $ + "failed to parse field " ++ + show key ++ ": " ++ + "keys " ++ show ss ++ " not present" + | pc > 1 = fail $ + "failed to parse field " ++ + show key ++ ": " ++ + "two or more synonym keys " ++ + show ss ++ " present" + | otherwise = asum $ map (o..:) ss -- | Synonym version of @..:?@. (...:?) :: FromJSON a => Object -> [Text] -> WarningParser (Maybe a) _ ...:? [] = fail "failed to find an empty key" o ...:? ss@(key:_) = apply - where pc = presentCount o ss - apply | pc == 0 = return Nothing - | pc > 1 = fail $ - "failed to parse field " ++ - show key ++ ": " ++ - "two or more synonym keys " ++ - show ss ++ " present" - | otherwise = asum $ map (o..:) ss + where + pc = presentCount o ss + apply | pc == 0 = pure Nothing + | pc > 1 = fail $ + "failed to parse field " ++ + show key ++ ": " ++ + "two or more synonym keys " ++ + show ss ++ " present" + | otherwise = asum $ map (o..:) ss -- | Tell warning parser about an expected field, so it doesn't warn about it. tellJSONField :: Text -> WarningParser () tellJSONField key = tell (mempty { wpmExpectedFields = Set.singleton key}) -- | 'WarningParser' version of 'withObject'. -withObjectWarnings :: String - -> (Object -> WarningParser a) - -> Value - -> Parser (WithJSONWarnings a) +withObjectWarnings :: + String + -> (Object -> WarningParser a) + -> Value + -> Parser (WithJSONWarnings a) withObjectWarnings expected f = - withObject expected $ - \obj -> - do (a,w) <- runWriterT (f obj) - let unrecognizedFields = - Set.toList - (Set.difference - (Set.fromList (map keyToText (HashMap.keys obj))) - (wpmExpectedFields w)) - return - (WithJSONWarnings a - (wpmWarnings w ++ - case unrecognizedFields of - [] -> [] - _ -> [JSONUnrecognizedFields expected unrecognizedFields])) + withObject expected $ + \obj -> do + (a,w) <- runWriterT (f obj) + let unrecognizedFields = + Set.toList + ( Set.difference + (Set.fromList (map keyToText (HashMap.keys obj))) + (wpmExpectedFields w) + ) + pure + ( WithJSONWarnings a + ( wpmWarnings w ++ + case unrecognizedFields of + [] -> [] + _ -> [JSONUnrecognizedFields expected unrecognizedFields] + ) + ) -- | Convert a 'WarningParser' to a 'Parser'. unWarningParser :: WarningParser a -> Parser a unWarningParser wp = do - (a,_) <- runWriterT wp - return a + (a,_) <- runWriterT wp + pure a -- | Log JSON warnings. -logJSONWarnings - :: (MonadReader env m, HasLogFunc env, HasCallStack, MonadIO m) - => FilePath -> [JSONWarning] -> m () +logJSONWarnings :: + (MonadReader env m, HasLogFunc env, HasCallStack, MonadIO m) + => FilePath + -> [JSONWarning] + -> m () logJSONWarnings fp = - mapM_ (\w -> logWarn ("Warning: " <> fromString fp <> ": " <> displayShow w)) + mapM_ (\w -> logWarn ("Warning: " <> fromString fp <> ": " <> displayShow w)) -- | Handle warnings in a sub-object. jsonSubWarnings :: WarningParser (WithJSONWarnings a) -> WarningParser a jsonSubWarnings f = do - WithJSONWarnings result warnings <- f - tell - (mempty - { wpmWarnings = warnings - }) - return result + WithJSONWarnings result warnings <- f + tell + ( mempty + { wpmWarnings = warnings + } + ) + pure result -- | Handle warnings in a @Traversable@ of sub-objects. -jsonSubWarningsT - :: Traversable t - => WarningParser (t (WithJSONWarnings a)) -> WarningParser (t a) +jsonSubWarningsT :: + Traversable t + => WarningParser (t (WithJSONWarnings a)) -> WarningParser (t a) jsonSubWarningsT f = - mapM (jsonSubWarnings . return) =<< f + mapM (jsonSubWarnings . pure) =<< f -- | Handle warnings in a @Maybe Traversable@ of sub-objects. -jsonSubWarningsTT - :: (Traversable t, Traversable u) - => WarningParser (u (t (WithJSONWarnings a))) - -> WarningParser (u (t a)) +jsonSubWarningsTT :: + (Traversable t, Traversable u) + => WarningParser (u (t (WithJSONWarnings a))) + -> WarningParser (u (t a)) jsonSubWarningsTT f = - mapM (jsonSubWarningsT . return) =<< f + mapM (jsonSubWarningsT . pure) =<< f -- Parsed JSON value without any warnings noJSONWarnings :: a -> WithJSONWarnings a @@ -196,39 +214,51 @@ -- | Monoid used by 'WarningParser' to track expected fields and warnings. data WarningParserMonoid = WarningParserMonoid - { wpmExpectedFields :: !(Set Text) - , wpmWarnings :: [JSONWarning] - } deriving Generic + { wpmExpectedFields :: !(Set Text) + , wpmWarnings :: [JSONWarning] + } deriving Generic + instance Semigroup WarningParserMonoid where - (<>) = mappenddefault + (<>) = mappenddefault + instance Monoid WarningParserMonoid where - mempty = memptydefault - mappend = (<>) + mempty = memptydefault + mappend = (<>) + instance IsString WarningParserMonoid where - fromString s = mempty { wpmWarnings = [fromString s] } + fromString s = mempty { wpmWarnings = [fromString s] } -- Parsed JSON value with its warnings data WithJSONWarnings a = WithJSONWarnings a [JSONWarning] - deriving (Eq, Generic, Show) + deriving (Eq, Generic, Show) + instance Functor WithJSONWarnings where - fmap f (WithJSONWarnings x w) = WithJSONWarnings (f x) w + fmap f (WithJSONWarnings x w) = WithJSONWarnings (f x) w + instance Monoid a => Semigroup (WithJSONWarnings a) where - (<>) = mappenddefault + (<>) = mappenddefault + instance Monoid a => Monoid (WithJSONWarnings a) where - mempty = memptydefault - mappend = (<>) + mempty = memptydefault + mappend = (<>) -- | Warning output from 'WarningParser'. -data JSONWarning = JSONUnrecognizedFields String [Text] - | JSONGeneralWarning !Text - deriving Eq +data JSONWarning + = JSONUnrecognizedFields String [Text] + | JSONGeneralWarning !Text + deriving Eq + instance Show JSONWarning where show = T.unpack . utf8BuilderToText . display + instance Display JSONWarning where display (JSONUnrecognizedFields obj [field]) = "Unrecognized field in " <> fromString obj <> ": " <> display field display (JSONUnrecognizedFields obj fields) = - "Unrecognized fields in " <> fromString obj <> ": " <> display (T.intercalate ", " fields) + "Unrecognized fields in " + <> fromString obj + <> ": " + <> display (T.intercalate ", " fields) display (JSONGeneralWarning t) = display t instance IsString JSONWarning where
src/Pantry/Internal/Companion.hs view
@@ -1,9 +1,9 @@-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE NoImplicitPrelude #-} --- | Companion threads, such as for printing messages saying we're --- still busy. Ultimately this could be put into its own package. This --- is a non-standard API for use by Pantry and Stack, please /DO NOT --- DEPEND ON IT/. +{-# LANGUAGE RankNTypes #-} + +-- | Companion threads, such as for printing messages saying we're still busy. +-- Ultimately this could be put into its own package. This is a non-standard API +-- for use by Pantry and Stack, please /DO NOT DEPEND ON IT/. module Pantry.Internal.Companion ( withCompanion , onCompanionDone @@ -12,23 +12,23 @@ , StopCompanion ) where -import RIO +import RIO -- | A companion thread which can perform arbitrary actions as well as delay type Companion m = Delay -> m () --- | Delay the given number of microseconds. If 'StopCompanion' is --- triggered before the timer completes, a 'CompanionDone' exception --- will be thrown (which is caught internally by 'withCompanion'). +-- | Delay the given number of microseconds. If 'StopCompanion' is triggered +-- before the timer completes, a 'CompanionDone' exception will be thrown (which +-- is caught internally by 'withCompanion'). type Delay = forall mio. MonadIO mio => Int -> mio () --- | Tell the 'Companion' to stop. The next time 'Delay' is --- called, or if a 'Delay' is currently blocking, the 'Companion' thread --- will exit with a 'CompanionDone' exception. +-- | Tell the 'Companion' to stop. The next time 'Delay' is called, or if a +-- 'Delay' is currently blocking, the 'Companion' thread will exit with a +-- 'CompanionDone' exception. type StopCompanion m = m () --- | When a delay was interrupted because we're told to stop, perform --- this action. +-- | When a delay was interrupted because we're told to stop, perform this +-- action. onCompanionDone :: MonadUnliftIO m => m () -- ^ the delay @@ -37,18 +37,18 @@ onCompanionDone theDelay theAction = theDelay `withException` \CompanionDone -> theAction --- | Internal exception used by 'withCompanion' to allow short-circuiting --- of the 'Companion'. Should not be used outside of this module. +-- | Internal exception used by 'withCompanion' to allow short-circuiting of the +-- 'Companion'. Should not be used outside of this module. data CompanionDone = CompanionDone deriving (Show, Typeable) + instance Exception CompanionDone --- | Keep running the 'Companion' action until either the inner action --- completes or calls the 'StopCompanion' action. This can be used to --- give the user status information while running a long running --- operations. -withCompanion - :: forall m a. MonadUnliftIO m +-- | Keep running the 'Companion' action until either the inner action completes +-- or calls the 'StopCompanion' action. This can be used to give the user status +-- information while running a long running operations. +withCompanion :: + forall m a. MonadUnliftIO m => Companion m -> (StopCompanion m -> m a) -> m a @@ -66,12 +66,14 @@ join $ atomically $ -- Delay has triggered, keep going (pure () <$ (readTVar delayDoneVar >>= checkSTM)) <|> - -- Time to stop the companion, throw a 'CompanionDone' exception immediately + -- Time to stop the companion, throw a 'CompanionDone' exception + -- immediately (throwIO CompanionDone <$ (readTVar shouldStopVar >>= checkSTM)) -- Run the 'Companion' and inner action together runConcurrently $ - -- Ignore a 'CompanionDone' exception from the companion, that's expected behavior + -- Ignore a 'CompanionDone' exception from the companion, that's expected + -- behavior Concurrently (companion delay `catch` \CompanionDone -> pure ()) *> -- Run the inner action, giving it the 'StopCompanion' action, and -- ensuring it is called regardless of exceptions.
src/Pantry/Internal/Stackage.hs view
@@ -4,47 +4,22 @@ ( module X ) where -import Pantry.Hackage as X - ( forceUpdateHackageIndex - , getHackageTarball - , HackageTarballResult(..) - ) -import Pantry.Storage as X - ( BlobId - , EntityField(..) - , HackageCabalId - , ModuleNameId - , PackageName - , PackageNameId - , Tree(..) - , TreeEntryId - , TreeId - , Unique(..) - , Version - , versionVersion - , VersionId - , getBlobKey - , getPackageNameById - , getPackageNameId - , getTreeForKey - , getVersionId - , loadBlobById - , storeBlob - , migrateAll - , Key(unBlobKey) - , allHackageCabalCount - , allBlobsSource - , allBlobsCount - , allHackageCabalRawPackageLocations - ) -import Pantry.Types as X - ( ModuleNameP(..) - , PackageNameP(..) - , PantryConfig(..) - , SafeFilePath - , Storage(..) - , VersionP(..) - , mkSafeFilePath - , packageTreeKey - , unSafeFilePath - ) +import Pantry.Hackage as X + ( HackageTarballResult (..), forceUpdateHackageIndex + , getHackageTarball + ) +import Pantry.Storage as X + ( BlobId, EntityField (..), HackageCabalId, Key (unBlobKey) + , ModuleNameId, PackageName, PackageNameId, Tree (..) + , TreeEntryId, TreeId, Unique (..), Version, VersionId + , allBlobsCount, allBlobsSource, allHackageCabalCount + , allHackageCabalRawPackageLocations, getBlobKey + , getPackageNameById, getPackageNameId, getTreeForKey + , getVersionId, loadBlobById, migrateAll, storeBlob + , versionVersion + ) +import Pantry.Types as X + ( ModuleNameP (..), PackageNameP (..), PantryConfig (..) + , SafeFilePath, Storage (..), VersionP (..), mkSafeFilePath + , packageTreeKey, unSafeFilePath + )
src/Pantry/Internal/StaticBytes.hs view
@@ -1,10 +1,11 @@-{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeOperators #-} + -- | This is an unstable API, exposed only for testing. Relying on -- this may break your code! Caveat emptor. -- @@ -26,31 +27,36 @@ , fromStatic ) where -import RIO hiding (words) +import Data.Bits +import Data.ByteArray import qualified Data.ByteString as B import qualified Data.ByteString.Internal as B +import qualified Data.Primitive.ByteArray as BA import qualified Data.Vector.Primitive as VP +import qualified Data.Vector.Storable as VS import qualified Data.Vector.Unboxed as VU import qualified Data.Vector.Unboxed.Base as VU -import qualified Data.Vector.Storable as VS -import System.IO.Unsafe (unsafePerformIO) -import Foreign.Ptr -import Foreign.ForeignPtr -import Foreign.Storable -import Data.Bits -import qualified Data.Primitive.ByteArray as BA -import Data.ByteArray +import Foreign.ForeignPtr +import Foreign.Ptr +import Foreign.Storable +import RIO hiding ( words ) +import System.IO.Unsafe ( unsafePerformIO ) newtype Bytes8 = Bytes8 Word64 deriving (Eq, Ord, Generic, NFData, Hashable, Data) + instance Show Bytes8 where show (Bytes8 w) = show (fromWordsD 8 [w] :: B.ByteString) + data Bytes16 = Bytes16 !Bytes8 !Bytes8 deriving (Show, Eq, Ord, Generic, NFData, Hashable, Data) + data Bytes32 = Bytes32 !Bytes16 !Bytes16 deriving (Show, Eq, Ord, Generic, NFData, Hashable, Data) + data Bytes64 = Bytes64 !Bytes32 !Bytes32 deriving (Show, Eq, Ord, Generic, NFData, Hashable, Data) + data Bytes128 = Bytes128 !Bytes64 !Bytes64 deriving (Show, Eq, Ord, Generic, NFData, Hashable, Data) @@ -58,44 +64,44 @@ = NotEnoughBytes | TooManyBytes deriving (Show, Eq, Typeable) + instance Exception StaticBytesException -- All lengths below are given in bytes class DynamicBytes dbytes where lengthD :: dbytes -> Int - -- | Yeah, it looks terrible to use a list here, but fusion should - -- kick in + -- | Yeah, it looks terrible to use a list here, but fusion should kick in withPeekD :: dbytes -> ((Int -> IO Word64) -> IO a) -> IO a -- | May throw a runtime exception if invariants are violated! fromWordsD :: Int -> [Word64] -> dbytes -fromWordsForeign - :: (ForeignPtr a -> Int -> b) +fromWordsForeign :: + (ForeignPtr a -> Int -> b) -> Int -> [Word64] -> b fromWordsForeign wrapper len words0 = unsafePerformIO $ do fptr <- B.mallocByteString len withForeignPtr fptr $ \ptr -> do - let loop _ [] = return () + let loop _ [] = pure () loop off (w:ws) = do pokeElemOff (castPtr ptr) off w loop (off + 1) ws loop 0 words0 - return $ wrapper fptr len + pure $ wrapper fptr len -withPeekForeign - :: (ForeignPtr a, Int, Int) +withPeekForeign :: + (ForeignPtr a, Int, Int) -> ((Int -> IO Word64) -> IO b) -> IO b withPeekForeign (fptr, off, len) inner = withForeignPtr fptr $ \ptr -> do let f off' - | off' >= len = return 0 + | off' >= len = pure 0 | off' + 8 > len = do let loop w64 i - | off' + i >= len = return w64 + | off' + i >= len = pure w64 | otherwise = do w8 :: Word8 <- peekByteOff ptr (off + off' + i) let w64' = shiftL (fromIntegral w8) (i * 8) .|. w64 @@ -106,7 +112,7 @@ instance DynamicBytes B.ByteString where lengthD = B.length - fromWordsD = fromWordsForeign (\fptr len -> B.fromForeignPtr fptr 0 len) + fromWordsD = fromWordsForeign (`B.fromForeignPtr` 0) withPeekD = withPeekForeign . B.toForeignPtr instance word8 ~ Word8 => DynamicBytes (VS.Vector word8) where @@ -126,16 +132,16 @@ loop 0 words0 withPeekD (VP.Vector off len ba) inner = do let f off' - | off' >= len = return 0 + | off' >= len = pure 0 | off' + 8 > len = do let loop w64 i - | off' + i >= len = return w64 + | off' + i >= len = pure w64 | otherwise = do let w8 :: Word8 = BA.indexByteArray ba (off + off' + i) let w64' = shiftL (fromIntegral w8) (i * 8) .|. w64 loop w64' (i + 1) loop 0 0 - | otherwise = return $ BA.indexByteArray ba (off + (off' `div` 8)) + | otherwise = pure $ BA.indexByteArray ba (off + (off' `div` 8)) inner f instance word8 ~ Word8 => DynamicBytes (VU.Vector word8) where @@ -177,15 +183,19 @@ instance ByteArrayAccess Bytes8 where length _ = 8 withByteArray = withByteArrayS + instance ByteArrayAccess Bytes16 where length _ = 16 withByteArray = withByteArrayS + instance ByteArrayAccess Bytes32 where length _ = 32 withByteArray = withByteArrayS + instance ByteArrayAccess Bytes64 where length _ = 64 withByteArray = withByteArrayS + instance ByteArrayAccess Bytes128 where length _ = 128 withByteArray = withByteArrayS @@ -193,9 +203,8 @@ withByteArrayS :: StaticBytes sbytes => sbytes -> (Ptr p -> IO a) -> IO a withByteArrayS sbytes = withByteArray (fromStatic sbytes :: ByteString) -toStaticExact - :: forall dbytes sbytes. - (DynamicBytes dbytes, StaticBytes sbytes) +toStaticExact :: + forall dbytes sbytes. (DynamicBytes dbytes, StaticBytes sbytes) => dbytes -> Either StaticBytesException sbytes toStaticExact dbytes = @@ -204,9 +213,8 @@ GT -> Left TooManyBytes EQ -> Right (toStaticPadTruncate dbytes) -toStaticPad - :: forall dbytes sbytes. - (DynamicBytes dbytes, StaticBytes sbytes) +toStaticPad :: + forall dbytes sbytes. (DynamicBytes dbytes, StaticBytes sbytes) => dbytes -> Either StaticBytesException sbytes toStaticPad dbytes = @@ -214,9 +222,8 @@ GT -> Left TooManyBytes _ -> Right (toStaticPadTruncate dbytes) -toStaticTruncate - :: forall dbytes sbytes. - (DynamicBytes dbytes, StaticBytes sbytes) +toStaticTruncate :: + forall dbytes sbytes. (DynamicBytes dbytes, StaticBytes sbytes) => dbytes -> Either StaticBytesException sbytes toStaticTruncate dbytes = @@ -224,15 +231,14 @@ LT -> Left NotEnoughBytes _ -> Right (toStaticPadTruncate dbytes) -toStaticPadTruncate - :: (DynamicBytes dbytes, StaticBytes sbytes) +toStaticPadTruncate :: + (DynamicBytes dbytes, StaticBytes sbytes) => dbytes -> sbytes toStaticPadTruncate dbytes = unsafePerformIO (withPeekD dbytes (usePeekS 0)) -fromStatic - :: forall dbytes sbytes. - (DynamicBytes dbytes, StaticBytes sbytes) +fromStatic :: + forall dbytes sbytes. (DynamicBytes dbytes, StaticBytes sbytes) => sbytes -> dbytes fromStatic = fromWordsD (lengthS (Nothing :: Maybe sbytes)) . ($ []) . toWordsS
src/Pantry/Repo.hs view
@@ -1,9 +1,10 @@-{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} + module Pantry.Repo ( fetchReposRaw , fetchRepos @@ -14,22 +15,21 @@ , withRepo ) where - -import Pantry.Types -import Pantry.Archive -import Pantry.Storage hiding (findOrGenerateCabalFile) -import RIO -import Path.IO (resolveFile') -import RIO.FilePath ((</>)) -import RIO.Directory (doesDirectoryExist) -import RIO.ByteString (isInfixOf) -import RIO.ByteString.Lazy (toStrict) +import Database.Persist ( Entity (..) ) +import Pantry.Archive +import Pantry.Storage hiding ( findOrGenerateCabalFile ) +import Pantry.Types +import Path.IO ( resolveFile' ) +import RIO +import RIO.ByteString ( isInfixOf ) +import RIO.ByteString.Lazy ( toStrict ) +import RIO.Directory ( doesDirectoryExist ) +import RIO.FilePath ( (</>) ) import qualified RIO.Map as Map -import RIO.Process -import Database.Persist (Entity (..)) +import RIO.Process import qualified RIO.Text as T -import System.Console.ANSI (hSupportsANSIWithoutEmulation) -import System.IsWindows (osIsWindows) +import System.Console.ANSI ( hSupportsANSIWithoutEmulation ) +import System.IsWindows ( osIsWindows ) data TarType = Gnu | Bsd @@ -50,11 +50,12 @@ let bs = toStrict stdoutBS pure $ if "GNU" `isInfixOf` bs then Gnu else Bsd --- | Like 'fetchRepos', except with 'RawPackageMetadata' instead of 'PackageMetadata'. +-- | Like 'fetchRepos', except with 'RawPackageMetadata' instead of +-- 'PackageMetadata'. -- -- @since 0.5.3 -fetchReposRaw - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) +fetchReposRaw :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => [(Repo, RawPackageMetadata)] -> RIO env () fetchReposRaw pairs = do @@ -65,47 +66,47 @@ -- | Fetch the given repositories at once and populate the pantry database. -- -- @since 0.5.3 -fetchRepos - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) +fetchRepos :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => [(Repo, PackageMetadata)] -> RIO env () fetchRepos pairs = do -- TODO be more efficient, group together shared archives fetchReposRaw $ map (second toRawPM) pairs -getRepoKey - :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) +getRepoKey :: + forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Repo -> RawPackageMetadata -> RIO env TreeKey getRepoKey repo rpm = packageTreeKey <$> getRepo repo rpm -- potential optimization -getRepo - :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) +getRepo :: + forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Repo -> RawPackageMetadata -> RIO env Package getRepo repo pm = do withCache $ getRepo' repo pm - where - withCache - :: RIO env Package - -> RIO env Package - withCache inner = do - mtid <- withStorage (loadRepoCache repo) - case mtid of - Just tid -> withStorage $ loadPackageById (RPLIRepo repo pm) tid - Nothing -> do - package <- inner - withStorage $ do - ment <- getTreeForKey $ packageTreeKey package - case ment of - Nothing -> error $ "invariant violated, Tree not found: " ++ show (packageTreeKey package) - Just (Entity tid _) -> storeRepoCache repo (repoSubdir repo) tid - pure package + where + withCache :: RIO env Package -> RIO env Package + withCache inner = do + mtid <- withStorage (loadRepoCache repo) + case mtid of + Just tid -> withStorage $ loadPackageById (RPLIRepo repo pm) tid + Nothing -> do + package <- inner + withStorage $ do + ment <- getTreeForKey $ packageTreeKey package + case ment of + Nothing -> error $ + "invariant violated, Tree not found: " + ++ show (packageTreeKey package) + Just (Entity tid _) -> storeRepoCache repo (repoSubdir repo) tid + pure package -getRepo' - :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) +getRepo' :: + forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Repo -> RawPackageMetadata -> RIO env Package @@ -125,35 +126,38 @@ } rpm -getRepos - :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) +getRepos :: + forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => AggregateRepo -> RIO env [Package] -getRepos repo@(AggregateRepo (SimpleRepo{..}) repoSubdirs) = - withCache getRepos' - where - withCache inner = do - pkgs <- forM repoSubdirs $ \(subdir, rpm) -> withStorage $ do - loadRepoCache (Repo sRepoUrl sRepoCommit sRepoType subdir) >>= \case - Just tid -> fmap Right $ (, subdir) <$> loadPackageById (RPLIRepo (Repo sRepoUrl sRepoCommit sRepoType subdir) rpm) tid - Nothing -> pure $ Left (subdir, rpm) - let (missingPkgs, cachedPkgs) = partitionEithers pkgs - newPkgs <- - if null missingPkgs - then pure [] - else do - packages <- inner repo { aRepoSubdirs = missingPkgs } - forM packages $ \(package, subdir) -> do - withStorage $ do - ment <- getTreeForKey $ packageTreeKey package - case ment of - Nothing -> error $ "invariant violated, Tree not found: " ++ show (packageTreeKey package) - Just (Entity tid _) -> storeRepoCache (Repo sRepoUrl sRepoCommit sRepoType subdir) subdir tid - pure package - pure (nubOrd ((fst <$> cachedPkgs) ++ newPkgs)) +getRepos repo@(AggregateRepo (SimpleRepo{..}) repoSubdirs) = withCache getRepos' + where + withCache inner = do + pkgs <- forM repoSubdirs $ \(subdir, rpm) -> withStorage $ do + loadRepoCache (Repo sRepoUrl sRepoCommit sRepoType subdir) >>= \case + Just tid -> + fmap Right $ (, subdir) <$> loadPackageById (RPLIRepo (Repo sRepoUrl sRepoCommit sRepoType subdir) rpm) tid + Nothing -> pure $ Left (subdir, rpm) + let (missingPkgs, cachedPkgs) = partitionEithers pkgs + newPkgs <- + if null missingPkgs + then pure [] + else do + packages <- inner repo { aRepoSubdirs = missingPkgs } + forM packages $ \(package, subdir) -> do + withStorage $ do + ment <- getTreeForKey $ packageTreeKey package + case ment of + Nothing -> error $ + "invariant violated, Tree not found: " + ++ show (packageTreeKey package) + Just (Entity tid _) -> + storeRepoCache (Repo sRepoUrl sRepoCommit sRepoType subdir) subdir tid + pure package + pure (nubOrd ((fst <$> cachedPkgs) ++ newPkgs)) -getRepos' - :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) +getRepos' :: + forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => AggregateRepo -> RIO env [(Package, Text)] -- ^ [(package, subdir)] getRepos' ar@(AggregateRepo (SimpleRepo{..}) repoSubdirs) = do @@ -175,8 +179,8 @@ -- | Fetch a repository and create a (temporary) tar archive from it. Pass the -- path of the generated tarball to the given action. -withRepoArchive - :: forall env a. (HasLogFunc env, HasProcessContext env) +withRepoArchive :: + forall env a. (HasLogFunc env, HasProcessContext env) => SimpleRepo -> (FilePath -> RIO env a) -> RIO env a @@ -188,28 +192,30 @@ -- | Run a git command, setting appropriate environment variable settings. See -- <https://github.com/commercialhaskell/stack/issues/3748>. -runGitCommand - :: (HasLogFunc env, HasProcessContext env) +runGitCommand :: + (HasLogFunc env, HasProcessContext env) => [String] -- ^ args -> RIO env () runGitCommand args = withModifyEnvVars go $ void $ proc "git" args readProcess_ - where - go = Map.delete "GIT_DIR" - . Map.delete "GIT_CEILING_DIRECTORIES" - . Map.delete "GIT_WORK_TREE" - . Map.delete "GIT_INDEX_FILE" - . Map.delete "GIT_OBJECT_DIRECTORY" -- possible optimization: set this to something Pantry controls - . Map.delete "GIT_ALTERNATE_OBJECT_DIRECTORIES" + where + go = Map.delete "GIT_DIR" + . Map.delete "GIT_CEILING_DIRECTORIES" + . Map.delete "GIT_WORK_TREE" + . Map.delete "GIT_INDEX_FILE" + . Map.delete "GIT_OBJECT_DIRECTORY" -- possible optimization: set this to something Pantry controls + . Map.delete "GIT_ALTERNATE_OBJECT_DIRECTORIES" --- Include submodules files into the archive: use `git submodule --- foreach` to execute `git archive` in each submodule and generate --- tar archive. With bsd tar, the generated archive is extracted to a --- temporary folder and the files in them are added to the tarball --- referenced by the variable tarball in the haskell code. This is --- done in GNU tar with -A option. -archiveSubmodules :: (HasLogFunc env, HasProcessContext env) => FilePath -> RIO env () +-- Include submodules files into the archive: use `git submodule foreach` to +-- execute `git archive` in each submodule and generate tar archive. With bsd +-- tar, the generated archive is extracted to a temporary folder and the files +-- in them are added to the tarball referenced by the variable tarball in the +-- haskell code. This is done in GNU tar with -A option. +archiveSubmodules :: + (HasLogFunc env, HasProcessContext env) + => FilePath + -> RIO env () archiveSubmodules tarball = do tarType <- getGitTarType let forceLocal = @@ -218,27 +224,26 @@ else mempty case tarType of Gnu -> runGitCommand - [ "submodule", "foreach", "--recursive" - , "git -c core.autocrlf=false archive --prefix=$displaypath/ -o bar.tar HEAD; " - <> "tar" <> forceLocal <> " -Af " <> tarball <> " bar.tar" - ] - Bsd -> - runGitCommand - [ "submodule" - , "foreach" - , "--recursive" - , "git -c core.autocrlf=false archive --prefix=$displaypath/ -o bar.tar HEAD;" <> - " rm -rf temp; mkdir temp; mv bar.tar temp/; tar " <> - " -C temp -xf temp/bar.tar; " <> - "rm temp/bar.tar; tar " <> - " -C temp -rf " <> - tarball <> - " . ;" - ] + [ "submodule" + , "foreach" + , "--recursive" + , "git -c core.autocrlf=false archive --prefix=$displaypath/ -o bar.tar HEAD; " + <> "tar" <> forceLocal <> " -Af " <> tarball <> " bar.tar" + ] + Bsd -> runGitCommand + [ "submodule" + , "foreach" + , "--recursive" + , "git -c core.autocrlf=false archive --prefix=$displaypath/ -o bar.tar HEAD; " + <> "rm -rf temp; mkdir temp; mv bar.tar temp/; " + <> "tar -C temp -xf temp/bar.tar; " + <> "rm temp/bar.tar; " + <> "tar -C temp -rf " <> tarball <> " . ;" + ] -- | Run an hg command -runHgCommand - :: (HasLogFunc env, HasProcessContext env) +runHgCommand :: + (HasLogFunc env, HasProcessContext env) => [String] -- ^ args -> RIO env () runHgCommand args = void $ proc "hg" args readProcess_ @@ -259,49 +264,67 @@ RepoHg -> runHgCommand ["archive", tarball, "-X", ".hg_archival.txt"] --- | Clone the repository and execute the action with the working --- directory set to the repository root. +-- | Clone the repository (and, in the case of Git and if necessary, fetch the +-- specific commit) and execute the action with the working directory set to the +-- repository root. -- -- @since 0.1.0.0 -withRepo - :: forall env a. (HasLogFunc env, HasProcessContext env) +withRepo :: + forall env a. (HasLogFunc env, HasProcessContext env) => SimpleRepo -> RIO env a -> RIO env a withRepo sr@SimpleRepo{..} action = withSystemTempDirectory "with-repo" $ \tmpDir -> do - -- Note we do not immediately change directories into the new temporary directory, - -- but instead wait until we have finished cloning the repo. This is because the - -- repo URL may be a relative path on the local filesystem, and we should interpret - -- it as relative to the current directory, not the temporary directory. - let dir = tmpDir </> "cloned" - (runCommand, resetArgs, submoduleArgs) = + let repoUrl = T.unpack sRepoUrl + repoCommit = T.unpack sRepoCommit + dir = tmpDir </> "cloned" + (runCommand, resetArgs) = case sRepoType of RepoGit -> ( runGitCommand - , ["reset", "--hard", T.unpack sRepoCommit] - , Just ["submodule", "update", "--init", "--recursive"] + , ["reset", "--hard", repoCommit] ) RepoHg -> ( runHgCommand - , ["update", "-C", T.unpack sRepoCommit] - , Nothing + , ["update", "-C", repoCommit] ) + fetchCommit = ["fetch", repoUrl, repoCommit] + submoduleArgs = ["submodule", "update", "--init", "--recursive"] fixANSIForWindows = - -- On Windows 10, an upstream issue with the `git clone` command means that - -- command clears, but does not then restore, the + -- On Windows 10, an upstream issue with the `git clone` command means + -- that command clears, but does not then restore, the -- ENABLE_VIRTUAL_TERMINAL_PROCESSING flag for native terminals. The -- following hack re-enables the lost ANSI-capability. when osIsWindows $ void $ liftIO $ hSupportsANSIWithoutEmulation stdout - logInfo $ "Cloning " <> display sRepoCommit <> " from " <> display sRepoUrl - runCommand ["clone", T.unpack sRepoUrl, dir] + runCommand ["clone", repoUrl, dir] fixANSIForWindows created <- doesDirectoryExist dir unless created $ throwIO $ FailedToCloneRepo sr + -- Note we do not immediately change directories into the new temporary + -- directory, but instead wait until we have finished cloning the repo. This + -- is because the repo URL may be a relative path on the local filesystem, + -- and we should interpret it as relative to the current directory, not the + -- temporary directory. withWorkingDir dir $ do - runCommand resetArgs - traverse_ runCommand submoduleArgs - fixANSIForWindows + case sRepoType of + RepoGit -> do + catch + -- This will result in a failure exit code if the specified commit + -- is not in the clone of the repository. + (runCommand resetArgs) + ( \(_ :: ExitCodeException) -> do + -- Perhaps the specified commit is not one that is brought across + -- by `git clone`. For example, in the case of a GitHub + -- repository, it may be a commit from a different repository + -- that is the subject of an unmerged pull request. Try to fetch + -- the specific commit and then try again. + runCommand fetchCommit + runCommand resetArgs + ) + runCommand submoduleArgs + fixANSIForWindows + RepoHg -> runCommand resetArgs action
src/Pantry/SHA256.hs view
@@ -1,18 +1,20 @@-{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} --- | Provides a data type ('SHA256') for efficient memory --- representation of a sha-256 hash value, together with helper --- functions for converting to and from that value. This module is --- intended to be imported qualified as @SHA256@. +{-# LANGUAGE OverloadedStrings #-} + +-- | Provides a data type ('SHA256') for efficient memory representation of a +-- sha-256 hash value, together with helper functions for converting to and from +-- that value. This module is intended to be imported qualified as @SHA256@. -- -- Some nomenclature: -- --- * Hashing calculates a new hash value from some input. @from@ takes a value that represents an existing hash. +-- * Hashing calculates a new hash value from some input. @from@ takes a value +-- that represents an existing hash. -- --- * Raw means a raw binary representation of the hash value, without any hex encoding. +-- * Raw means a raw binary representation of the hash value, without any hex +-- encoding. -- -- * Text always uses lower case hex encoding -- @@ -37,24 +39,23 @@ , toRaw ) where -import RIO -import Data.Aeson -import Database.Persist.Sql -import Pantry.Internal.StaticBytes -import Conduit -import qualified RIO.Text as T - -import qualified Crypto.Hash.Conduit as Hash (hashFile, sinkHash) -import qualified Crypto.Hash as Hash (hash, hashlazy, Digest, SHA256) +import Conduit +import qualified Crypto.Hash as Hash ( Digest, SHA256, hash, hashlazy ) +import qualified Crypto.Hash.Conduit as Hash ( hashFile, sinkHash ) +import Data.Aeson import qualified Data.ByteArray import qualified Data.ByteArray.Encoding as Mem +import Database.Persist.Sql +import Pantry.Internal.StaticBytes +import RIO +import qualified RIO.Text as T -- | A SHA256 hash, stored in a static size for more efficient -- memory representation. -- -- @since 0.1.0.0 newtype SHA256 = SHA256 Bytes32 - deriving (Generic, Eq, NFData, Data, Typeable, Ord, Hashable) + deriving (Generic, Eq, NFData, Data, Typeable, Ord, Hashable) -- | Exceptions which can occur in this module -- @@ -94,7 +95,8 @@ fromHexText :: Text -> Either SHA256Exception SHA256 fromHexText = fromHexBytes . encodeUtf8 --- | Convert a base16-encoded 'ByteString' value containing a hash into a 'SHA256'. +-- | Convert a base16-encoded 'ByteString' value containing a hash into a +-- 'SHA256'. -- -- @since 0.1.0.0 fromHexBytes :: ByteString -> Either SHA256Exception SHA256 @@ -114,7 +116,8 @@ -- -- @since 0.1.0.0 fromRaw :: ByteString -> Either SHA256Exception SHA256 -fromRaw bs = either (Left . InvalidByteCount bs) (Right . SHA256) (toStaticExact bs) +fromRaw bs = + either (Left . InvalidByteCount bs) (Right . SHA256) (toStaticExact bs) -- | Convert a 'SHA256' into a base16-encoded SHA256 hash. -- @@ -122,7 +125,8 @@ toHexText :: SHA256 -> Text toHexText ss = case decodeUtf8' $ toHexBytes ss of - Left e -> error $ "Impossible failure in staticSHA256ToText: " ++ show (ss, e) + Left e -> + error $ "Impossible failure in staticSHA256ToText: " ++ show (ss, e) Right t -> t -- | Convert a 'SHA256' into a base16-encoded SHA256 hash.
src/Pantry/SQLite.hs view
@@ -1,23 +1,26 @@-{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RankNTypes #-} + module Pantry.SQLite ( Storage (..) , initStorage ) where -import RIO hiding (FilePath) -import Database.Persist.Sqlite -import RIO.Orphans () -import Path (Path, Abs, File, toFilePath, parent) -import Path.IO (ensureDir) -import Pantry.Types (PantryException (MigrationFailure), Storage (..)) -import System.FileLock (withFileLock, withTryFileLock, SharedExclusive (..)) -import Pantry.Internal.Companion +import Database.Persist.Sqlite +import Pantry.Internal.Companion +import Pantry.Types + ( PantryException (MigrationFailure), Storage (..) ) +import Path ( Abs, File, Path, parent, toFilePath ) +import Path.IO ( ensureDir ) +import RIO hiding ( FilePath ) +import RIO.Orphans () +import System.FileLock + ( SharedExclusive (..), withFileLock, withTryFileLock ) -initStorage - :: HasLogFunc env +initStorage :: + HasLogFunc env => Text -> Migration -> Path Abs File -- ^ storage file @@ -53,27 +56,25 @@ runSqlConn action conn , withWriteLock_ = id } - where - wrapMigrationFailure = handleAny (throwIO . MigrationFailure description fp) + where + wrapMigrationFailure = handleAny (throwIO . MigrationFailure description fp) - sqinfo isMigration - = set extraPragmas ["PRAGMA busy_timeout=2000;"] - $ set walEnabled False + sqinfo isMigration + = set extraPragmas ["PRAGMA busy_timeout=2000;"] + $ set walEnabled False - -- When doing a migration, we want to disable foreign key - -- checking, since the order in which tables are created by - -- the migration scripts may not respect foreign keys. The - -- rest of the time: enforce those foreign keys. - $ set fkEnabled (not isMigration) + -- When doing a migration, we want to disable foreign key checking, since + -- the order in which tables are created by the migration scripts may not + -- respect foreign keys. The rest of the time: enforce those foreign keys. + $ set fkEnabled (not isMigration) - $ mkSqliteConnectionInfo (fromString $ toFilePath fp) + $ mkSqliteConnectionInfo (fromString $ toFilePath fp) --- | Ensure that only one process is trying to write to the database --- at a time. See --- https://github.com/commercialhaskell/stack/issues/4471 and comments +-- | Ensure that only one process is trying to write to the database at a time. +-- See https://github.com/commercialhaskell/stack/issues/4471 and comments -- above. -withWriteLock - :: HasLogFunc env +withWriteLock :: + HasLogFunc env => Utf8Builder -- ^ database description, for lock messages -> Path Abs File -- ^ SQLite database file -> RIO env a @@ -90,13 +91,24 @@ -- Wait five seconds before giving the first message to -- avoid spamming the user for uninteresting file locks delay $ 5 * 1000 * 1000 -- 5 seconds - logInfo $ "Unable to get a write lock on the " <> desc <> " database, waiting..." + logInfo $ + "Unable to get a write lock on the " + <> desc + <> " database, waiting..." -- Now loop printing a message every 1 minute forever $ do delay (60 * 1000 * 1000) -- 1 minute - `onCompanionDone` logInfo ("Acquired the " <> desc <> " database write lock") - logWarn ("Still waiting on the " <> desc <> " database write lock...") + `onCompanionDone` logInfo + ( "Acquired the " + <> desc + <> " database write lock" + ) + logWarn + ( "Still waiting on the " + <> desc + <> " database write lock..." + ) withCompanion complainer $ \stopComplaining -> withFileLock lockFile Exclusive $ const $ do stopComplaining
src/Pantry/Storage.hs view
@@ -1,24 +1,25 @@-{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + module Pantry.Storage ( SqlBackend , initStorage @@ -101,29 +102,40 @@ , unCachedTree ) where -import RIO hiding (FilePath) -import RIO.Process -import qualified RIO.ByteString as B +import Conduit +import Data.Acquire ( with ) +import Database.Persist +import Database.Persist.Sqlite +import Database.Persist.TH +import Pantry.HPack ( hpack, hpackVersion ) +import qualified Pantry.SHA256 as SHA256 +import qualified Pantry.SQLite as SQLite +import Pantry.Types + ( BlobKey, FileSize (..), FileType (..), HasPantryConfig + , Package (..), PackageNameP (..), Repo (..), Revision (..) + , SHA256, SafeFilePath, SnapshotCacheHash (..), TreeKey + , VersionP (..), connRDBMS + ) import qualified Pantry.Types as P -import qualified RIO.List as List +import Path + ( Abs, Dir, File, Path, filename, fromAbsFile, fromRelFile + , parseAbsDir, toFilePath + ) +import Path.IO ( createTempDir, getTempDir, listDir, removeDirRecur ) +import RIO hiding ( FilePath ) +import qualified RIO.ByteString as B +import RIO.Directory + ( createDirectoryIfMissing, getPermissions + , setOwnerExecutable, setPermissions + ) +import RIO.FilePath ( (</>), takeDirectory ) import qualified RIO.FilePath as FilePath -import RIO.FilePath ((</>), takeDirectory) -import RIO.Directory (createDirectoryIfMissing, setPermissions, getPermissions, setOwnerExecutable) -import Database.Persist -import Database.Persist.Sqlite -import Database.Persist.TH -import RIO.Orphans (HasResourceMap) -import qualified Pantry.SHA256 as SHA256 +import qualified RIO.List as List import qualified RIO.Map as Map +import RIO.Orphans ( HasResourceMap ) +import RIO.Process import qualified RIO.Text as T -import RIO.Time (UTCTime, getCurrentTime) -import Path (Path, Abs, File, Dir, toFilePath, filename, parseAbsDir, fromAbsFile, fromRelFile) -import Path.IO (listDir, createTempDir, getTempDir, removeDirRecur) -import Pantry.HPack (hpackVersion, hpack) -import Conduit -import Data.Acquire (with) -import Pantry.Types (PackageNameP (..), VersionP (..), SHA256, FileSize (..), FileType (..), HasPantryConfig, BlobKey, Repo (..), TreeKey, SafeFilePath, Revision (..), Package (..), SnapshotCacheHash (..), connRDBMS) -import qualified Pantry.SQLite as SQLite +import RIO.Time ( UTCTime, getCurrentTime ) share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| -- Raw blobs @@ -261,25 +273,25 @@ UniqueModule name |] -initStorage - :: HasLogFunc env +initStorage :: + HasLogFunc env => Path Abs File -- ^ storage file -> (P.Storage -> RIO env a) -> RIO env a initStorage = SQLite.initStorage "Pantry" migrateAll -withStorage - :: (HasPantryConfig env, HasLogFunc env) +withStorage :: + (HasPantryConfig env, HasLogFunc env) => ReaderT SqlBackend (RIO env) a -> RIO env a withStorage action = do storage <- view (P.pantryConfigL.to P.pcStorage) SQLite.withStorage_ storage action --- | This is a helper type to distinguish db queries between different rdbms backends. The important --- part is that the affects described in this data type should be semantically equivalent between --- the supported engines. +-- | This is a helper type to distinguish db queries between different rdbms +-- backends. The important part is that the affects described in this data type +-- should be semantically equivalent between the supported engines. data RdbmsActions env a = RdbmsActions { raSqlite :: !(ReaderT SqlBackend (RIO env) a) -- ^ A query that is specific to SQLite @@ -287,9 +299,10 @@ -- ^ A query that is specific to PostgreSQL } --- | This function provides a way to create queries supported by multiple sql backends. -rdbmsAwareQuery - :: RdbmsActions env a +-- | This function provides a way to create queries supported by multiple sql +-- backends. +rdbmsAwareQuery :: + RdbmsActions env a -> ReaderT SqlBackend (RIO env) a rdbmsAwareQuery RdbmsActions {raSqlite, raPostgres} = do rdbms <- Pantry.Types.connRDBMS <$> ask @@ -298,25 +311,24 @@ "sqlite" -> raSqlite _ -> error $ "rdbmsAwareQuery: unsupported rdbms '" ++ T.unpack rdbms ++ "'" - -getPackageNameById - :: PackageNameId +getPackageNameById :: + PackageNameId -> ReaderT SqlBackend (RIO env) (Maybe P.PackageName) getPackageNameById = fmap (unPackageNameP . packageNameName <$>) . get - -getPackageNameId - :: P.PackageName +getPackageNameId :: + P.PackageName -> ReaderT SqlBackend (RIO env) PackageNameId -getPackageNameId = fmap (either entityKey id) . insertBy . PackageName . PackageNameP +getPackageNameId = + fmap (either entityKey id) . insertBy . PackageName . PackageNameP -getVersionId - :: P.Version +getVersionId :: + P.Version -> ReaderT SqlBackend (RIO env) VersionId getVersionId = fmap (either entityKey id) . insertBy . Version . VersionP -storeBlob - :: ByteString +storeBlob :: + ByteString -> ReaderT SqlBackend (RIO env) (BlobId, BlobKey) storeBlob bs = do let sha = SHA256.hashBytes bs @@ -329,20 +341,20 @@ RdbmsActions { raSqlite = insert Blob {blobSha = sha, blobSize = size, blobContents = bs} - , raPostgres = - do rawExecute - "INSERT INTO blob(sha, size, contents) VALUES (?, ?, ?) ON CONFLICT DO NOTHING" - [ toPersistValue sha - , toPersistValue size - , toPersistValue bs - ] - rawSql - "SELECT blob.id FROM blob WHERE blob.sha = ?" - [toPersistValue sha] >>= \case - [Single key] -> pure key - _ -> - error - "soreBlob: there was a critical problem storing a blob." + , raPostgres = do + rawExecute + "INSERT INTO blob(sha, size, contents) VALUES (?, ?, ?) ON \ + \CONFLICT DO NOTHING" + [ toPersistValue sha + , toPersistValue size + , toPersistValue bs + ] + rawSql + "SELECT blob.id FROM blob WHERE blob.sha = ?" + [toPersistValue sha] >>= \case + [Single key] -> pure key + _ -> error + "soreBlob: there was a critical problem storing a blob." } key:rest -> assert (null rest) (pure key) pure (key, P.BlobKey sha size) @@ -380,16 +392,18 @@ -> ConduitT () (BlobId, ByteString) (ReaderT SqlBackend (RIO env)) () allBlobsSource mblobId = selectSource [BlobId >. blobId | Just blobId <- [mblobId]] [Asc BlobId] .| - mapC ((entityKey &&& blobContents . entityVal)) + mapC (entityKey &&& blobContents . entityVal) -- | Pull all hackage cabal entries from the database as --- 'RawPackageLocationImmutable'. We do a manual join rather than --- dropping to raw SQL, and Esqueleto would add more deps. +-- 'RawPackageLocationImmutable'. We do a manual join rather than dropping to +-- raw SQL, and Esqueleto would add more deps. allHackageCabalRawPackageLocations :: HasResourceMap env => Maybe HackageCabalId - -- ^ For some x, yield cabals whose id>x. - -> ReaderT SqlBackend (RIO env) (Map.Map HackageCabalId P.RawPackageLocationImmutable) + -- ^ For some x, yield cabals whose id>x. + -> ReaderT + SqlBackend (RIO env) + (Map.Map HackageCabalId P.RawPackageLocationImmutable) allHackageCabalRawPackageLocations mhackageId = do hackageCabals :: Map HackageCabalId HackageCabal <- selectTuples @@ -415,8 +429,8 @@ mblobKey <- maybe (pure Nothing) - (fmap Just . getBlobKey) - (fmap (treeKey . entityVal) mtree) + ((fmap Just . getBlobKey) . treeKey . entityVal) + mtree pure (P.RPLIHackage (P.PackageIdentifierRevision @@ -425,10 +439,10 @@ (P.CFIRevision (hackageCabalRevision hackageCabal))) (fmap P.TreeKey mblobKey))) - where - selectTuples pred sort = - fmap (Map.fromList . map tuple) (selectList pred sort) - tuple (Entity k v) = (k, v) + where + selectTuples pred sort = + fmap (Map.fromList . map tuple) (selectList pred sort) + tuple (Entity k v) = (k, v) allBlobsCount :: Maybe BlobId -> ReaderT SqlBackend (RIO env) Int allBlobsCount mblobId = count [BlobId >. blobId | Just blobId <- [mblobId]] @@ -481,7 +495,10 @@ clearHackageRevisions = deleteWhere ([] :: [Filter HackageCabal]) storeHackageRevision :: - P.PackageName -> P.Version -> BlobId -> ReaderT SqlBackend (RIO env) () + P.PackageName + -> P.Version + -> BlobId + -> ReaderT SqlBackend (RIO env) () storeHackageRevision name version key = do nameid <- getPackageNameId name versionid <- getVersionId version @@ -497,13 +514,13 @@ , hackageCabalTree = Nothing } -loadHackagePackageVersions - :: P.PackageName +loadHackagePackageVersions :: + P.PackageName -> ReaderT SqlBackend (RIO env) (Map P.Version (Map Revision BlobKey)) loadHackagePackageVersions name = do nameid <- getPackageNameId name -- would be better with esqueleto - (Map.fromListWith Map.union . map go) <$> rawSql + Map.fromListWith Map.union . map go <$> rawSql "SELECT hackage.revision, version.version, blob.sha, blob.size\n\ \FROM hackage_cabal as hackage, version, blob\n\ \WHERE hackage.name=?\n\ @@ -514,31 +531,30 @@ go (Single revision, Single (P.VersionP version), Single key, Single size) = (version, Map.singleton revision (P.BlobKey key size)) -loadHackagePackageVersion - :: P.PackageName +loadHackagePackageVersion :: + P.PackageName -> P.Version -> ReaderT SqlBackend (RIO env) (Map Revision (BlobId, P.BlobKey)) loadHackagePackageVersion name version = do nameid <- getPackageNameId name versionid <- getVersionId version -- would be better with esqueleto - (Map.fromList . map go) <$> rawSql + Map.fromList . map go <$> rawSql "SELECT hackage.revision, blob.sha, blob.size, blob.id\n\ \FROM hackage_cabal as hackage, version, blob\n\ \WHERE hackage.name=?\n\ \AND hackage.version=?\n\ \AND hackage.cabal=blob.id" [toPersistValue nameid, toPersistValue versionid] - where - go (Single revision, Single sha, Single size, Single bid) = - (revision, (bid, P.BlobKey sha size)) + where + go (Single revision, Single sha, Single size, Single bid) = + (revision, (bid, P.BlobKey sha size)) -loadLatestCacheUpdate - :: ReaderT SqlBackend (RIO env) (Maybe (FileSize, SHA256)) -loadLatestCacheUpdate = - fmap go <$> selectFirst [] [Desc CacheUpdateTime] - where - go (Entity _ cu) = (cacheUpdateSize cu, cacheUpdateSha cu) +loadLatestCacheUpdate :: + ReaderT SqlBackend (RIO env) (Maybe (FileSize, SHA256)) +loadLatestCacheUpdate = fmap go <$> selectFirst [] [Desc CacheUpdateTime] + where + go (Entity _ cu) = (cacheUpdateSize cu, cacheUpdateSha cu) storeCacheUpdate :: FileSize -> SHA256 -> ReaderT SqlBackend (RIO env) () storeCacheUpdate size sha = do @@ -549,8 +565,8 @@ , cacheUpdateSha = sha } -storeHackageTarballInfo - :: P.PackageName +storeHackageTarballInfo :: + P.PackageName -> P.Version -> SHA256 -> FileSize @@ -565,38 +581,36 @@ , hackageTarballSize = size } -loadHackageTarballInfo - :: P.PackageName +loadHackageTarballInfo :: + P.PackageName -> P.Version -> ReaderT SqlBackend (RIO env) (Maybe (SHA256, FileSize)) loadHackageTarballInfo name version = do nameid <- getPackageNameId name versionid <- getVersionId version fmap go <$> getBy (UniqueHackageTarball nameid versionid) - where - go (Entity _ ht) = (hackageTarballSha ht, hackageTarballSize ht) + where + go (Entity _ ht) = (hackageTarballSha ht, hackageTarballSize ht) storeCabalFile :: - ByteString - -> P.PackageName - -> ReaderT SqlBackend (RIO env) BlobId + ByteString + -> P.PackageName + -> ReaderT SqlBackend (RIO env) BlobId storeCabalFile cabalBS pkgName = do - (bid, _) <- storeBlob cabalBS - let cabalFile = P.cabalFileName pkgName - _ <- insertBy FilePath {filePathPath = cabalFile} - return bid + (bid, _) <- storeBlob cabalBS + let cabalFile = P.cabalFileName pkgName + _ <- insertBy FilePath {filePathPath = cabalFile} + pure bid loadFilePath :: - SafeFilePath - -> ReaderT SqlBackend (RIO env) (Entity FilePath) + SafeFilePath + -> ReaderT SqlBackend (RIO env) (Entity FilePath) loadFilePath path = do - fp <- getBy $ UniqueSfp path - case fp of - Nothing -> - error $ - "loadFilePath: No row found for " <> - (T.unpack $ P.unSafeFilePath path) - Just record -> return record + fp <- getBy $ UniqueSfp path + case fp of + Nothing -> error $ + "loadFilePath: No row found for " <> T.unpack (P.unSafeFilePath path) + Just record -> pure record loadHPackTreeEntity :: TreeId -> ReaderT SqlBackend (RIO env) (Entity TreeEntry) loadHPackTreeEntity tid = do @@ -605,23 +619,22 @@ hpackTreeEntry <- selectFirst [TreeEntryTree ==. tid, TreeEntryPath ==. filePathId] [] case hpackTreeEntry of - Nothing -> - error $ - "loadHPackTreeEntity: No package.yaml file found in TreeEntry for TreeId: " ++ - show tid - Just record -> return record + Nothing -> error $ + "loadHPackTreeEntity: No package.yaml file found in TreeEntry for TreeId: " + ++ show tid + Just record -> pure record storeHPack :: - (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => P.RawPackageLocationImmutable - -> TreeId - -> ReaderT SqlBackend (RIO env) (Key HPack) + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => P.RawPackageLocationImmutable + -> TreeId + -> ReaderT SqlBackend (RIO env) (Key HPack) storeHPack rpli tid = do - vid <- hpackVersionId - hpackRecord <- getBy (UniqueHPack tid vid) - case hpackRecord of - Nothing -> generateHPack rpli tid vid - Just record -> return $ entityKey record + vid <- hpackVersionId + hpackRecord <- getBy (UniqueHPack tid vid) + case hpackRecord of + Nothing -> generateHPack rpli tid vid + Just record -> pure $ entityKey record loadCabalBlobKey :: HPackId -> ReaderT SqlBackend (RIO env) BlobKey loadCabalBlobKey hpackId = do @@ -629,35 +642,35 @@ getBlobKey $ hPackCabalBlob hpackRecord generateHPack :: - (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => P.RawPackageLocationImmutable -- ^ for exceptions - -> TreeId - -> VersionId - -> ReaderT SqlBackend (RIO env) (Key HPack) + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => P.RawPackageLocationImmutable -- ^ for exceptions + -> TreeId + -> VersionId + -> ReaderT SqlBackend (RIO env) (Key HPack) generateHPack rpli tid vid = do - tree <- getTree tid - (pkgName, cabalBS) <- hpackToCabalS rpli tree - bid <- storeCabalFile cabalBS pkgName - let cabalFile = P.cabalFileName pkgName - fid <- insertBy FilePath {filePathPath = cabalFile} - let hpackRecord = - HPack - { hPackTree = tid - , hPackVersion = vid - , hPackCabalBlob = bid - , hPackCabalPath = either entityKey id fid - } - either entityKey id <$> insertBy hpackRecord + tree <- getTree tid + (pkgName, cabalBS) <- hpackToCabalS rpli tree + bid <- storeCabalFile cabalBS pkgName + let cabalFile = P.cabalFileName pkgName + fid <- insertBy FilePath {filePathPath = cabalFile} + let hpackRecord = + HPack + { hPackTree = tid + , hPackVersion = vid + , hPackCabalBlob = bid + , hPackCabalPath = either entityKey id fid + } + either entityKey id <$> insertBy hpackRecord hpackVersionId :: - (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => ReaderT SqlBackend (RIO env) VersionId + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => ReaderT SqlBackend (RIO env) VersionId hpackVersionId = do - hpackSoftwareVersion <- lift hpackVersion - fmap (either entityKey id) $ - insertBy $ - Version {versionVersion = P.VersionP hpackSoftwareVersion} + hpackSoftwareVersion <- lift hpackVersion + fmap (either entityKey id) $ + insertBy $ + Version {versionVersion = P.VersionP hpackSoftwareVersion} getFilePathId :: SafeFilePath -> ReaderT SqlBackend (RIO env) FilePathId @@ -668,23 +681,22 @@ rdbmsAwareQuery RdbmsActions { raSqlite = insert $ FilePath sfp - , raPostgres = - do rawExecute - "INSERT INTO file_path(path) VALUES (?) ON CONFLICT DO NOTHING" - [toPersistValue sfp] - rawSql - "SELECT id FROM file_path WHERE path = ?" - [toPersistValue sfp] >>= \case - [Single key] -> pure key - _ -> - error - "getFilePathId: there was a critical problem storing a blob." + , raPostgres = do + rawExecute + "INSERT INTO file_path(path) VALUES (?) ON CONFLICT DO NOTHING" + [toPersistValue sfp] + rawSql + "SELECT id FROM file_path WHERE path = ?" + [toPersistValue sfp] >>= \case + [Single key] -> pure key + _ -> error + "getFilePathId: there was a critical problem storing a blob." } _ -> error $ "getFilePathId: FilePath unique constraint key is violated for: " ++ fp - where - fp = T.unpack (P.unSafeFilePath sfp) + where + fp = T.unpack (P.unSafeFilePath sfp) -- | A tree that has already been stored in the database newtype CachedTree @@ -694,8 +706,8 @@ unCachedTree :: CachedTree -> P.Tree unCachedTree (CachedTreeMap m) = P.TreeMap $ fst <$> m -storeTree - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) +storeTree :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => P.RawPackageLocationImmutable -- ^ for exceptions -> P.PackageIdentifier -> CachedTree @@ -704,14 +716,18 @@ storeTree rpli (P.PackageIdentifier name version) tree@(CachedTreeMap m) buildFile = do (bid, blobKey) <- storeBlob $ P.renderTree $ unCachedTree tree (cabalid, ftype) <- case buildFile of - P.BFHpack (P.TreeEntry _ ftype) -> pure (Nothing, ftype) - P.BFCabal _ (P.TreeEntry (P.BlobKey btypeSha _) ftype) -> do - buildTypeid <- loadBlobBySHA btypeSha - buildid <- - case buildTypeid of - Just buildId -> pure buildId - Nothing -> error $ "storeTree: " ++ (show buildFile) ++ " BlobKey not found: " ++ show (tree, btypeSha) - return (Just buildid, ftype) + P.BFHpack (P.TreeEntry _ ftype) -> pure (Nothing, ftype) + P.BFCabal _ (P.TreeEntry (P.BlobKey btypeSha _) ftype) -> do + buildTypeid <- loadBlobBySHA btypeSha + buildid <- + case buildTypeid of + Just buildId -> pure buildId + Nothing -> error $ + "storeTree: " + ++ show buildFile + ++ " BlobKey not found: " + ++ show (tree, btypeSha) + pure (Just buildid, ftype) nameid <- getPackageNameId name versionid <- getVersionId version etid <- insertBy Tree @@ -735,9 +751,9 @@ } pure (tid, P.TreeKey blobKey) case buildFile of - P.BFHpack _ -> storeHPack rpli tid >> return () - P.BFCabal _ _ -> return () - return (tid, pTreeKey) + P.BFHpack _ -> void $ storeHPack rpli tid + P.BFCabal _ _ -> pure () + pure (tid, pTreeKey) getTree :: TreeId -> ReaderT SqlBackend (RIO env) P.Tree getTree tid = do @@ -756,8 +772,8 @@ Nothing -> pure Nothing Just ent -> Just <$> loadTreeByEnt ent -getTreeForKey - :: TreeKey +getTreeForKey :: + TreeKey -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree)) getTreeForKey (P.TreeKey key) = do mbid <- getBlobId key @@ -771,60 +787,51 @@ -> TreeId -> ReaderT SqlBackend (RIO env) Package loadPackageById rpli tid = do - (mts :: Maybe Tree) <- get tid - ts <- - case mts of - Nothing -> - error $ "loadPackageById: invalid foreign key " ++ show tid - Just ts -> pure ts - (tree :: P.Tree) <- loadTreeByEnt $ Entity tid ts - (blobKey :: BlobKey) <- getBlobKey $ treeKey ts - (mname :: Maybe PackageName) <- get $ treeName ts - name <- - case mname of - Nothing -> - error $ - "loadPackageByid: invalid foreign key " ++ show (treeName ts) - Just (PackageName (P.PackageNameP name)) -> pure name - mversion <- get $ treeVersion ts - version <- - case mversion of - Nothing -> - error $ - "loadPackageByid: invalid foreign key " ++ show (treeVersion ts) - Just (Version (P.VersionP version)) -> pure version - let ident = P.PackageIdentifier name version - (packageEntry, mtree) <- - case treeCabal ts of - Just keyBlob -> do - cabalKey <- getBlobKey keyBlob - return - ( P.PCCabalFile $ P.TreeEntry cabalKey (treeCabalType ts) - , tree) - Nothing -> do - hpackVid <- hpackVersionId - hpackEntity <- getBy (UniqueHPack tid hpackVid) - let (P.TreeMap tmap) = tree - cabalFile = P.cabalFileName name - case hpackEntity of - Nothing - -- This case will happen when you either - -- update stack with a new hpack version or - -- use different hpack version via - -- --with-hpack option. - -> do - (hpackId :: HPackId) <- storeHPack rpli tid - hpackRecord <- getJust hpackId - getHPackCabalFile hpackRecord ts tmap cabalFile - Just (Entity _ item) -> - getHPackCabalFile item ts tmap cabalFile - pure - Package - { packageTreeKey = P.TreeKey blobKey - , packageTree = mtree - , packageCabalEntry = packageEntry - , packageIdent = ident - } + (mts :: Maybe Tree) <- get tid + ts <- case mts of + Nothing -> + error $ "loadPackageById: invalid foreign key " ++ show tid + Just ts -> pure ts + (tree :: P.Tree) <- loadTreeByEnt $ Entity tid ts + (blobKey :: BlobKey) <- getBlobKey $ treeKey ts + (mname :: Maybe PackageName) <- get $ treeName ts + name <- case mname of + Nothing -> error $ + "loadPackageByid: invalid foreign key " ++ show (treeName ts) + Just (PackageName (P.PackageNameP name)) -> pure name + mversion <- get $ treeVersion ts + version <- case mversion of + Nothing -> error $ + "loadPackageByid: invalid foreign key " ++ show (treeVersion ts) + Just (Version (P.VersionP version)) -> pure version + let ident = P.PackageIdentifier name version + (packageEntry, mtree) <- case treeCabal ts of + Just keyBlob -> do + cabalKey <- getBlobKey keyBlob + pure + ( P.PCCabalFile $ P.TreeEntry cabalKey (treeCabalType ts) + , tree) + Nothing -> do + hpackVid <- hpackVersionId + hpackEntity <- getBy (UniqueHPack tid hpackVid) + let (P.TreeMap tmap) = tree + cabalFile = P.cabalFileName name + case hpackEntity of + Nothing -> do + -- This case will happen when you either update stack with a new hpack + -- version or use different hpack version via --with-hpack option. + (hpackId :: HPackId) <- storeHPack rpli tid + hpackRecord <- getJust hpackId + getHPackCabalFile hpackRecord ts tmap cabalFile + Just (Entity _ item) -> + getHPackCabalFile item ts tmap cabalFile + pure + Package + { packageTreeKey = P.TreeKey blobKey + , packageTree = mtree + , packageCabalEntry = packageEntry + , packageIdent = ident + } getHPackBlobKey :: HPack -> ReaderT SqlBackend (RIO env) BlobKey getHPackBlobKey hpackRecord = do @@ -837,30 +844,30 @@ hpackRecord <- getJust hpackId getHPackBlobKey hpackRecord - getHPackCabalFile :: - (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => HPack - -> Tree - -> Map SafeFilePath P.TreeEntry - -> SafeFilePath - -> ReaderT SqlBackend (RIO env) (P.PackageCabal, P.Tree) + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => HPack + -> Tree + -> Map SafeFilePath P.TreeEntry + -> SafeFilePath + -> ReaderT SqlBackend (RIO env) (P.PackageCabal, P.Tree) getHPackCabalFile hpackRecord ts tmap cabalFile = do - cabalKey <- getBlobKey (hPackCabalBlob hpackRecord) - hpackKey <- getHPackBlobKey hpackRecord - hpackSoftwareVersion <- lift hpackVersion - let fileType = treeCabalType ts - cbTreeEntry = P.TreeEntry cabalKey fileType - hpackTreeEntry = P.TreeEntry hpackKey fileType - tree = P.TreeMap $ Map.insert cabalFile cbTreeEntry tmap - return - ( P.PCHpack $ - P.PHpack - { P.phOriginal = hpackTreeEntry - , P.phGenerated = cbTreeEntry - , P.phVersion = hpackSoftwareVersion - } - , tree) + cabalKey <- getBlobKey (hPackCabalBlob hpackRecord) + hpackKey <- getHPackBlobKey hpackRecord + hpackSoftwareVersion <- lift hpackVersion + let fileType = treeCabalType ts + cbTreeEntry = P.TreeEntry cabalKey fileType + hpackTreeEntry = P.TreeEntry hpackKey fileType + tree = P.TreeMap $ Map.insert cabalFile cbTreeEntry tmap + pure + ( P.PCHpack $ + P.PHpack + { P.phOriginal = hpackTreeEntry + , P.phGenerated = cbTreeEntry + , P.phVersion = hpackSoftwareVersion + } + , tree + ) loadTreeByEnt :: Entity Tree -> ReaderT SqlBackend (RIO env) P.Tree loadTreeByEnt (Entity tid _t) = do @@ -876,8 +883,8 @@ (sfp, P.TreeEntry (P.BlobKey sha size) ft)) entries -storeHackageTree - :: P.PackageName +storeHackageTree :: + P.PackageName -> P.Version -> BlobId -> P.TreeKey @@ -893,8 +900,8 @@ ] [HackageCabalTree =. Just (entityKey ent)] -loadHackageTreeKey - :: P.PackageName +loadHackageTreeKey :: + P.PackageName -> P.Version -> SHA256 -> ReaderT SqlBackend (RIO env) (Maybe TreeKey) @@ -919,8 +926,8 @@ (Single treesha, Single size):_ -> pure $ Just $ P.TreeKey $ P.BlobKey treesha size -loadHackageTree - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) +loadHackageTree :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => P.RawPackageLocationImmutable -- ^ for exceptions -> P.PackageName -> P.Version @@ -943,8 +950,8 @@ Nothing -> assert False $ pure Nothing Just tid -> Just <$> loadPackageById rpli tid -storeArchiveCache - :: Text -- ^ URL +storeArchiveCache :: + Text -- ^ URL -> Text -- ^ subdir -> SHA256 -> FileSize @@ -962,8 +969,8 @@ , archiveCacheTree = entityKey ent } -loadArchiveCache - :: Text -- ^ URL +loadArchiveCache :: + Text -- ^ URL -> Text -- ^ subdir -> ReaderT SqlBackend (RIO env) [(SHA256, FileSize, TreeId)] loadArchiveCache url subdir = map go <$> selectList @@ -971,11 +978,11 @@ , ArchiveCacheSubdir ==. subdir ] [Desc ArchiveCacheTime] - where - go (Entity _ ac) = (archiveCacheSha ac, archiveCacheSize ac, archiveCacheTree ac) + where + go (Entity _ ac) = (archiveCacheSha ac, archiveCacheSize ac, archiveCacheTree ac) -storeRepoCache - :: Repo +storeRepoCache :: + Repo -> Text -- ^ subdir -> TreeId -> ReaderT SqlBackend (RIO env) () @@ -990,8 +997,8 @@ , repoCacheTree = tid } -loadRepoCache - :: Repo +loadRepoCache :: + Repo -> ReaderT SqlBackend (RIO env) (Maybe TreeId) loadRepoCache repo = fmap (repoCacheTree . entityVal) <$> selectFirst [ RepoCacheUrl ==. repoUrl repo @@ -1002,7 +1009,9 @@ [Desc RepoCacheTime] storePreferredVersion :: - P.PackageName -> Text -> ReaderT SqlBackend (RIO env) () + P.PackageName + -> Text + -> ReaderT SqlBackend (RIO env) () storePreferredVersion name p = do nameid <- getPackageNameId name ment <- getBy $ UniquePreferred nameid @@ -1014,13 +1023,14 @@ Just (Entity pid _) -> update pid [PreferredVersionsPreferred =. p] loadPreferredVersion :: - P.PackageName -> ReaderT SqlBackend (RIO env) (Maybe Text) + P.PackageName + -> ReaderT SqlBackend (RIO env) (Maybe Text) loadPreferredVersion name = do nameid <- getPackageNameId name fmap (preferredVersionsPreferred . entityVal) <$> getBy (UniquePreferred nameid) -sinkHackagePackageNames - :: (P.PackageName -> Bool) +sinkHackagePackageNames :: + (P.PackageName -> Bool) -> ConduitT P.PackageName Void (ReaderT SqlBackend (RIO env)) a -> ReaderT SqlBackend (RIO env) a sinkHackagePackageNames predicate sink = do @@ -1029,19 +1039,19 @@ $ src .| concatMapMC go .| sink - where - go (Entity nameid (PackageName (PackageNameP name))) - | predicate name = do - -- Make sure it's actually on Hackage. Would be much more - -- efficient with some raw SQL and an inner join, but we - -- don't have a Conduit version of rawSql. - onHackage <- checkOnHackage nameid - pure $ if onHackage then Just name else Nothing - | otherwise = pure Nothing + where + go (Entity nameid (PackageName (PackageNameP name))) + | predicate name = do + -- Make sure it's actually on Hackage. Would be much more efficient with + -- some raw SQL and an inner join, but we don't have a Conduit version + -- of rawSql. + onHackage <- checkOnHackage nameid + pure $ if onHackage then Just name else Nothing + | otherwise = pure Nothing - checkOnHackage nameid = do - cnt <- count [HackageCabalName ==. nameid] - pure $ cnt > 0 + checkOnHackage nameid = do + cnt <- count [HackageCabalName ==. nameid] + pure $ cnt > 0 -- | Get the filename for the cabal file in the given directory. -- @@ -1050,59 +1060,61 @@ -- -- If the directory contains a file named package.yaml, hpack is used to -- generate a .cabal file from it. -findOrGenerateCabalFile - :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => Path Abs Dir -- ^ package directory - -> RIO env (P.PackageName, Path Abs File) +findOrGenerateCabalFile :: + forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Path Abs Dir -- ^ package directory + -> RIO env (P.PackageName, Path Abs File) findOrGenerateCabalFile pkgDir = do - hpack pkgDir - files <- filter (flip hasExtension "cabal" . toFilePath) . snd - <$> listDir pkgDir - -- If there are multiple files, ignore files that start with - -- ".". On unixlike environments these are hidden, and this - -- character is not valid in package names. The main goal is - -- to ignore emacs lock files - see - -- https://github.com/commercialhaskell/stack/issues/1897. - let isHidden ('.':_) = True - isHidden _ = False - case filter (not . isHidden . fromRelFile . filename) files of - [] -> throwIO $ P.NoCabalFileFound pkgDir - [x] -> maybe - (throwIO $ P.InvalidCabalFilePath x) - (\pn -> pure $ (pn, x)) $ - List.stripSuffix ".cabal" (toFilePath (filename x)) >>= - P.parsePackageName - _:_ -> throwIO $ P.MultipleCabalFilesFound pkgDir files - where hasExtension fp x = FilePath.takeExtension fp == "." ++ x + hpack pkgDir + files <- filter (flip hasExtension "cabal" . toFilePath) . snd + <$> listDir pkgDir + -- If there are multiple files, ignore files that start with ".". On unix-like + -- environments these are hidden, and this character is not valid in package + -- names. The main goal is to ignore emacs lock files - see + -- https://github.com/commercialhaskell/stack/issues/1897. + let isHidden ('.':_) = True + isHidden _ = False + case filter (not . isHidden . fromRelFile . filename) files of + [] -> throwIO $ P.NoCabalFileFound pkgDir + [x] -> maybe + (throwIO $ P.InvalidCabalFilePath x) + (\pn -> pure (pn, x)) $ + List.stripSuffix ".cabal" (toFilePath (filename x)) >>= + P.parsePackageName + _:_ -> throwIO $ P.MultipleCabalFilesFound pkgDir files + where + hasExtension fp x = FilePath.takeExtension fp == "." ++ x -- | Similar to 'hpackToCabal' but doesn't require a new connection to database. -hpackToCabalS :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => P.RawPackageLocationImmutable -- ^ for exceptions - -> P.Tree - -> ReaderT SqlBackend (RIO env) (P.PackageName, ByteString) +hpackToCabalS :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => P.RawPackageLocationImmutable -- ^ for exceptions + -> P.Tree + -> ReaderT SqlBackend (RIO env) (P.PackageName, ByteString) hpackToCabalS rpli tree = do tmpDir <- lift $ do - tdir <- getTempDir - createTempDir tdir "hpack-pkg-dir" + tdir <- getTempDir + createTempDir tdir "hpack-pkg-dir" unpackTreeToDir rpli tmpDir tree (packageName, cfile) <- lift $ findOrGenerateCabalFile tmpDir !bs <- lift $ B.readFile (fromAbsFile cfile) lift $ removeDirRecur tmpDir - return $ (packageName, bs) + pure (packageName, bs) -hpackToCabal :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => P.RawPackageLocationImmutable -- ^ for exceptions - -> P.Tree - -> RIO env (P.PackageName, ByteString) +hpackToCabal :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => P.RawPackageLocationImmutable -- ^ for exceptions + -> P.Tree + -> RIO env (P.PackageName, ByteString) hpackToCabal rpli tree = withSystemTempDirectory "hpack-pkg-dir" $ \tmpdir -> do - tdir <- parseAbsDir tmpdir - withStorage $ unpackTreeToDir rpli tdir tree - (packageName, cfile) <- findOrGenerateCabalFile tdir - bs <- B.readFile (fromAbsFile cfile) - return (packageName, bs) + tdir <- parseAbsDir tmpdir + withStorage $ unpackTreeToDir rpli tdir tree + (packageName, cfile) <- findOrGenerateCabalFile tdir + bs <- B.readFile (fromAbsFile cfile) + pure (packageName, bs) -unpackTreeToDir - :: (HasPantryConfig env, HasLogFunc env) +unpackTreeToDir :: + (HasPantryConfig env, HasLogFunc env) => P.RawPackageLocationImmutable -- ^ for exceptions -> Path Abs Dir -- ^ dest dir, will be created if necessary -> P.Tree @@ -1135,26 +1147,26 @@ (Single n):_ -> pure n -getSnapshotCacheByHash - :: SnapshotCacheHash +getSnapshotCacheByHash :: + SnapshotCacheHash -> ReaderT SqlBackend (RIO env) (Maybe SnapshotCacheId) getSnapshotCacheByHash = fmap (fmap entityKey) . getBy . UniqueSnapshotCache . unSnapshotCacheHash -getSnapshotCacheId - :: SnapshotCacheHash +getSnapshotCacheId :: + SnapshotCacheHash -> ReaderT SqlBackend (RIO env) SnapshotCacheId getSnapshotCacheId = fmap (either entityKey id) . insertBy . SnapshotCache . unSnapshotCacheHash -getModuleNameId - :: P.ModuleName +getModuleNameId :: + P.ModuleName -> ReaderT SqlBackend (RIO env) ModuleNameId getModuleNameId = fmap (either entityKey id) . insertBy . ModuleName . P.ModuleNameP -storeSnapshotModuleCache - :: SnapshotCacheId +storeSnapshotModuleCache :: + SnapshotCacheId -> Map P.PackageName (Set P.ModuleName) -> ReaderT SqlBackend (RIO env) () storeSnapshotModuleCache cache packageModules = @@ -1168,8 +1180,8 @@ , packageExposedModuleModule = moduleName } -loadExposedModulePackages - :: SnapshotCacheId +loadExposedModulePackages :: + SnapshotCacheId -> P.ModuleName -> ReaderT SqlBackend (RIO env) [P.PackageName] loadExposedModulePackages cacheId mName = @@ -1183,24 +1195,27 @@ [ toPersistValue (P.ModuleNameP mName) , toPersistValue cacheId ] - where - go (Single (P.PackageNameP m)) = m + where + go (Single (P.PackageNameP m)) = m -data LoadCachedTreeException = MissingBlob !BlobKey +newtype LoadCachedTreeException = MissingBlob BlobKey deriving (Show, Typeable) + instance Exception LoadCachedTreeException -- | Ensure that all blobs needed for this package are present in the cache -loadCachedTree :: forall env. P.Tree -> ReaderT SqlBackend (RIO env) (Either LoadCachedTreeException CachedTree) +loadCachedTree :: + forall env. P.Tree + -> ReaderT SqlBackend (RIO env) (Either LoadCachedTreeException CachedTree) loadCachedTree (P.TreeMap m) = - try $ CachedTreeMap <$> traverse loadEntry m - where - loadEntry :: P.TreeEntry -> ReaderT SqlBackend (RIO env) (P.TreeEntry, BlobId) - loadEntry te = (te, ) <$> loadBlob' (P.teBlob te) + try $ CachedTreeMap <$> traverse loadEntry m + where + loadEntry :: P.TreeEntry -> ReaderT SqlBackend (RIO env) (P.TreeEntry, BlobId) + loadEntry te = (te, ) <$> loadBlob' (P.teBlob te) - loadBlob' :: BlobKey -> ReaderT SqlBackend (RIO env) BlobId - loadBlob' blobKey@(P.BlobKey sha _) = do - mbid <- loadBlobBySHA sha - case mbid of - Nothing -> throwIO $ MissingBlob blobKey - Just bid -> pure bid + loadBlob' :: BlobKey -> ReaderT SqlBackend (RIO env) BlobId + loadBlob' blobKey@(P.BlobKey sha _) = do + mbid <- loadBlobBySHA sha + case mbid of + Nothing -> throwIO $ MissingBlob blobKey + Just bid -> pure bid
src/Pantry/Tree.hs view
@@ -1,27 +1,30 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ViewPatterns #-} + module Pantry.Tree ( unpackTree , rawParseGPD ) where -import RIO +import Distribution.PackageDescription ( GenericPackageDescription ) +import Distribution.PackageDescription.Parsec +import Distribution.Parsec ( PWarning (..) ) +import Pantry.Storage hiding + ( Tree, TreeEntry, findOrGenerateCabalFile ) +import Pantry.Types +import Path ( Abs, Dir, File, Path, toFilePath ) +import RIO +import qualified RIO.ByteString as B +import RIO.Directory + ( createDirectoryIfMissing, getPermissions + , setOwnerExecutable, setPermissions + ) +import RIO.FilePath ((</>), takeDirectory) import qualified RIO.Map as Map import qualified RIO.Text as T -import qualified RIO.ByteString as B -import Pantry.Storage hiding (Tree, TreeEntry, findOrGenerateCabalFile) -import Pantry.Types -import RIO.FilePath ((</>), takeDirectory) -import RIO.Directory (createDirectoryIfMissing, setPermissions, getPermissions, setOwnerExecutable) -import Path (Path, Abs, Dir, toFilePath) -import Distribution.Parsec (PWarning (..)) -import Distribution.PackageDescription (GenericPackageDescription) -import Distribution.PackageDescription.Parsec -import Path (File) -unpackTree - :: (HasPantryConfig env, HasLogFunc env) +unpackTree :: + (HasPantryConfig env, HasLogFunc env) => RawPackageLocationImmutable -- for exceptions -> Path Abs Dir -- ^ dest dir, will be created if necessary -> Tree @@ -43,16 +46,16 @@ perms <- getPermissions dest setPermissions dest $ setOwnerExecutable True perms --- | A helper function that performs the basic character encoding --- necessary. -rawParseGPD - :: MonadThrow m +-- | A helper function that performs the basic character encoding necessary. +rawParseGPD :: + MonadThrow m => Either RawPackageLocationImmutable (Path Abs File) -> ByteString -> m ([PWarning], GenericPackageDescription) rawParseGPD loc bs = - case eres of - Left (mversion, errs) -> throwM $ InvalidCabalFile loc mversion (toList errs) warnings - Right gpkg -> return (warnings, gpkg) - where - (warnings, eres) = runParseResult $ parseGenericPackageDescription bs + case eres of + Left (mversion, errs) -> + throwM $ InvalidCabalFile loc mversion (toList errs) warnings + Right gpkg -> pure (warnings, gpkg) + where + (warnings, eres) = runParseResult $ parseGenericPackageDescription bs
src/Pantry/Types.hs view
@@ -1,3200 +1,3320 @@-{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} -module Pantry.Types - ( PantryConfig (..) - , PackageIndexConfig (..) - , HackageSecurityConfig (..) - , defaultHackageSecurityConfig - , Storage (..) - , HasPantryConfig (..) - , BlobKey (..) - , PackageName - , Version - , PackageIdentifier (..) - , Revision (..) - , ModuleName - , CabalFileInfo (..) - , PrintWarnings (..) - , PackageNameP (..) - , VersionP (..) - , ModuleNameP (..) - , PackageIdentifierRevision (..) - , pirForHash - , FileType (..) - , BuildFile (..) - , FileSize (..) - , TreeEntry (..) - , SafeFilePath - , unSafeFilePath - , mkSafeFilePath - , safeFilePathToPath - , hpackSafeFilePath - , TreeKey (..) - , Tree (..) - , renderTree - , parseTree - , parseTreeM - , SHA256 - , Unresolved - , resolvePaths - , Package (..) - , PackageCabal (..) - , PHpack (..) - -- , PackageTarball (..) - , RawPackageLocation (..) - , PackageLocation (..) - , toRawPL - , RawPackageLocationImmutable (..) - , PackageLocationImmutable (..) - , toRawPLI - , RawArchive (..) - , Archive (..) - , toRawArchive - , Repo (..) - , AggregateRepo (..) - , SimpleRepo (..) - , toAggregateRepos - , rToSimpleRepo - , arToSimpleRepo - , RepoType (..) - , parsePackageIdentifier - , parsePackageName - , parsePackageNameThrowing - , parseFlagName - , parseVersion - , parseVersionThrowing - , packageIdentifierString - , packageNameString - , flagNameString - , versionString - , moduleNameString - , OptionalSubdirs (..) - , ArchiveLocation (..) - , RelFilePath (..) - , CabalString (..) - , toCabalStringMap - , unCabalStringMap - , parsePackageIdentifierRevision - , Mismatch (..) - , PantryException (..) - , FuzzyResults (..) - , ResolvedPath (..) - , HpackExecutable (..) - , WantedCompiler (..) - --, resolveSnapshotLocation - , snapshotLocation - , defaultSnapshotLocation - , SnapName (..) - , parseSnapName - , RawSnapshotLocation (..) - , SnapshotLocation (..) - , toRawSL - , parseHackageText - , parseRawSnapshotLocation - , RawSnapshotLayer (..) - , SnapshotLayer (..) - , toRawSnapshotLayer - , RawSnapshot (..) - , Snapshot (..) - , RawSnapshotPackage (..) - , SnapshotPackage (..) - , parseWantedCompiler - , RawPackageMetadata (..) - , PackageMetadata (..) - , toRawPM - , cabalFileName - , SnapshotCacheHash (..) - , getGlobalHintsFile - , bsToBlobKey - , warnMissingCabalFile - , connRDBMS - ) where - -import RIO -import qualified Data.Conduit.Tar as Tar -import qualified RIO.Text as T -import qualified RIO.ByteString as B -import qualified RIO.ByteString.Lazy as BL -import RIO.List (intersperse, groupBy) -import RIO.Time (toGregorian, Day, UTCTime) -import qualified RIO.Map as Map -import RIO.PrettyPrint (bulletedList, fillSep, flow, hang, line, mkNarrativeList, parens, string, style) -import RIO.PrettyPrint.Types (Style (..)) -import qualified Data.Map.Strict as Map (mapKeysMonotonic) -import qualified RIO.Set as Set -import Data.Aeson.Types (toJSONKeyText, Parser) -import Pantry.Internal.AesonExtended - ( FromJSON (..), FromJSONKey (..), FromJSONKeyFunction (..), Object - , ToJSON (..), ToJSONKey (..), ToJSONKeyFunction (..), Value (..) - , WarningParser, WithJSONWarnings, (..:), (..:?), (..!=), (.=), (.:) - , (...:?), jsonSubWarnings, jsonSubWarningsT, noJSONWarnings, object - , tellJSONField, withObject, withObjectWarnings, withText - ) -import Data.Aeson.Encoding.Internal (unsafeToEncoding) -import Data.ByteString.Builder (toLazyByteString, byteString, wordDec) -import Database.Persist -import Database.Persist.Sql -import Pantry.SHA256 (SHA256) -import qualified Pantry.SHA256 as SHA256 -import qualified Distribution.Compat.CharParsing as Parse -import Distribution.CabalSpecVersion (cabalSpecLatest) -#if MIN_VERSION_Cabal(3,4,0) -import Distribution.CabalSpecVersion (cabalSpecToVersionDigits) -#else -import Distribution.CabalSpecVersion (CabalSpecVersion (..)) -#endif -import Distribution.Parsec (PError (..), PWarning (..), showPos, parsec, explicitEitherParsec, ParsecParser) -import Distribution.Types.PackageName (PackageName, unPackageName, mkPackageName) -import Distribution.Types.VersionRange (VersionRange) -import Distribution.PackageDescription (FlagName, unFlagName, GenericPackageDescription) -import Distribution.Types.PackageId (PackageIdentifier (..)) -import qualified Distribution.Pretty -import qualified Distribution.Text -import qualified Hpack.Config as Hpack -import Distribution.ModuleName (ModuleName) -import Distribution.Types.Version (Version, mkVersion, nullVersion) -import Network.HTTP.Client (parseRequest) -import Network.HTTP.Types (Status, statusCode) -import Text.PrettyPrint.Leijen.Extended (Pretty (..), StyleDoc) -import Data.Text.Read (decimal) -import Path (Path, Abs, Dir, File, toFilePath, filename, (</>), parseRelFile) -import Path.IO (resolveFile, resolveDir) -import qualified Data.List.NonEmpty as NE -import Casa.Client (CasaRepoPrefix) - -#if MIN_VERSION_persistent(2, 13, 0) -import Database.Persist.SqlBackend.Internal (connRDBMS) -#endif - -#if MIN_VERSION_aeson(2, 0, 0) -import qualified Data.Aeson.KeyMap as HM -import qualified Data.Aeson.Key - -type AesonKey = Data.Aeson.Key.Key -#else -import qualified RIO.HashMap as HM - -type AesonKey = Text -#endif - --- | Parsed tree with more information on the Haskell package it contains. --- --- @since 0.1.0.0 -data Package = Package - { packageTreeKey :: !TreeKey - -- ^ The 'TreeKey' containing this package. - -- - -- This is a hash of the binary representation of 'packageTree'. - -- - -- @since 0.1.0.0 - , packageTree :: !Tree - -- ^ The 'Tree' containing this package. - -- - -- @since 0.1.0.0 - , packageCabalEntry :: !PackageCabal - -- ^ Information on the cabal file inside this package. - -- - -- @since 0.1.0.0 - , packageIdent :: !PackageIdentifier - -- ^ The package name and version in this package. - -- - -- @since 0.1.0.0 - } - deriving (Show, Eq, Ord) - -data PHpack = PHpack - { - phOriginal :: !TreeEntry, -- ^ Original hpack file - phGenerated :: !TreeEntry, -- ^ Generated Cabal file - phVersion :: !Version -- ^ Version of Hpack used - } deriving (Show, Eq, Ord) - -data PackageCabal = PCCabalFile !TreeEntry -- ^ TreeEntry of Cabal file - | PCHpack !PHpack - deriving (Show, Eq, Ord) - -cabalFileName :: PackageName -> SafeFilePath -cabalFileName name = - case mkSafeFilePath $ T.pack (packageNameString name) <> ".cabal" of - Nothing -> error $ "cabalFileName: failed for " ++ show name - Just sfp -> sfp - --- | The revision number of a package from Hackage, counting upwards --- from 0 (the original cabal file). --- --- See caveats on 'CFIRevision'. --- --- @since 0.1.0.0 -newtype Revision = Revision Word - deriving (Generic, Show, Eq, NFData, Data, Typeable, Ord, Hashable, Display, PersistField, PersistFieldSql) - --- | Represents a SQL database connection. This used to be a newtype --- wrapper around a connection pool. However, when investigating --- <https://github.com/commercialhaskell/stack/issues/4471>, it --- appeared that holding a pool resulted in overly long write locks --- being held on the database. As a result, we now abstract away --- whether a pool is used, and the default implementation in --- "Pantry.Storage" does not use a pool. -data Storage = Storage - { withStorage_ :: forall env a. HasLogFunc env => ReaderT SqlBackend (RIO env) a -> RIO env a - , withWriteLock_ :: forall env a. HasLogFunc env => RIO env a -> RIO env a - } - --- | Configuration value used by the entire pantry package. Create one --- using @withPantryConfig@. See also @PantryApp@ for a convenience --- approach to using pantry. --- --- @since 0.1.0.0 -data PantryConfig = PantryConfig - { pcPackageIndex :: !PackageIndexConfig - , pcHpackExecutable :: !HpackExecutable - , pcRootDir :: !(Path Abs Dir) - , pcStorage :: !Storage - , pcUpdateRef :: !(MVar Bool) - -- ^ Want to try updating the index once during a single run for missing - -- package identifiers. We also want to ensure we only update once at a - -- time. Start at @True@. - , pcParsedCabalFilesRawImmutable :: !(IORef (Map RawPackageLocationImmutable GenericPackageDescription)) - -- ^ Cache of previously parsed cabal files, to save on slow parsing time. - , pcParsedCabalFilesMutable :: - !(IORef - (Map - (Path Abs Dir) - (PrintWarnings -> IO GenericPackageDescription, PackageName, Path Abs File) - ) - ) - -- ^ Cache for mutable packages. We want to allow for an optimization: - -- deferring parsing of the 'GenericPackageDescription' until its actually - -- needed. Therefore, we keep the filepath and the 'PackageName' derived from - -- that filepath. When the @IO GenericPackageDescription@ is run, it will - -- ensure that the @PackageName@ matches the value inside the cabal file, and - -- print out any warnings that still need to be printed. - , pcConnectionCount :: !Int - -- ^ concurrently open downloads - , pcCasaRepoPrefix :: !CasaRepoPrefix - -- ^ The pull URL e.g. @https://casa.fpcomplete.com/v1/pull@ - , pcCasaMaxPerRequest :: !Int - -- ^ Maximum blobs sent per pull request. - , pcSnapshotLocation :: SnapName -> RawSnapshotLocation - -- ^ The location of snapshot synonyms - } - --- | Get the location of a snapshot synonym from the 'PantryConfig'. --- --- @since 0.5.0.0 -snapshotLocation :: HasPantryConfig env => SnapName -> RIO env RawSnapshotLocation -snapshotLocation name = do - loc <- view $ pantryConfigL.to pcSnapshotLocation - pure $ loc name - --- | Should we print warnings when loading a cabal file? --- --- @since 0.1.0.0 -data PrintWarnings = YesPrintWarnings | NoPrintWarnings - --- | Wraps a value which potentially contains relative paths. Needs to --- be provided with a base directory to resolve these paths. --- --- Unwrap this using 'resolvePaths'. --- --- @since 0.1.0.0 -newtype Unresolved a = Unresolved (Maybe (Path Abs Dir) -> IO a) - deriving Functor -instance Applicative Unresolved where - pure = Unresolved . const . pure - Unresolved f <*> Unresolved x = Unresolved $ \mdir -> f mdir <*> x mdir - --- | Resolve all of the file paths in an 'Unresolved' relative to the --- given directory. --- --- @since 0.1.0.0 -resolvePaths - :: MonadIO m - => Maybe (Path Abs Dir) -- ^ directory to use for relative paths - -> Unresolved a - -> m a -resolvePaths mdir (Unresolved f) = liftIO (f mdir) - --- | A combination of the relative path provided in a config file, --- together with the resolved absolute path. --- --- @since 0.1.0.0 -data ResolvedPath t = ResolvedPath - { resolvedRelative :: !RelFilePath - -- ^ Original value parsed from a config file. - , resolvedAbsolute :: !(Path Abs t) - -- ^ Absolute path resolved against base directory loaded from. - } - deriving (Show, Eq, Generic, Ord) -instance NFData (ResolvedPath t) - --- | Location to load a package from. Can either be immutable (see --- 'PackageLocationImmutable') or a local directory which is expected --- to change over time. Raw version doesn't include exact package --- version (e.g. could refer to the latest revision on Hackage) --- --- @since 0.1.0.0 -data RawPackageLocation - = RPLImmutable !RawPackageLocationImmutable - | RPLMutable !(ResolvedPath Dir) - deriving (Show, Eq, Generic) -instance NFData RawPackageLocation - --- | Location to load a package from. Can either be immutable (see --- 'PackageLocationImmutable') or a local directory which is expected --- to change over time. --- --- @since 0.1.0.0 -data PackageLocation - = PLImmutable !PackageLocationImmutable - | PLMutable !(ResolvedPath Dir) - deriving (Show, Eq, Generic) -instance NFData PackageLocation - -instance Display PackageLocation where - display (PLImmutable loc) = display loc - display (PLMutable fp) = fromString $ toFilePath $ resolvedAbsolute fp - --- | Convert `PackageLocation` to its "raw" equivalent --- --- @since 0.1.0.0 -toRawPL :: PackageLocation -> RawPackageLocation -toRawPL (PLImmutable im) = RPLImmutable (toRawPLI im) -toRawPL (PLMutable m) = RPLMutable m - --- | Location for remote packages or archives assumed to be immutable. --- as user specifies it i.e. not an exact location --- --- @since 0.1.0.0 -data RawPackageLocationImmutable - = RPLIHackage !PackageIdentifierRevision !(Maybe TreeKey) - | RPLIArchive !RawArchive !RawPackageMetadata - | RPLIRepo !Repo !RawPackageMetadata - deriving (Show, Eq, Ord, Generic) - -instance NFData RawPackageLocationImmutable - -instance Display RawPackageLocationImmutable where - display (RPLIHackage pir _tree) = display pir <> " (from Hackage)" - display (RPLIArchive archive _pm) = - "Archive from " <> display (raLocation archive) <> - (if T.null $ raSubdir archive - then mempty - else " in subdir " <> display (raSubdir archive)) - display (RPLIRepo repo _pm) = - "Repo from " <> display (repoUrl repo) <> - ", commit " <> display (repoCommit repo) <> - (if T.null $ repoSubdir repo - then mempty - else " in subdir " <> display (repoSubdir repo)) - -instance Pretty RawPackageLocationImmutable where - pretty (RPLIHackage pir _tree) = fillSep - [ fromString . T.unpack $ textDisplay pir - , parens (flow "from Hackage") - ] - pretty (RPLIArchive archive _pm) = fillSep - [ flow "Archive from" - , pretty (raLocation archive) - , if T.null $ raSubdir archive - then mempty - else fillSep - [ flow "in subdir" - , style Dir (fromString $ T.unpack (raSubdir archive)) - ] - ] - pretty (RPLIRepo repo _pm) = fillSep - [ flow "Repo from" - , style Url (fromString $ T.unpack (repoUrl repo)) <> "," - , "commit" - , fromString $ T.unpack (repoCommit repo) - , if T.null $ repoSubdir repo - then mempty - else fillSep - [ flow "in subdir" - , style Dir (fromString $ T.unpack (repoSubdir repo)) - ] - ] - --- | Location for remote packages or archives assumed to be immutable. --- --- @since 0.1.0.0 -data PackageLocationImmutable - = PLIHackage !PackageIdentifier !BlobKey !TreeKey - | PLIArchive !Archive !PackageMetadata - | PLIRepo !Repo !PackageMetadata - deriving (Generic, Show, Eq, Ord, Typeable) - -instance NFData PackageLocationImmutable - -instance Display PackageLocationImmutable where - display (PLIHackage ident _cabalHash _tree) = - fromString (packageNameString $ pkgName ident) <> " (from Hackage)" - display (PLIArchive archive _pm) = - "Archive from " <> display (archiveLocation archive) <> - (if T.null $ archiveSubdir archive - then mempty - else " in subdir " <> display (archiveSubdir archive)) - display (PLIRepo repo _pm) = - "Repo from " <> display (repoUrl repo) <> - ", commit " <> display (repoCommit repo) <> - (if T.null $ repoSubdir repo - then mempty - else " in subdir " <> display (repoSubdir repo)) - -instance ToJSON PackageLocationImmutable where - toJSON = toJSON . toRawPLI - --- | Package identifier and revision with a specified cabal file hash --- --- @since 0.1.0.0 -pirForHash :: PackageIdentifier -> BlobKey -> PackageIdentifierRevision -pirForHash (PackageIdentifier name ver) (BlobKey sha size') = - let cfi = CFIHash sha (Just size') - in PackageIdentifierRevision name ver cfi - --- | Convert `PackageLocationImmutable` to its "raw" equivalent --- --- @since 0.1.0.0 -toRawPLI :: PackageLocationImmutable -> RawPackageLocationImmutable -toRawPLI (PLIHackage ident cfKey treeKey) = RPLIHackage (pirForHash ident cfKey) (Just treeKey) -toRawPLI (PLIArchive archive pm) = RPLIArchive (toRawArchive archive) (toRawPM pm) -toRawPLI (PLIRepo repo pm) = RPLIRepo repo (toRawPM pm) - --- | A raw package archive, specified by a user, could have no --- hash and file size information. --- --- @since 0.1.0.0 -data RawArchive = RawArchive - { raLocation :: !ArchiveLocation - -- ^ Location of the archive - -- - -- @since 0.1.0.0 - , raHash :: !(Maybe SHA256) - -- ^ Cryptographic hash of the archive file - -- - -- @since 0.1.0.0 - , raSize :: !(Maybe FileSize) - -- ^ Size of the archive file - -- - -- @since 0.1.0.0 - , raSubdir :: !Text - -- ^ Subdirectory within the archive to get the package from. - -- - -- @since 0.1.0.0 - } - deriving (Generic, Show, Eq, Ord, Typeable) - -instance NFData RawArchive - --- | A package archive, could be from a URL or a local file --- path. Local file path archives are assumed to be unchanging --- over time, and so are allowed in custom snapshots. --- --- @since 0.1.0.0 -data Archive = Archive - { archiveLocation :: !ArchiveLocation - -- ^ Location of the archive - -- - -- @since 0.1.0.0 - , archiveHash :: !SHA256 - -- ^ Cryptographic hash of the archive file - -- - -- @since 0.1.0.0 - , archiveSize :: !FileSize - -- ^ Size of the archive file - -- - -- @since 0.1.0.0 - , archiveSubdir :: !Text - -- ^ Subdirectory within the archive to get the package from. - -- - -- @since 0.1.0.0 - } - deriving (Generic, Show, Eq, Ord, Typeable) -instance NFData Archive - --- | Convert archive to its "raw" equivalent. --- --- @since 0.1.0.0 -toRawArchive :: Archive -> RawArchive -toRawArchive archive = - RawArchive (archiveLocation archive) (Just $ archiveHash archive) - (Just $ archiveSize archive) (archiveSubdir archive) - --- | The type of a source control repository. --- --- @since 0.1.0.0 -data RepoType = RepoGit | RepoHg - deriving (Generic, Show, Eq, Ord, Typeable) -instance NFData RepoType -instance PersistField RepoType where - toPersistValue RepoGit = toPersistValue (1 :: Int32) - toPersistValue RepoHg = toPersistValue (2 :: Int32) - fromPersistValue v = do - i <- fromPersistValue v - case i :: Int32 of - 1 -> pure RepoGit - 2 -> pure RepoHg - _ -> Left $ fromString $ "Invalid RepoType: " ++ show i -instance PersistFieldSql RepoType where - sqlType _ = SqlInt32 - --- | Information on packages stored in a source control repository. --- --- @since 0.1.0.0 -data Repo = Repo - { repoUrl :: !Text - -- ^ Location of the repo - -- - -- @since 0.1.0.0 - , repoCommit :: !Text - -- ^ Commit to use from the repo. It's strongly recommended to use - -- a hash instead of a tag or branch name. - -- - -- @since 0.1.0.0 - , repoType :: !RepoType - -- ^ The type of the repo - -- - -- @since 0.1.0.0 - , repoSubdir :: !Text - -- ^ Subdirectory within the archive to get the package from. - -- - -- @since 0.1.0.0 - } - deriving (Generic, Eq, Ord, Typeable) -instance NFData Repo -instance Show Repo where - show = T.unpack . utf8BuilderToText . display -instance Display Repo where - display (Repo url commit typ subdir) = - (case typ of - RepoGit -> "Git" - RepoHg -> "Mercurial") <> - " repo at " <> - display url <> - ", commit " <> - display commit <> - (if T.null subdir - then mempty - else " in subdirectory " <> display subdir) - -rToSimpleRepo :: Repo -> SimpleRepo -rToSimpleRepo Repo {..} = SimpleRepo { sRepoUrl = repoUrl, sRepoCommit = repoCommit, sRepoType = repoType } - -data AggregateRepo = AggregateRepo - { aRepo :: !SimpleRepo - , aRepoSubdirs :: [(Text, RawPackageMetadata)] - } - deriving (Show, Generic, Eq, Ord, Typeable) - --- | Group input repositories by non-subdir values. -toAggregateRepos :: [(Repo, RawPackageMetadata)] -> [AggregateRepo] -toAggregateRepos = mapMaybe toAggregateRepo . groupBy matchRepoExclSubdir - where - toAggregateRepo :: [(Repo, RawPackageMetadata)] -> Maybe AggregateRepo - toAggregateRepo [] = Nothing - toAggregateRepo xs@((repo, _):_) = - Just $ AggregateRepo (rToSimpleRepo repo) (fmap (first repoSubdir) xs) - - matchRepoExclSubdir x1 x2 = - let (Repo url1 commit1 type1 _, _) = x1 - (Repo url2 commit2 type2 _, _) = x2 - in (url1, commit1, type1) == (url2, commit2, type2) - -arToSimpleRepo :: AggregateRepo -> SimpleRepo -arToSimpleRepo AggregateRepo {..} = aRepo - --- | Repository without subdirectory information. --- --- @since 0.5.3 -data SimpleRepo = SimpleRepo - { sRepoUrl :: !Text - , sRepoCommit :: !Text - , sRepoType :: !RepoType - } - deriving (Show, Generic, Eq, Ord, Typeable) - -instance Display SimpleRepo where - display (SimpleRepo url commit typ) = - (case typ of - RepoGit -> "Git" - RepoHg -> "Mercurial") <> - " repo at " <> - display url <> - ", commit " <> - display commit - --- An unexported newtype wrapper to hang a 'FromJSON' instance off of. Contains --- a GitHub user and repo name separated by a forward slash, e.g. "foo/bar". -newtype GitHubRepo = GitHubRepo Text - -instance FromJSON GitHubRepo where - parseJSON = withText "GitHubRepo" $ \s -> do - case T.split (== '/') s of - [x, y] | not (T.null x || T.null y) -> return (GitHubRepo s) - _ -> fail "expecting \"user/repo\"" - --- | Configuration to securely download package metadata and contents. For most --- purposes, you'll want to use the default Hackage settings via --- @defaultPackageIndexConfig@. --- --- /NOTE/ It's highly recommended to only use the official Hackage --- server or a mirror. See --- <https://github.com/commercialhaskell/stack/issues/4137>. --- --- @since 0.6.0 -data PackageIndexConfig = PackageIndexConfig - { picDownloadPrefix :: !Text - , picHackageSecurityConfig :: !HackageSecurityConfig - } - deriving Show - --- | If the @hackage-security@ key is absent from the JSON object, assigns --- default value 'defaultHackageSecurityConfig'. --- --- @since 0.6.0 -instance FromJSON (WithJSONWarnings PackageIndexConfig) where - parseJSON = withObjectWarnings "PackageIndexConfig" $ \o -> do - picDownloadPrefix <- o ..: "download-prefix" - picHackageSecurityConfig <- jsonSubWarnings $ - o ..:? "hackage-security" ..!= noJSONWarnings defaultHackageSecurityConfig - pure PackageIndexConfig {..} - --- | Default 'HackageSecurityConfig' value using the official Hackage server. --- The value of the 'hscIgnoreExpiry' field is 'True'. --- --- @since 0.7.0 -defaultHackageSecurityConfig :: HackageSecurityConfig -defaultHackageSecurityConfig = HackageSecurityConfig - { hscKeyIds = - [ "0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d" - , "1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42" - , "2c6c3627bd6c982990239487f1abd02e08a02e6cf16edb105a8012d444d870c3" - , "51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921" - , "fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0" - ] - , hscKeyThreshold = 3 - , hscIgnoreExpiry = True - } - --- | Configuration for Hackage Security to securely download package metadata --- and contents. For most purposes, you'll want to use the default Hackage --- settings via @defaultHackageSecurityConfig@. --- --- /NOTE/ It's highly recommended to only use the official Hackage --- server or a mirror. See --- <https://github.com/commercialhaskell/stack/issues/4137>. --- --- @since 0.6.0 -data HackageSecurityConfig = HackageSecurityConfig - { hscKeyIds :: ![Text] - , hscKeyThreshold :: !Int - , hscIgnoreExpiry :: !Bool - } - deriving Show - --- | If the @ignore-expiry@ key is absent from the JSON object, assigns default --- value 'True'. --- --- @since 0.1.1.0 -instance FromJSON (WithJSONWarnings HackageSecurityConfig) where - parseJSON = withObjectWarnings "HackageSecurityConfig" $ \o -> do - hscKeyIds <- o ..: "keyids" - hscKeyThreshold <- o ..: "key-threshold" - hscIgnoreExpiry <- o ..:? "ignore-expiry" ..!= True - pure HackageSecurityConfig {..} - --- | An environment which contains a 'PantryConfig'. --- --- @since 0.1.0.0 -class HasPantryConfig env where - -- | Lens to get or set the 'PantryConfig' - -- - -- @since 0.1.0.0 - pantryConfigL :: Lens' env PantryConfig - - --- | File size in bytes --- --- @since 0.1.0.0 -newtype FileSize = FileSize Word - deriving (Show, Eq, Ord, Typeable, Generic, Display, Hashable, NFData, PersistField, PersistFieldSql, ToJSON, FromJSON) - --- | A key for looking up a blob, which combines the SHA256 hash of --- the contents and the file size. --- --- The file size may seem redundant with the hash. However, it is --- necessary for safely downloading blobs from an untrusted --- source. See --- <https://www.fpcomplete.com/blog/2018/07/pantry-part-2-trees-keys>. --- --- @since 0.1.0.0 -data BlobKey = BlobKey !SHA256 !FileSize - deriving (Eq, Ord, Typeable, Generic) -instance NFData BlobKey - -instance Show BlobKey where - show = T.unpack . utf8BuilderToText . display -instance Display BlobKey where - display (BlobKey sha size') = display sha <> "," <> display size' - -blobKeyPairs :: BlobKey -> [(AesonKey, Value)] -blobKeyPairs (BlobKey sha size') = - [ "sha256" .= sha - , "size" .= size' - ] - -instance ToJSON BlobKey where - toJSON = object . blobKeyPairs -instance FromJSON BlobKey where - parseJSON = withObject "BlobKey" $ \o -> BlobKey - <$> o .: "sha256" - <*> o .: "size" - -newtype PackageNameP = PackageNameP { unPackageNameP :: PackageName } - deriving (Eq, Ord, Show, Read, NFData) -instance Display PackageNameP where - display = fromString . packageNameString . unPackageNameP -instance PersistField PackageNameP where - toPersistValue (PackageNameP pn) = PersistText $ T.pack $ packageNameString pn - fromPersistValue v = do - str <- fromPersistValue v - case parsePackageName str of - Nothing -> Left $ "Invalid package name: " <> T.pack str - Just pn -> Right $ PackageNameP pn -instance PersistFieldSql PackageNameP where - sqlType _ = SqlString -instance ToJSON PackageNameP where - toJSON (PackageNameP pn) = String $ T.pack $ packageNameString pn -instance FromJSON PackageNameP where - parseJSON = withText "PackageNameP" $ pure . PackageNameP . mkPackageName . T.unpack -instance ToJSONKey PackageNameP where - toJSONKey = - ToJSONKeyText - (fromString . packageNameString . unPackageNameP) - (unsafeToEncoding . getUtf8Builder . display) -instance FromJSONKey PackageNameP where - fromJSONKey = FromJSONKeyText $ PackageNameP . mkPackageName . T.unpack - -newtype VersionP = VersionP { unVersionP :: Version } - deriving (Eq, Ord, Show, Read, NFData) -instance PersistField VersionP where - toPersistValue (VersionP v) = PersistText $ T.pack $ versionString v - fromPersistValue v = do - str <- fromPersistValue v - case parseVersion str of - Nothing -> Left $ "Invalid version number: " <> T.pack str - Just ver -> Right $ VersionP ver -instance PersistFieldSql VersionP where - sqlType _ = SqlString -instance Display VersionP where - display (VersionP v) = fromString $ versionString v -instance ToJSON VersionP where - toJSON (VersionP v) = String $ T.pack $ versionString v -instance FromJSON VersionP where - parseJSON = - withText "VersionP" $ - either (fail . displayException) (pure . VersionP) . parseVersionThrowing . T.unpack - -newtype ModuleNameP = ModuleNameP - { unModuleNameP :: ModuleName - } deriving (Eq, Ord, Show, NFData) -instance Display ModuleNameP where - display = fromString . moduleNameString . unModuleNameP -instance PersistField ModuleNameP where - toPersistValue (ModuleNameP mn) = PersistText $ T.pack $ moduleNameString mn - fromPersistValue v = do - str <- fromPersistValue v - case parseModuleName str of - Nothing -> Left $ "Invalid module name: " <> T.pack str - Just pn -> Right $ ModuleNameP pn -instance PersistFieldSql ModuleNameP where - sqlType _ = SqlString - --- | How to choose a cabal file for a package from Hackage. This is to --- work with Hackage cabal file revisions, which makes --- @PackageIdentifier@ insufficient for specifying a package from --- Hackage. --- --- @since 0.1.0.0 -data CabalFileInfo - = CFILatest - -- ^ Take the latest revision of the cabal file available. This - -- isn't reproducible at all, but the running assumption (not - -- necessarily true) is that cabal file revisions do not change - -- semantics of the build. - -- - -- @since 0.1.0.0 - | CFIHash !SHA256 !(Maybe FileSize) - -- ^ Identify by contents of the cabal file itself. Only reason for - -- @Maybe@ on @FileSize@ is for compatibility with input that - -- doesn't include the file size. - -- - -- @since 0.1.0.0 - | CFIRevision !Revision - -- ^ Identify by revision number, with 0 being the original and - -- counting upward. This relies on Hackage providing consistent - -- versioning. @CFIHash@ should be preferred wherever possible for - -- reproducibility. - -- - -- @since 0.1.0.0 - deriving (Generic, Show, Eq, Ord, Typeable) -instance NFData CabalFileInfo -instance Hashable CabalFileInfo - -instance Display CabalFileInfo where - display CFILatest = mempty - display (CFIHash hash' msize) = - "@sha256:" <> display hash' <> maybe mempty (\i -> "," <> display i) msize - display (CFIRevision rev) = "@rev:" <> display rev - --- | A full specification for a package from Hackage, including the --- package name, version, and how to load up the correct cabal file --- revision. --- --- @since 0.1.0.0 -data PackageIdentifierRevision = PackageIdentifierRevision !PackageName !Version !CabalFileInfo - deriving (Generic, Eq, Ord, Typeable) -instance NFData PackageIdentifierRevision - -instance Show PackageIdentifierRevision where - show = T.unpack . utf8BuilderToText . display - -instance Display PackageIdentifierRevision where - display (PackageIdentifierRevision name version cfi) = - fromString (packageNameString name) <> "-" <> fromString (versionString version) <> display cfi - -instance ToJSON PackageIdentifierRevision where - toJSON = toJSON . utf8BuilderToText . display -instance FromJSON PackageIdentifierRevision where - parseJSON = withText "PackageIdentifierRevision" $ \t -> - case parsePackageIdentifierRevision t of - Left e -> fail $ show e - Right pir -> pure pir - --- | Parse a hackage text. --- --- @since 0.1.0.0 -parseHackageText :: Text -> Either PantryException (PackageIdentifier, BlobKey) -parseHackageText t = - either (\x -> error (show x) $ const $ Left $ PackageIdentifierRevisionParseFail t) Right $ - explicitEitherParsec (hackageTextParsec <* Parse.eof) $ - T.unpack t - -hackageTextParsec :: ParsecParser (PackageIdentifier, BlobKey) -hackageTextParsec = do - ident <- packageIdentifierParsec - _ <- Parse.string "@sha256:" - - shaT <- Parse.munch (/= ',') - sha <- either (const mzero) pure $ SHA256.fromHexText $ fromString shaT - - _ <- Parse.char ',' - size' <- Parse.integral -- FIXME probably need to handle overflow, since unfortunately Cabal doesn't - pure (ident, BlobKey sha (FileSize size')) - -splitColon :: Text -> Maybe (Text, Text) -splitColon t' = - let (x, y) = T.break (== ':') t' - in (x, ) <$> T.stripPrefix ":" y - --- | Parse a 'PackageIdentifierRevision' --- --- @since 0.1.0.0 -parsePackageIdentifierRevision :: Text -> Either PantryException PackageIdentifierRevision -parsePackageIdentifierRevision t = maybe (Left $ PackageIdentifierRevisionParseFail t) Right $ do - let (identT, cfiT) = T.break (== '@') t - PackageIdentifier name version <- parsePackageIdentifier $ T.unpack identT - cfi <- - case splitColon cfiT of - Just ("@sha256", shaSizeT) -> do - let (shaT, sizeT) = T.break (== ',') shaSizeT - sha <- either (const Nothing) Just $ SHA256.fromHexText shaT - msize <- - case T.stripPrefix "," sizeT of - Nothing -> Just Nothing - Just sizeT' -> - case decimal sizeT' of - Right (size', "") -> Just $ Just $ FileSize size' - _ -> Nothing - pure $ CFIHash sha msize - Just ("@rev", revT) -> - case decimal revT of - Right (rev, "") -> pure $ CFIRevision $ Revision rev - _ -> Nothing - Nothing -> pure CFILatest - _ -> Nothing - pure $ PackageIdentifierRevision name version cfi - -data Mismatch a = Mismatch - { mismatchExpected :: !a - , mismatchActual :: !a - } - --- | Things that can go wrong in pantry. Note two things: --- --- * Many other exception types may be thrown from underlying --- libraries. Pantry does not attempt to wrap these underlying --- exceptions. --- --- * We may add more constructors to this data type in minor version --- bumps of pantry. This technically breaks the PVP. You should not --- be writing pattern matches against this type that expect total --- matching. --- --- @since 0.1.0.0 -data PantryException - = PackageIdentifierRevisionParseFail !Text - | InvalidCabalFile - !(Either RawPackageLocationImmutable (Path Abs File)) - !(Maybe Version) - ![PError] - ![PWarning] - | TreeWithoutCabalFile !RawPackageLocationImmutable - | TreeWithMultipleCabalFiles !RawPackageLocationImmutable ![SafeFilePath] - | MismatchedCabalName !(Path Abs File) !PackageName - | NoLocalPackageDirFound !(Path Abs Dir) - | NoCabalFileFound !(Path Abs Dir) - | MultipleCabalFilesFound !(Path Abs Dir) ![Path Abs File] - | InvalidWantedCompiler !Text - | InvalidSnapshotLocation !(Path Abs Dir) !Text - | InvalidOverrideCompiler !WantedCompiler !WantedCompiler - | InvalidFilePathSnapshot !Text - | InvalidSnapshot !RawSnapshotLocation !SomeException - | MismatchedPackageMetadata - !RawPackageLocationImmutable - !RawPackageMetadata - !(Maybe TreeKey) - !PackageIdentifier - | Non200ResponseStatus !Status - | InvalidBlobKey !(Mismatch BlobKey) - | Couldn'tParseSnapshot !RawSnapshotLocation !String - | WrongCabalFileName !RawPackageLocationImmutable !SafeFilePath !PackageName - | DownloadInvalidSHA256 !Text !(Mismatch SHA256) - | DownloadInvalidSize !Text !(Mismatch FileSize) - | DownloadTooLarge !Text !(Mismatch FileSize) - -- ^ Different from 'DownloadInvalidSize' since 'mismatchActual' is - -- a lower bound on the size from the server. - | LocalInvalidSHA256 !(Path Abs File) !(Mismatch SHA256) - | LocalInvalidSize !(Path Abs File) !(Mismatch FileSize) - | UnknownArchiveType !ArchiveLocation - | InvalidTarFileType !ArchiveLocation !FilePath !Tar.FileType - | UnsupportedTarball !ArchiveLocation !Text - | NoHackageCryptographicHash !PackageIdentifier - | FailedToCloneRepo !SimpleRepo - | TreeReferencesMissingBlob !RawPackageLocationImmutable !SafeFilePath !BlobKey - | CompletePackageMetadataMismatch !RawPackageLocationImmutable !PackageMetadata - | CRC32Mismatch !ArchiveLocation !FilePath !(Mismatch Word32) - | UnknownHackagePackage !PackageIdentifierRevision !FuzzyResults - | CannotCompleteRepoNonSHA1 !Repo - | MutablePackageLocationFromUrl !Text - | MismatchedCabalFileForHackage !PackageIdentifierRevision !(Mismatch PackageIdentifier) - | PackageNameParseFail !Text - | PackageVersionParseFail !Text - | InvalidCabalFilePath !(Path Abs File) - | DuplicatePackageNames !Utf8Builder ![(PackageName, [RawPackageLocationImmutable])] - | MigrationFailure !Text !(Path Abs File) !SomeException - | InvalidTreeFromCasa !BlobKey !ByteString - | ParseSnapNameException !Text - | HpackLibraryException !(Path Abs File) !String - | HpackExeException !FilePath !(Path Abs Dir) !SomeException - - deriving Typeable -instance Exception PantryException where -instance Show PantryException where - show = T.unpack . utf8BuilderToText . display - --- To support the Haskell Foundation's --- [Haskell Error Index](https://errors.haskell.org/) initiative, all Pantry --- error messages generated by Pantry itself begin with an unique code in the --- form `[S-nnn]`, where `nnn` is a three-digit number in the range 100 to 999. --- The numbers are selected at random, not in sequence. --- --- Prettier versions of these error messages are also provided. See the instance --- of Pretty. -instance Display PantryException where - display (InvalidTreeFromCasa blobKey _bs) = - "Error: [S-258]\n" - <> "Invalid tree from casa: " - <> display blobKey - display (PackageIdentifierRevisionParseFail text) = - "Error: [S-360]\n" - <> "Invalid package identifier (with optional revision): " - <> display text - display (InvalidCabalFile loc mversion errs warnings) = - "Error: [S-242]\n" - <> "Unable to parse cabal file from package " - <> either display (fromString . toFilePath) loc - <> "\n\n" - <> foldMap - ( \(PError pos msg) -> - "- " - <> fromString (showPos pos) - <> ": " - <> fromString msg - <> "\n" - ) - errs - <> foldMap - ( \(PWarning _ pos msg) -> - "- " - <> fromString (showPos pos) - <> ": " - <> fromString msg - <> "\n" - ) - warnings - <> ( case mversion of - Just version - | version > cabalSpecLatestVersion -> - "\n\nThe cabal file uses the cabal specification version " - <> fromString (versionString version) - <> ", but we only support up to version " - <> fromString (versionString cabalSpecLatestVersion) - <> ".\nRecommended action: upgrade your build tool (e.g., `stack upgrade`)." - _ -> mempty - ) - display (TreeWithoutCabalFile pl) = - "Error: [S-654]\n" - <> "No cabal file found for " - <> display pl - display (TreeWithMultipleCabalFiles pl sfps) = - "Error: [S-500]\n" - <> "Multiple cabal files found for " - <> display pl - <> ": " - <> fold (intersperse ", " (map display sfps)) - display (MismatchedCabalName fp name) = - "Error: [S-910]\n" - <> "The Cabal file:\n" - <> fromString (toFilePath fp) - <> "\nis not named after the package that it defines.\n" - <> "Please rename the file to: " - <> fromString (packageNameString name) - <> ".cabal\n" - <> "Hackage rejects packages where the first part of the Cabal file name " - <> "is not the package name." - display (NoLocalPackageDirFound dir) = - "Error: [S-395]\n" - <> "Stack looks for packages in the directories configured in\n" - <> "the 'packages' and 'extra-deps' fields defined in your stack.yaml\n" - <> "The current entry points to " - <> fromString (toFilePath dir) - <> ",\nbut no such directory could be found. If, alternatively, a package\n" - <> "in the package index was intended, its name and version must be\n" - <> "specified as an extra-dep." - display (NoCabalFileFound dir) = - "Error: [S-636]\n" - <> "Stack looks for packages in the directories configured in\n" - <> "the 'packages' and 'extra-deps' fields defined in your stack.yaml\n" - <> "The current entry points to " - <> fromString (toFilePath dir) - <> ",\nbut no .cabal or package.yaml file could be found there." - display (MultipleCabalFilesFound dir files) = - "Error: [S-368]\n" - <> "Multiple .cabal files found in directory " - <> fromString (toFilePath dir) - <> ":\n" - <> fold - ( intersperse - "\n" - (map (\x -> "- " <> fromString (toFilePath (filename x))) files) - ) - display (InvalidWantedCompiler t) = - "Error: [S-204]\n" - <> "Invalid wanted compiler: " - <> display t - display (InvalidSnapshotLocation dir t) = - "Error: [S-935]\n" - <> "Invalid snapshot location " - <> displayShow t - <> " relative to directory " - <> displayShow (toFilePath dir) - display (InvalidOverrideCompiler x y) = - "Error: [S-287]\n" - <> "Specified compiler for a resolver (" - <> display x - <> "), but also specified an override compiler (" - <> display y - <> ")" - display (InvalidFilePathSnapshot t) = - "Error: [S-617]\n" - <> "Specified snapshot as file path with " - <> displayShow t - <> ", but not reading from a local file" - display (InvalidSnapshot loc err) = - "Error: [S-775]\n" - <> "Exception while reading snapshot from " - <> display loc - <> ":\n" - <> displayShow err - display (MismatchedPackageMetadata loc pm mtreeKey foundIdent) = - "Error: [S-427]\n" - <> "Mismatched package metadata for " - <> display loc - <> "\nFound: " - <> fromString (packageIdentifierString foundIdent) - <> ( case mtreeKey of - Nothing -> mempty - Just treeKey -> " with tree " <> display treeKey - ) - <> "\nExpected: " - <> display pm - display (Non200ResponseStatus status) = - "Error: [S-571]\n" - <> "Unexpected non-200 HTTP status code: " - <> displayShow (statusCode status) - display (InvalidBlobKey Mismatch{..}) = - "Error: [S-236]\n" - <> "Invalid blob key found, expected: " - <> display mismatchExpected - <> ", actual: " - <> display mismatchActual - display (Couldn'tParseSnapshot sl err) = - "Error: [S-645]\n" - <> "Couldn't parse snapshot from " - <> display sl - <> ": " - <> fromString err - display (WrongCabalFileName pl sfp name) = - "Error: [S-575]\n" - <> "Wrong cabal file name for package " - <> display pl - <> "\nThe cabal file is named " - <> display sfp - <> ", but package name is " - <> fromString (packageNameString name) - <> "\nFor more information, see:\n - https://github.com/commercialhaskell/stack/issues/317\n -https://github.com/commercialhaskell/stack/issues/895" - display (DownloadInvalidSHA256 url Mismatch {..}) = - "Error: [S-394]\n" - <> "Mismatched SHA256 hash from " - <> display url - <> "\nExpected: " - <> display mismatchExpected - <> "\nActual: " - <> display mismatchActual - display (DownloadInvalidSize url Mismatch {..}) = - "Error: [S-401]\n" - <> "Mismatched download size from " - <> display url - <> "\nExpected: " - <> display mismatchExpected - <> "\nActual: " - <> display mismatchActual - display (DownloadTooLarge url Mismatch {..}) = - "Error: [S-113]\n" - <> "Download from " - <> display url - <> " was too large.\n" - <> "Expected: " - <> display mismatchExpected - <> ", stopped after receiving: " - <> display mismatchActual - display (LocalInvalidSHA256 path Mismatch {..}) = - "Error: [S-834]\n" - <> "Mismatched SHA256 hash from " - <> fromString (toFilePath path) - <> "\nExpected: " - <> display mismatchExpected - <> "\nActual: " - <> display mismatchActual - display (LocalInvalidSize path Mismatch {..}) = - "Error: [S-713]\n" - <> "Mismatched file size from " - <> fromString (toFilePath path) - <> "\nExpected: " - <> display mismatchExpected - <> "\nActual: " - <> display mismatchActual - display (UnknownArchiveType loc) = - "Error: [S-372]\n" - <> "Unable to determine archive type of: " - <> display loc - display (InvalidTarFileType loc fp x) = - "Error: [S-950]\n" - <> "Unsupported tar file type in archive " - <> display loc - <> " at file " - <> fromString fp - <> ": " - <> displayShow x - display (UnsupportedTarball loc err) = - "Error: [S-760]\n" - <> "Unsupported tarball from " - <> display loc - <> ": " - <> display err - display (NoHackageCryptographicHash ident) = - "Error: [S-922]\n" - <> "No cryptographic hash found for Hackage package " - <> fromString (packageIdentifierString ident) - display (FailedToCloneRepo repo) = - "Error: [S-109]\n" - <> "Failed to clone repo " - <> display repo - display (TreeReferencesMissingBlob loc sfp key) = - "Error: [S-237]\n" - <> "The package " - <> display loc - <> " needs blob " - <> display key - <> " for file path " - <> display sfp - <> ", but the blob is not available" - display (CompletePackageMetadataMismatch loc pm) = - "Error: [S-984]\n" - <> "When completing package metadata for " - <> display loc - <> ", some values changed in the new package metadata: " - <> display pm - display (CRC32Mismatch loc fp Mismatch {..}) = - "Error: [S-607]\n" - <> "CRC32 mismatch in ZIP file from " - <> display loc - <> " on internal file " - <> fromString fp - <> "\nExpected: " - <> display mismatchExpected - <> "\nActual: " - <> display mismatchActual - display (UnknownHackagePackage pir fuzzy) = - "Error: [S-476]\n" - <> "Could not find " - <> display pir - <> " on Hackage" - <> displayFuzzy fuzzy - display (CannotCompleteRepoNonSHA1 repo) = - "Error: [S-112]\n" - <> "Cannot complete repo information for a non SHA1 commit due to non-reproducibility: " - <> display repo - display (MutablePackageLocationFromUrl t) = - "Error: [S-321]\n" - <> "Cannot refer to a mutable package location from a URL: " - <> display t - display (MismatchedCabalFileForHackage pir Mismatch{..}) = - "Error: [S-377]\n" - <> "When processing cabal file for Hackage package " - <> display pir - <> ":\nMismatched package identifier." - <> "\nExpected: " - <> fromString (packageIdentifierString mismatchExpected) - <> "\nActual: " - <> fromString (packageIdentifierString mismatchActual) - display (PackageNameParseFail t) = - "Error: [S-580]\n" - <> "Invalid package name: " - <> display t - display (PackageVersionParseFail t) = - "Error: [S-479]\n" - <> "Invalid version: " - <> display t - display (InvalidCabalFilePath fp) = - "Error: [S-824]\n" - <> "File path contains a name which is not a valid package name: " - <> fromString (toFilePath fp) - display (DuplicatePackageNames source pairs') = - "Error: [S-674]\n" - <> "Duplicate package names (" - <> source - <> "):\n" - <> foldMap - ( \(name, locs) -> - fromString (packageNameString name) - <> ":\n" - <> foldMap (\loc -> "- " <> display loc <> "\n") locs - ) - pairs' - display (MigrationFailure desc fp err) = - "Error: [S-536]\n" - <> "Encountered error while migrating database " - <> display desc - <> "\nlocated at " - <> fromString (toFilePath fp) - <> ":" - <> "\n " - <> displayShow err - display (ParseSnapNameException t) = - "Error: [S-994]\n" - <> "Invalid snapshot name: " - <> display t - display (HpackLibraryException file err) = - "Error: [S-305]\n" - <> "Failed to generate a Cabal file using the Hpack library on file:\n" - <> fromString (toFilePath file) - <> "\n\n" - <> "The error encountered was:\n\n" - <> fromString err - display (HpackExeException fp dir err) = - "Error: [S-720]\n" - <> "Failed to generate a Cabal file using the Hpack executable:\n" - <> fromString fp - <> "in directory: " - <> fromString (toFilePath dir) - <> "\n\n" - <> "The error encountered was:\n\n" - <> fromString (show err) - --- See also the instance of Display. Although prettier, these messages are --- intended to be substantively the same as the corresponding 'black and white' --- versions. -instance Pretty PantryException where - pretty (InvalidTreeFromCasa blobKey _bs) = - "[S-258]" - <> line - <> fillSep - [ flow "Invalid tree from casa:" - , fromString . T.unpack $ textDisplay blobKey - ] - pretty (PackageIdentifierRevisionParseFail text) = - "[S-360]" - <> line - <> fillSep - [ flow "Invalid package identifier (with optional revision):" - , fromString $ T.unpack text - ] - pretty (InvalidCabalFile loc mversion errs warnings) = - "[S-242]" - <> line - <> fillSep - [ flow "Unable to parse Cabal file from package" - , either pretty pretty loc <> ":" - ] - <> line - <> bulletedList - ( map (\(PError pos msg) -> fillSep - [ fromString (showPos pos) <> ":" - , fromString msg - ]) - errs - ) - <> line - <> bulletedList - ( map (\(PWarning _ pos msg) -> fillSep - [ fromString (showPos pos) <> ":" - , fromString msg - ]) - warnings - ) - <> ( case mversion of - Just version | version > cabalSpecLatestVersion -> - line - <> fillSep - [ flow "The Cabal file uses the Cabal specification version" - , style Current (fromString $ versionString version) <> "," - , flow "but we only support up to version" - , fromString (versionString cabalSpecLatestVersion) <> "." - , flow "Recommended action: upgrade your build tool" - , parens (fillSep - [ "e.g." - , style Shell (flow "stack upgrade") - ]) <> "." - ] - _ -> mempty - ) - pretty (TreeWithoutCabalFile loc) = - "[S-654]" - <> line - <> fillSep - [ flow "No Cabal file found for" - , pretty loc <> "." - ] - pretty (TreeWithMultipleCabalFiles loc sfps) = - "[S-500]" - <> line - <> fillSep - ( flow "Multiple Cabal files found for" - : (pretty loc <> ":") - : mkNarrativeList (Just File) False - (map (fromString . T.unpack . textDisplay) sfps :: [StyleDoc]) - ) - pretty (MismatchedCabalName fp name) = - "[S-910]" - <> line - <> fillSep - [ flow "The Cabal file" - , pretty fp - , flow "is not named after the package that it defines. Please rename" - , flow "the file to" - , style File (fromString $ packageNameString name <> ".cabal") <> "." - , flow "Hackage rejects packages where the first part of the Cabal" - , flow "file name is not the package name." - ] - pretty (NoLocalPackageDirFound dir) = - "[S-395]" - <> line - <> fillSep - [ flow "Stack looks for packages in the directories configured in the" - , style Shell "packages" - , "and" - , style Shell "extra-deps" - , flow "fields defined in your" - , style File "stack.yaml" <> "." - , flow "The current entry points to" - , pretty dir - , flow "but no such directory could be found. If, alternatively, a" - , flow "package in the package index was intended, its name and" - , flow "version must be specified as an extra-dep." - ] - pretty (NoCabalFileFound dir) = - "[S-636]" - <> line - <> fillSep - [ flow "Stack looks for packages in the directories configured in the" - , style Shell "packages" - , "and" - , style Shell "extra-deps" - , flow "fields defined in your" - , style File "stack.yaml" <> "." - , flow "The current entry points to" - , pretty dir - , flow "but no Cabal file or" - , style File "package.yaml" - , flow "could be found there." - ] - pretty (MultipleCabalFilesFound dir files) = - "[S-368]" - <> line - <> fillSep - ( flow "Multiple Cabal files found in directory" - : (pretty dir <> ":") - : mkNarrativeList (Just File) False - (map (pretty . filename) files) - ) - pretty (InvalidWantedCompiler t) = - "[S-204]" - <> line - <> fillSep - [ flow "Invalid wanted compiler:" - , style Current (fromString $ T.unpack t) <> "." - ] - pretty (InvalidSnapshotLocation dir t) = - "[S-935]" - <> line - <> fillSep - [ flow "Invalid snapshot location" - , style Current (fromString $ T.unpack t) - , flow "relative to directory" - , pretty dir <> "." - ] - pretty (InvalidOverrideCompiler x y) = - "[S-287]" - <> line - <> fillSep - [ flow "Specified compiler for a resolver" - , parens (style Shell (fromString . T.unpack $ textDisplay x)) - , flow "but also specified an override compiler" - , parens (style Shell (fromString . T.unpack $ textDisplay y)) <> "." - ] - pretty (InvalidFilePathSnapshot t) = - "[S-617]" - <> line - <> fillSep - [ flow "Specified snapshot as file path with" - , style File (fromString $ T.unpack t) <> "," - , flow "but not reading from a local file." - ] - pretty (InvalidSnapshot loc err) = - "[S-775]" - <> line - <> fillSep - [ flow "Exception while reading snapshot from" - , pretty loc <> ":" - ] - <> blankLine - <> string (displayException err) - pretty (MismatchedPackageMetadata loc pm mtreeKey foundIdent) = - "[S-427]" - <> line - <> fillSep - [ flow "Mismatched package metadata for" - , pretty loc <> "." - ] - <> blankLine - <> hang 10 (fillSep - [ "Expected:" - , let t = textDisplay pm - in if T.null t - then "nothing." - else fromString $ T.unpack t <> "." - ]) - <> line - <> hang 10 (fillSep - [ "Found: " - , fromString $ packageIdentifierString foundIdent <> case mtreeKey of - Nothing -> "." - _ -> mempty - , case mtreeKey of - Nothing -> mempty - Just treeKey -> fillSep - [ "with tree" - , fromString . T.unpack $ textDisplay treeKey <> "." - ] - ]) - pretty (Non200ResponseStatus status) = - "[S-571]" - <> line - <> fillSep - [ flow "Unexpected non-200 HTTP status code:" - , (fromString . show $ statusCode status) <> "." - ] - pretty (InvalidBlobKey Mismatch{..}) = - "[S-236]" - <> line - <> fillSep - [ flow "Invalid blob key found, expected:" - , fromString . T.unpack $ textDisplay mismatchExpected <> "," - , "actual:" - , fromString . T.unpack $ textDisplay mismatchActual <> "." - ] - pretty (Couldn'tParseSnapshot sl err) = - "[S-645]" - <> line - <> fillSep - [ flow "Couldn't parse snapshot from" - , pretty sl <> ":" - ] - <> blankLine - <> string err - pretty (WrongCabalFileName loc sfp name) = - "[S-575]" - <> line - <> fillSep - [ flow "Wrong Cabal file name for package" - , pretty loc <> "." - , flow "The Cabal file is named" - , style File (fromString . T.unpack $ textDisplay sfp) <> "," - , flow "but package name is" - , fromString (packageNameString name) <> "." - , flow "For more information, see" - , style Url "https://github.com/commercialhaskell/stack/issues/317" - , "and" - , style Url "https://github.com/commercialhaskell/stack/issues/895" <> "." - ] - pretty (DownloadInvalidSHA256 url Mismatch {..}) = - "[S-394]" - <> line - <> fillSep - [ flow "Mismatched SHA256 hash from" - , style Url (fromString $ T.unpack url) <> "." - ] - <> blankLine - <> hang 10 (fillSep - [ "Expected:" - , fromString . T.unpack $ textDisplay mismatchExpected <> "." - ]) - <> line - <> hang 10 (fillSep - [ "Actual: " - , fromString . T.unpack $ textDisplay mismatchActual <> "." - ]) - pretty (DownloadInvalidSize url Mismatch {..}) = - "[S-401]" - <> line - <> fillSep - [ flow "Mismatched download size from" - , style Url (fromString $ T.unpack url) <> "." - ] - <> blankLine - <> hang 10 (fillSep - [ "Expected:" - , fromString . T.unpack $ textDisplay mismatchExpected <> "." - ]) - <> line - <> hang 10 (fillSep - [ "Actual: " - , fromString . T.unpack $ textDisplay mismatchActual <> "." - ]) - pretty (DownloadTooLarge url Mismatch {..}) = - "[S-113]" - <> line - <> fillSep - [ flow "Download from" - , style Url (fromString $ T.unpack url) - , flow "was too large. Expected:" - , fromString . T.unpack $ textDisplay mismatchExpected <> "," - , flow "stopped after receiving:" - , fromString . T.unpack $ textDisplay mismatchActual <> "." - ] - pretty (LocalInvalidSHA256 path Mismatch {..}) = - "[S-834]" - <> line - <> fillSep - [ flow "Mismatched SHA256 hash from" - , pretty path <> "." - ] - <> blankLine - <> hang 10 (fillSep - [ "Expected:" - , fromString . T.unpack $ textDisplay mismatchExpected <> "." - ]) - <> line - <> hang 10 (fillSep - [ "Actual: " - , fromString . T.unpack $ textDisplay mismatchActual <> "." - ]) - pretty (LocalInvalidSize path Mismatch {..}) = - "[S-713]" - <> line - <> fillSep - [ flow "Mismatched file size from" - , pretty path <> "." - ] - <> blankLine - <> hang 10 (fillSep - [ "Expected:" - , fromString . T.unpack $ textDisplay mismatchExpected <> "." - ]) - <> line - <> hang 10 (fillSep - [ "Actual: " - , fromString . T.unpack $ textDisplay mismatchActual <> "." - ]) - pretty (UnknownArchiveType loc) = - "[S-372]" - <> line - <> fillSep - [ flow "Unable to determine archive type of:" - , pretty loc <> "." - ] - pretty (InvalidTarFileType loc fp x) = - "[S-950]" - <> line - <> fillSep - [ flow "Unsupported tar file type in archive" - , pretty loc - , flow "at file" - , style File (fromString fp) <> ":" - , fromString $ show x <> "." - ] - pretty (UnsupportedTarball loc err) = - "[S-760]" - <> line - <> fillSep - [ flow "Unsupported tarball from" - , pretty loc <> ":" - ] - <> blankLine - <> string (T.unpack err) - pretty (NoHackageCryptographicHash ident) = - "[S-922]" - <> line - <> fillSep - [ flow "No cryptographic hash found for Hackage package" - , fromString (packageIdentifierString ident) <> "." - ] - pretty (FailedToCloneRepo repo) = - "[S-109]" - <> line - <> fillSep - [ flow "Failed to clone repository" - , fromString . T.unpack $ textDisplay repo - ] - pretty (TreeReferencesMissingBlob loc sfp key) = - "[S-237]" - <> line - <> fillSep - [ flow "The package" - , pretty loc - , flow "needs blob" - , fromString . T.unpack $ textDisplay key - , flow "for file path" - , style File (fromString . T.unpack $ textDisplay sfp) <> "," - , flow "but the blob is not available." - ] - pretty (CompletePackageMetadataMismatch loc pm) = - "[S-984]" - <> line - <> fillSep - [ flow "When completing package metadata for" - , pretty loc <> "," - , flow "some values changed in the new package metadata:" - , fromString . T.unpack $ textDisplay pm <> "." - ] - pretty (CRC32Mismatch loc fp Mismatch {..}) = - "[S-607]" - <> line - <> fillSep - [ flow "CRC32 mismatch in Zip file from" - , pretty loc - , flow "on internal file" - , style File (fromString fp) - ] - <> blankLine - <> hang 10 (fillSep - [ "Expected:" - , fromString . T.unpack $ textDisplay mismatchExpected <> "." - ]) - <> line - <> hang 10 (fillSep - [ "Actual: " - , fromString . T.unpack $ textDisplay mismatchActual <> "." - ]) - pretty (UnknownHackagePackage pir fuzzy) = - "[S-476]" - <> line - <> fillSep - [ flow "Could not find" - , style Error (fromString . T.unpack $ textDisplay pir) - , flow "on Hackage." - ] - <> prettyFuzzy fuzzy - pretty (CannotCompleteRepoNonSHA1 repo) = - "[S-112]" - <> line - <> fillSep - [ flow "Cannot complete repo information for a non SHA1 commit due to" - , "non-reproducibility:" - , fromString . T.unpack $ textDisplay repo <> "." - ] - pretty (MutablePackageLocationFromUrl t) = - "[S-321]" - <> line - <> fillSep - [ flow "Cannot refer to a mutable package location from a URL:" - , style Url (fromString $ T.unpack t) <> "." - ] - pretty (MismatchedCabalFileForHackage pir Mismatch{..}) = - "[S-377]" - <> line - <> fillSep - [ flow "When processing Cabal file for Hackage package" - , fromString . T.unpack $ textDisplay pir <> "," - , flow "mismatched package identifier." - ] - <> blankLine - <> hang 10 (fillSep - [ "Expected:" - , fromString (packageIdentifierString mismatchExpected) <> "." - ]) - <> line - <> hang 10 (fillSep - [ "Actual: " - , fromString (packageIdentifierString mismatchActual) <> "." - ]) - pretty (PackageNameParseFail t) = - "[S-580]" - <> line - <> fillSep - [ flow "Invalid package name:" - , fromString $ T.unpack t <> "." - ] - pretty (PackageVersionParseFail t) = - "[S-479]" - <> line - <> fillSep - [ flow "Invalid version:" - , fromString $ T.unpack t <> "." - ] - pretty (InvalidCabalFilePath fp) = - "[S-824]" - <> line - <> fillSep - [ flow "File path contains a name which is not a valid package name:" - , pretty fp <> "." - ] - pretty (DuplicatePackageNames source pairs') = - "[S-674]" - <> line - <> fillSep - [ flow "Duplicate package names" - , parens (fromString . T.unpack $ textDisplay source) <> ":" - ] - <> line - <> foldMap - ( \(name, locs) -> - fromString (packageNameString name) <> ":" - <> line - <> bulletedList (map pretty locs) - <> line - ) - pairs' - pretty (MigrationFailure desc fp err) = - "[S-536]" - <> line - <> fillSep - [ flow "Encountered error while migrating database" - , fromString $ T.unpack desc - , flow "located at" - , pretty fp <> ":" - ] - <> blankLine - <> string (displayException err) - pretty (ParseSnapNameException t) = - "[S-994]" - <> line - <> fillSep - [ flow "Invalid snapshot name:" - , fromString $ T.unpack t <> "." - ] - pretty (HpackLibraryException file err) = - "[S-305]" - <> line - <> fillSep - [ flow "Failed to generate a Cabal file using the Hpack library on" - , "file:" - , pretty file <> "." - , flow "The error encountered was:" - ] - <> blankLine - <> string err - pretty (HpackExeException fp dir err) = - "[S-720]" - <> line - <> fillSep - [ flow "Failed to generate a Cabal file using the Hpack executable:" - , style File (fromString fp) - , flow "in directory:" - , pretty dir <> "." - , flow "The error encountered was:" - ] - <> blankLine - <> string (displayException err) - -blankLine :: StyleDoc -blankLine = line <> line - -data FuzzyResults - = FRNameNotFound ![PackageName] - | FRVersionNotFound !(NonEmpty PackageIdentifierRevision) - | FRRevisionNotFound !(NonEmpty PackageIdentifierRevision) - -displayFuzzy :: FuzzyResults -> Utf8Builder -displayFuzzy (FRNameNotFound names) = - case NE.nonEmpty names of - Nothing -> "" - Just names' -> - "\nPerhaps you meant " <> - orSeparated (NE.map (fromString . packageNameString) names') <> - "?" -displayFuzzy (FRVersionNotFound pirs) = - "\nPossible candidates: " <> - commaSeparated (NE.map display pirs) <> - "." -displayFuzzy (FRRevisionNotFound pirs) = - "\nThe specified revision was not found.\nPossible candidates: " <> - commaSeparated (NE.map display pirs) <> - "." - -prettyFuzzy :: FuzzyResults -> StyleDoc -prettyFuzzy (FRNameNotFound names) = - case NE.nonEmpty names of - Nothing -> mempty - Just names' -> - line - <> fillSep - ( flow "Perhaps you meant one of" - : mkNarrativeList Nothing False - (NE.toList $ NE.map (fromString . packageNameString) names' :: [StyleDoc]) - ) -prettyFuzzy (FRVersionNotFound pirs) = - line - <> fillSep - ( flow "Possible candidates:" - : mkNarrativeList Nothing False - (NE.toList $ NE.map (fromString . T.unpack . textDisplay) pirs :: [StyleDoc]) - ) -prettyFuzzy (FRRevisionNotFound pirs) = - line - <> fillSep - ( flow "The specified revision was not found. Possible candidates:" - : mkNarrativeList Nothing False - (NE.toList $ NE.map (fromString . T.unpack . textDisplay) pirs :: [StyleDoc]) - ) - -orSeparated :: NonEmpty Utf8Builder -> Utf8Builder -orSeparated xs - | NE.length xs == 1 = NE.head xs - | NE.length xs == 2 = NE.head xs <> " or " <> NE.last xs - | otherwise = fold (intersperse ", " (NE.init xs)) <> ", or " <> NE.last xs - -commaSeparated :: NonEmpty Utf8Builder -> Utf8Builder -commaSeparated = fold . NE.intersperse ", " - -cabalSpecLatestVersion :: Version -cabalSpecLatestVersion = mkVersion $ cabalSpecToVersionDigits cabalSpecLatest - -#if !MIN_VERSION_Cabal(3,4,0) -cabalSpecToVersionDigits :: CabalSpecVersion -> [Int] -cabalSpecToVersionDigits CabalSpecV3_0 = [3,0] -cabalSpecToVersionDigits CabalSpecV2_4 = [2,4] -cabalSpecToVersionDigits CabalSpecV2_2 = [2,2] -cabalSpecToVersionDigits CabalSpecV2_0 = [2,0] -cabalSpecToVersionDigits CabalSpecV1_24 = [1,24] -cabalSpecToVersionDigits CabalSpecV1_22 = [1,22] -cabalSpecToVersionDigits CabalSpecV1_20 = [1,20] -cabalSpecToVersionDigits CabalSpecV1_18 = [1,18] -cabalSpecToVersionDigits CabalSpecV1_12 = [1,12] -cabalSpecToVersionDigits CabalSpecV1_10 = [1,10] -cabalSpecToVersionDigits CabalSpecV1_8 = [1,8] -cabalSpecToVersionDigits CabalSpecV1_6 = [1,6] -cabalSpecToVersionDigits CabalSpecV1_4 = [1,4] -cabalSpecToVersionDigits CabalSpecV1_2 = [1,2] -cabalSpecToVersionDigits CabalSpecV1_0 = [1,0] -#endif - -data BuildFile = BFCabal !SafeFilePath !TreeEntry - | BFHpack !TreeEntry -- We don't need SafeFilePath for Hpack since it has to be package.yaml file - deriving (Show, Eq) - -data FileType = FTNormal | FTExecutable - deriving (Show, Eq, Enum, Bounded, Ord) -instance PersistField FileType where - toPersistValue FTNormal = PersistInt64 1 - toPersistValue FTExecutable = PersistInt64 2 - - fromPersistValue v = do - i <- fromPersistValue v - case i :: Int64 of - 1 -> Right FTNormal - 2 -> Right FTExecutable - _ -> Left $ "Invalid FileType: " <> tshow i -instance PersistFieldSql FileType where - sqlType _ = SqlInt32 - -data TreeEntry = TreeEntry - { teBlob :: !BlobKey - , teType :: !FileType - } - deriving (Show, Eq, Ord) - -newtype SafeFilePath = SafeFilePath Text - deriving (Show, Eq, Ord, Display) - -instance PersistField SafeFilePath where - toPersistValue = toPersistValue . unSafeFilePath - fromPersistValue v = do - t <- fromPersistValue v - maybe (Left $ "Invalid SafeFilePath: " <> t) Right $ mkSafeFilePath t -instance PersistFieldSql SafeFilePath where - sqlType _ = SqlString - -unSafeFilePath :: SafeFilePath -> Text -unSafeFilePath (SafeFilePath t) = t - -safeFilePathToPath :: (MonadThrow m) => Path Abs Dir -> SafeFilePath -> m (Path Abs File) -safeFilePathToPath dir (SafeFilePath path) = do - fpath <- parseRelFile (T.unpack path) - return $ dir </> fpath - -mkSafeFilePath :: Text -> Maybe SafeFilePath -mkSafeFilePath t = do - guard $ not $ "\\" `T.isInfixOf` t - guard $ not $ "//" `T.isInfixOf` t - guard $ not $ "\n" `T.isInfixOf` t - guard $ not $ "\0" `T.isInfixOf` t - - (c, _) <- T.uncons t - guard $ c /= '/' - - guard $ all (not . T.all (== '.')) $ T.split (== '/') t - - Just $ SafeFilePath t - --- | SafeFilePath for `package.yaml` file. -hpackSafeFilePath :: SafeFilePath -hpackSafeFilePath = - let fpath = mkSafeFilePath (T.pack Hpack.packageConfig) - in case fpath of - Nothing -> error $ "hpackSafeFilePath: Not able to encode " <> (Hpack.packageConfig) - Just sfp -> sfp - --- | The hash of the binary representation of a 'Tree'. --- --- @since 0.1.0.0 -newtype TreeKey = TreeKey BlobKey - deriving (Show, Eq, Ord, Generic, Typeable, ToJSON, FromJSON, NFData, Display) - --- | Represents the contents of a tree, which is a mapping from --- relative file paths to 'TreeEntry's. --- --- @since 0.1.0.0 -newtype Tree - = TreeMap (Map SafeFilePath TreeEntry) - -- In the future, consider allowing more lax parsing - -- See: https://www.fpcomplete.com/blog/2018/07/pantry-part-2-trees-keys - -- TreeTarball !PackageTarball - deriving (Show, Eq, Ord) - -renderTree :: Tree -> ByteString -renderTree = BL.toStrict . toLazyByteString . go - where - go :: Tree -> Builder - go (TreeMap m) = "map:" <> Map.foldMapWithKey goEntry m - - goEntry sfp (TreeEntry (BlobKey sha (FileSize size')) ft) = - netstring (unSafeFilePath sfp) <> - byteString (SHA256.toRaw sha) <> - netword size' <> - (case ft of - FTNormal -> "N" - FTExecutable -> "X") - -netstring :: Text -> Builder -netstring t = - let bs = encodeUtf8 t - in netword (fromIntegral (B.length bs)) <> byteString bs - -netword :: Word -> Builder -netword w = wordDec w <> ":" - -parseTreeM :: MonadThrow m => (BlobKey, ByteString) -> m (TreeKey, Tree) -parseTreeM (blobKey, blob) = - case parseTree blob of - Nothing -> throwM (InvalidTreeFromCasa blobKey blob) - Just tree -> pure (TreeKey blobKey, tree) - -parseTree :: ByteString -> Maybe Tree -parseTree bs1 = do - tree <- parseTree' bs1 - let bs2 = renderTree tree - guard $ bs1 == bs2 - Just tree - -parseTree' :: ByteString -> Maybe Tree -parseTree' bs0 = do - entriesBS <- B.stripPrefix "map:" bs0 - TreeMap <$> loop Map.empty entriesBS - where - loop !m bs1 - | B.null bs1 = pure m - | otherwise = do - (sfpBS, bs2) <- takeNetstring bs1 - sfp <- - case decodeUtf8' sfpBS of - Left _ -> Nothing - Right sfpT -> mkSafeFilePath sfpT - (sha, bs3) <- takeSha bs2 - (size', bs4) <- takeNetword bs3 - (typeW, bs5) <- B.uncons bs4 - ft <- - case typeW of - 78 -> Just FTNormal -- 'N' - 88 -> Just FTExecutable -- 'X' - _ -> Nothing - let entry = TreeEntry (BlobKey sha (FileSize (fromIntegral size'))) ft - loop (Map.insert sfp entry m) bs5 - - takeNetstring bs1 = do - (size', bs2) <- takeNetword bs1 - guard $ B.length bs2 >= size' - Just $ B.splitAt size' bs2 - - takeSha bs = do - let (x, y) = B.splitAt 32 bs - x' <- either (const Nothing) Just (SHA256.fromRaw x) - Just (x', y) - - takeNetword = - go 0 - where - go !accum bs = do - (next, rest) <- B.uncons bs - if - | next == 58 -> pure (accum, rest) -- ':' - | next >= 48 && next <= 57 -> - go - (accum * 10 + fromIntegral (next - 48)) - rest - | otherwise -> Nothing - - {- -data PackageTarball = PackageTarball - { ptBlob :: !BlobKey - -- ^ Contains the tarball itself - , ptCabal :: !BlobKey - -- ^ Contains the cabal file contents - , ptSubdir :: !FilePath - -- ^ Subdir containing the files we want for this package. - -- - -- There must be precisely one file with a @.cabal@ file extension - -- located there. Thanks to Hackage revisions, its contents will be - -- overwritten by the value of @ptCabal@. - } - deriving Show - -} - --- | This is almost a copy of Cabal's parser for package identifiers, --- the main difference is in the fact that Stack requires version to be --- present while Cabal uses "null version" as a default value --- --- @since 0.1.0.0 -parsePackageIdentifier :: String -> Maybe PackageIdentifier -parsePackageIdentifier = either (const Nothing) Just . explicitEitherParsec (packageIdentifierParsec <* Parse.eof) - -packageIdentifierParsec :: ParsecParser PackageIdentifier -packageIdentifierParsec = do - ident@(PackageIdentifier _ v) <- parsec - - -- version is a required component of a package identifier for Stack - guard (v /= nullVersion) - - pure ident - --- | Parse a package name from a 'String'. --- --- @since 0.1.0.0 -parsePackageName :: String -> Maybe PackageName -parsePackageName = Distribution.Text.simpleParse - --- | Parse a package name from a 'String' throwing on failure --- --- @since 0.1.0.0 -parsePackageNameThrowing :: MonadThrow m => String -> m PackageName -parsePackageNameThrowing str = - case parsePackageName str of - Nothing -> throwM $ PackageNameParseFail $ T.pack str - Just pn -> pure pn - --- | Parse a version from a 'String'. --- --- @since 0.1.0.0 -parseVersion :: String -> Maybe Version -parseVersion = Distribution.Text.simpleParse - --- | Parse a package version from a 'String' throwing on failure --- --- @since 0.1.0.0 -parseVersionThrowing :: MonadThrow m => String -> m Version -parseVersionThrowing str = - case parseVersion str of - Nothing -> throwM $ PackageVersionParseFail $ T.pack str - Just v -> pure v - --- | Parse a version range from a 'String'. --- --- @since 0.1.0.0 -parseVersionRange :: String -> Maybe VersionRange -parseVersionRange = Distribution.Text.simpleParse - --- | Parse a module name from a 'String'. --- --- @since 0.1.0.0 -parseModuleName :: String -> Maybe ModuleName -parseModuleName = Distribution.Text.simpleParse - --- | Parse a flag name from a 'String'. --- --- @since 0.1.0.0 -parseFlagName :: String -> Maybe FlagName -parseFlagName = Distribution.Text.simpleParse - --- | Render a package name as a 'String'. --- --- @since 0.1.0.0 -packageNameString :: PackageName -> String -packageNameString = unPackageName - --- | Render a package identifier as a 'String'. --- --- @since 0.1.0.0 -packageIdentifierString :: PackageIdentifier -> String -packageIdentifierString = Distribution.Text.display - --- | Render a version as a 'String'. --- --- @since 0.1.0.0 -versionString :: Version -> String -versionString = Distribution.Text.display - --- | Render a flag name as a 'String'. --- --- @since 0.1.0.0 -flagNameString :: FlagName -> String -flagNameString = unFlagName - --- | Render a module name as a 'String'. --- --- @since 0.1.0.0 -moduleNameString :: ModuleName -> String -moduleNameString = Distribution.Text.display - -data OptionalSubdirs - = OSSubdirs !(NonEmpty Text) - | OSPackageMetadata !Text !RawPackageMetadata - -- ^ subdirectory and package metadata - deriving (Show, Eq, Generic) -instance NFData OptionalSubdirs - --- | Metadata provided by a config file for archives and repos. This --- information can be used for optimized lookups of information like --- package identifiers, or for validating that the user configuration --- has the expected information. --- --- @since 0.1.0.0 -data RawPackageMetadata = RawPackageMetadata - { rpmName :: !(Maybe PackageName) - -- ^ Package name in the cabal file - -- - -- @since 0.1.0.0 - , rpmVersion :: !(Maybe Version) - -- ^ Package version in the cabal file - -- - -- @since 0.1.0.0 - , rpmTreeKey :: !(Maybe TreeKey) - -- ^ Tree key of the loaded up package - -- - -- @since 0.1.0.0 - } - deriving (Show, Eq, Ord, Generic, Typeable) -instance NFData RawPackageMetadata - -instance Display RawPackageMetadata where - display rpm = fold $ intersperse ", " $ catMaybes - [ (\name -> "name == " <> fromString (packageNameString name)) <$> rpmName rpm - , (\version -> "version == " <> fromString (versionString version)) <$> rpmVersion rpm - , (\tree -> "tree == " <> display tree) <$> rpmTreeKey rpm - ] - --- | Exact metadata specifying concrete package --- --- @since 0.1.0.0 -data PackageMetadata = PackageMetadata - { pmIdent :: !PackageIdentifier - -- ^ Package identifier in the cabal file - -- - -- @since 0.1.0.0 - , pmTreeKey :: !TreeKey - -- ^ Tree key of the loaded up package - -- - -- @since 0.1.0.0 - } - deriving (Show, Eq, Ord, Generic, Typeable) --- i PackageMetadata -instance NFData PackageMetadata - -instance Display PackageMetadata where - display pm = fold $ intersperse ", " $ - [ "ident == " <> fromString (packageIdentifierString $ pmIdent pm) - , "tree == " <> display (pmTreeKey pm) - ] - -parsePackageMetadata :: Object -> WarningParser PackageMetadata -parsePackageMetadata o = do - _oldCabalFile :: Maybe BlobKey <- o ..:? "cabal-file" - pantryTree :: BlobKey <- o ..: "pantry-tree" - CabalString pkgName <- o ..: "name" - CabalString pkgVersion <- o ..: "version" - let pmTreeKey = TreeKey pantryTree - pmIdent = PackageIdentifier {..} - pure PackageMetadata {..} - - --- | Convert package metadata to its "raw" equivalent. --- --- @since 0.1.0.0 -toRawPM :: PackageMetadata -> RawPackageMetadata -toRawPM pm = RawPackageMetadata (Just name) (Just version) (Just $ pmTreeKey pm) - where - PackageIdentifier name version = pmIdent pm - --- | File path relative to the configuration file it was parsed from --- --- @since 0.1.0.0 -newtype RelFilePath = RelFilePath Text - deriving (Show, ToJSON, FromJSON, Eq, Ord, Generic, Typeable, NFData, Display) - --- | Location that an archive is stored at --- --- @since 0.1.0.0 -data ArchiveLocation - = ALUrl !Text - -- ^ Archive stored at an HTTP(S) URL - -- - -- @since 0.1.0.0 - | ALFilePath !(ResolvedPath File) - -- ^ Archive stored at a local file path - -- - -- @since 0.1.0.0 - deriving (Show, Eq, Ord, Generic, Typeable) -instance NFData ArchiveLocation - -instance Display ArchiveLocation where - display (ALUrl url) = display url - display (ALFilePath resolved) = fromString $ toFilePath $ resolvedAbsolute resolved - -instance Pretty ArchiveLocation where - pretty (ALUrl url) = style Url (fromString $ T.unpack url) - pretty (ALFilePath resolved) = pretty $ resolvedAbsolute resolved - -parseArchiveLocationObject :: Object -> WarningParser (Unresolved ArchiveLocation) -parseArchiveLocationObject o = - ((o ..: "url") >>= either (fail . T.unpack) pure . validateUrl) <|> - ((o ..: "filepath") >>= either (fail . T.unpack) pure . validateFilePath) <|> - ((o ..: "archive") >>= either (fail . T.unpack) pure . parseArchiveLocationText) <|> - ((o ..: "location") >>= either (fail . T.unpack) pure . parseArchiveLocationText) - -parseArchiveLocationText :: Text -> Either Text (Unresolved ArchiveLocation) -parseArchiveLocationText t = - case validateUrl t of - Left e1 -> - case validateFilePath t of - Left e2 -> Left $ T.unlines - [ "Invalid archive location, neither a URL nor a file path" - , " URL error: " <> e1 - , " File path error: " <> e2 - ] - Right x -> Right x - Right x -> Right x - -validateUrl :: Text -> Either Text (Unresolved ArchiveLocation) -validateUrl t = - case parseRequest $ T.unpack t of - Left _ -> Left $ "Could not parse URL: " <> t - Right _ -> pure $ pure $ ALUrl t - -validateFilePath :: Text -> Either Text (Unresolved ArchiveLocation) -validateFilePath t = - if any (\ext -> ext `T.isSuffixOf` t) (T.words ".zip .tar .tar.gz") - then pure $ Unresolved $ \mdir -> - case mdir of - Nothing -> throwIO $ InvalidFilePathSnapshot t - Just dir -> do - abs' <- resolveFile dir $ T.unpack t - pure $ ALFilePath $ ResolvedPath (RelFilePath t) abs' - else Left $ "Does not have an archive file extension: " <> t - -instance ToJSON RawPackageLocation where - toJSON (RPLImmutable rpli) = toJSON rpli - toJSON (RPLMutable resolved) = toJSON (resolvedRelative resolved) -instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocation))) where - parseJSON v = - ((fmap.fmap.fmap.fmap) RPLImmutable (parseJSON v)) <|> - ((noJSONWarnings . mkMutable) <$> parseJSON v) - where - mkMutable :: Text -> Unresolved (NonEmpty RawPackageLocation) - mkMutable t = Unresolved $ \mdir -> do - case mdir of - Nothing -> throwIO $ MutablePackageLocationFromUrl t - Just dir -> do - abs' <- resolveDir dir $ T.unpack t - pure $ pure $ RPLMutable $ ResolvedPath (RelFilePath t) abs' - -instance ToJSON RawPackageLocationImmutable where - toJSON (RPLIHackage pir mtree) = object $ concat - [ ["hackage" .= pir] - , maybe [] (\tree -> ["pantry-tree" .= tree]) mtree - ] - toJSON (RPLIArchive (RawArchive loc msha msize subdir) rpm) = object $ concat - [ case loc of - ALUrl url -> ["url" .= url] - ALFilePath resolved -> ["filepath" .= resolvedRelative resolved] - , maybe [] (\sha -> ["sha256" .= sha]) msha - , maybe [] (\size' -> ["size" .= size']) msize - , if T.null subdir then [] else ["subdir" .= subdir] - , rpmToPairs rpm - ] - toJSON (RPLIRepo (Repo url commit typ subdir) rpm) = object $ concat - [ [ urlKey .= url - , "commit" .= commit - ] - , if T.null subdir then [] else ["subdir" .= subdir] - , rpmToPairs rpm - ] - where - urlKey = - case typ of - RepoGit -> "git" - RepoHg -> "hg" - -rpmToPairs :: RawPackageMetadata -> [(AesonKey, Value)] -rpmToPairs (RawPackageMetadata mname mversion mtree) = concat - [ maybe [] (\name -> ["name" .= CabalString name]) mname - , maybe [] (\version -> ["version" .= CabalString version]) mversion - , maybe [] (\tree -> ["pantry-tree" .= tree]) mtree - ] - -instance FromJSON (WithJSONWarnings (Unresolved PackageLocationImmutable)) where - parseJSON v = repoObject v <|> archiveObject v <|> hackageObject v <|> github v - <|> fail ("Could not parse a UnresolvedPackageLocationImmutable from: " ++ show v) - where - repoObject :: Value -> Parser (WithJSONWarnings (Unresolved PackageLocationImmutable)) - repoObject = withObjectWarnings "UnresolvedPackageLocationImmutable.PLIRepo" $ \o -> do - pm <- parsePackageMetadata o - repoSubdir <- o ..:? "subdir" ..!= "" - repoCommit <- o ..: "commit" - (repoType, repoUrl) <- - (o ..: "git" >>= \url -> pure (RepoGit, url)) <|> - (o ..: "hg" >>= \url -> pure (RepoHg, url)) - pure $ pure $ PLIRepo Repo {..} pm - - archiveObject = - withObjectWarnings "UnresolvedPackageLocationImmutable.PLIArchive" $ \o -> do - pm <- parsePackageMetadata o - Unresolved mkArchiveLocation <- parseArchiveLocationObject o - archiveHash <- o ..: "sha256" - archiveSize <- o ..: "size" - archiveSubdir <- o ..:? "subdir" ..!= "" - pure $ Unresolved $ \mdir -> do - archiveLocation <- mkArchiveLocation mdir - pure $ PLIArchive Archive {..} pm - - hackageObject = - withObjectWarnings "UnresolvedPackagelocationimmutable.PLIHackage (Object)" $ \o -> do - treeKey <- o ..: "pantry-tree" - htxt <- o ..: "hackage" - case parseHackageText htxt of - Left e -> fail $ show e - Right (pkgIdentifier, blobKey) -> - pure $ pure $ PLIHackage pkgIdentifier blobKey (TreeKey treeKey) - - github value = - withObjectWarnings "UnresolvedPackagelocationimmutable.PLIArchive:github" (\o -> do - pm <- parsePackageMetadata o - GitHubRepo ghRepo <- o ..: "github" - commit <- o ..: "commit" - let archiveLocation = ALUrl $ T.concat - [ "https://github.com/" - , ghRepo - , "/archive/" - , commit - , ".tar.gz" - ] - archiveHash <- o ..: "sha256" - archiveSize <- o ..: "size" - archiveSubdir <- o ..:? "subdir" ..!= "" - pure $ pure $ PLIArchive Archive {..} pm) value - -instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) where - parseJSON v - = http v - <|> hackageText v - <|> hackageObject v - <|> repo v - <|> archiveObject v - <|> github v - <|> fail ("Could not parse a UnresolvedRawPackageLocationImmutable from: " ++ show v) - where - http :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) - http = withText "UnresolvedPackageLocationImmutable.RPLIArchive (Text)" $ \t -> - case parseArchiveLocationText t of - Left _ -> fail $ "Invalid archive location: " ++ T.unpack t - Right (Unresolved mkArchiveLocation) -> - pure $ noJSONWarnings $ Unresolved $ \mdir -> do - raLocation <- mkArchiveLocation mdir - let raHash = Nothing - raSize = Nothing - raSubdir = T.empty - pure $ pure $ RPLIArchive RawArchive {..} rpmEmpty - - hackageText = withText "UnresolvedPackageLocationImmutable.UPLIHackage (Text)" $ \t -> - case parsePackageIdentifierRevision t of - Left e -> fail $ show e - Right pir -> pure $ noJSONWarnings $ pure $ pure $ RPLIHackage pir Nothing - - hackageObject = withObjectWarnings "UnresolvedPackageLocationImmutable.UPLIHackage" $ \o -> (pure.pure) <$> (RPLIHackage - <$> o ..: "hackage" - <*> o ..:? "pantry-tree") - - optionalSubdirs :: Object -> WarningParser OptionalSubdirs - optionalSubdirs o = - -- if subdirs exists, it needs to be valid - case HM.lookup "subdirs" o of - Just v' -> do - tellJSONField "subdirs" - subdirs <- lift $ parseJSON v' - case NE.nonEmpty subdirs of - Nothing -> fail "Invalid empty subdirs" - Just x -> pure $ OSSubdirs x - Nothing -> OSPackageMetadata - <$> o ..:? "subdir" ..!= T.empty - <*> (rawPackageMetadataHelper - <$> (fmap unCabalString <$> (o ..:? "name")) - <*> (fmap unCabalString <$> (o ..:? "version")) - <*> o ..:? "pantry-tree" - <*> o ..:? "cabal-file") - - rawPackageMetadataHelper - :: Maybe PackageName - -> Maybe Version - -> Maybe TreeKey - -> Maybe BlobKey - -> RawPackageMetadata - rawPackageMetadataHelper name version pantryTree _ignoredCabalFile = - RawPackageMetadata name version pantryTree - - repo = withObjectWarnings "UnresolvedPackageLocationImmutable.UPLIRepo" $ \o -> do - (repoType, repoUrl) <- - ((RepoGit, ) <$> o ..: "git") <|> - ((RepoHg, ) <$> o ..: "hg") - repoCommit <- o ..: "commit" - os <- optionalSubdirs o - pure $ pure $ NE.map (\(repoSubdir, pm) -> RPLIRepo Repo {..} pm) (osToRpms os) - - archiveObject = withObjectWarnings "UnresolvedPackageLocationImmutable.RPLIArchive" $ \o -> do - Unresolved mkArchiveLocation <- parseArchiveLocationObject o - raHash <- o ..:? "sha256" - raSize <- o ..:? "size" - os <- optionalSubdirs o - pure $ Unresolved $ \mdir -> do - raLocation <- mkArchiveLocation mdir - pure $ NE.map (\(raSubdir, pm) -> RPLIArchive RawArchive {..} pm) (osToRpms os) - - github = withObjectWarnings "PLArchive:github" $ \o -> do - GitHubRepo ghRepo <- o ..: "github" - commit <- o ..: "commit" - let raLocation = ALUrl $ T.concat - [ "https://github.com/" - , ghRepo - , "/archive/" - , commit - , ".tar.gz" - ] - raHash <- o ..:? "sha256" - raSize <- o ..:? "size" - os <- optionalSubdirs o - pure $ pure $ NE.map (\(raSubdir, pm) -> RPLIArchive RawArchive {..} pm) (osToRpms os) - --- | Returns pairs of subdirectory and 'PackageMetadata'. -osToRpms :: OptionalSubdirs -> NonEmpty (Text, RawPackageMetadata) -osToRpms (OSSubdirs subdirs) = NE.map (, rpmEmpty) subdirs -osToRpms (OSPackageMetadata subdir rpm) = pure (subdir, rpm) - -rpmEmpty :: RawPackageMetadata -rpmEmpty = RawPackageMetadata Nothing Nothing Nothing - --- | Newtype wrapper for easier JSON integration with Cabal types. --- --- @since 0.1.0.0 -newtype CabalString a = CabalString { unCabalString :: a } - deriving (Show, Eq, Ord, Typeable) - --- I'd like to use coerce here, but can't due to roles. unsafeCoerce --- could work, but let's avoid unsafe code. - --- | Wrap the keys in a 'Map' with a 'CabalString' to get a 'ToJSON' --- instance. --- --- @since 0.1.0.0 -toCabalStringMap :: Map a v -> Map (CabalString a) v -toCabalStringMap = Map.mapKeysMonotonic CabalString - --- | Unwrap the 'CabalString' from the keys in a 'Map' to use a --- 'FromJSON' instance. --- --- @since 0.1.0.0 -unCabalStringMap :: Map (CabalString a) v -> Map a v -unCabalStringMap = Map.mapKeysMonotonic unCabalString - -instance Distribution.Pretty.Pretty a => ToJSON (CabalString a) where - toJSON = toJSON . Distribution.Text.display . unCabalString -instance Distribution.Pretty.Pretty a => ToJSONKey (CabalString a) where - toJSONKey = toJSONKeyText $ T.pack . Distribution.Text.display . unCabalString - -instance forall a. IsCabalString a => FromJSON (CabalString a) where - parseJSON = withText name $ \t -> - case cabalStringParser $ T.unpack t of - Nothing -> fail $ "Invalid " ++ name ++ ": " ++ T.unpack t - Just x -> pure $ CabalString x - where - name = cabalStringName (Nothing :: Maybe a) -instance forall a. IsCabalString a => FromJSONKey (CabalString a) where - fromJSONKey = - FromJSONKeyTextParser $ \t -> - case cabalStringParser $ T.unpack t of - Nothing -> fail $ "Invalid " ++ name ++ ": " ++ T.unpack t - Just x -> pure $ CabalString x - where - name = cabalStringName (Nothing :: Maybe a) - -class IsCabalString a where - cabalStringName :: proxy a -> String - cabalStringParser :: String -> Maybe a -instance IsCabalString PackageName where - cabalStringName _ = "package name" - cabalStringParser = parsePackageName -instance IsCabalString Version where - cabalStringName _ = "version" - cabalStringParser = parseVersion -instance IsCabalString VersionRange where - cabalStringName _ = "version range" - cabalStringParser = parseVersionRange -instance IsCabalString PackageIdentifier where - cabalStringName _ = "package identifier" - cabalStringParser = parsePackageIdentifier -instance IsCabalString FlagName where - cabalStringName _ = "flag name" - cabalStringParser = parseFlagName - --- | What to use for running hpack --- --- @since 0.1.0.0 -data HpackExecutable - = HpackBundled - -- ^ Compiled in library - | HpackCommand !FilePath - -- ^ Executable at the provided path - deriving (Show, Read, Eq, Ord) - - --- | Which compiler a snapshot wants to use. The build tool may elect --- to do some fuzzy matching of versions (e.g., allowing different --- patch versions). --- --- @since 0.1.0.0 -data WantedCompiler - = WCGhc !Version - | WCGhcGit !Text !Text - | WCGhcjs - !Version - !Version - -- ^ GHCJS version followed by GHC version - deriving (Show, Eq, Ord, Generic) - -instance NFData WantedCompiler -instance Display WantedCompiler where - display (WCGhc vghc) = "ghc-" <> fromString (versionString vghc) - display (WCGhcjs vghcjs vghc) = - "ghcjs-" <> fromString (versionString vghcjs) <> "_ghc-" <> fromString (versionString vghc) - display (WCGhcGit commit flavour) = - "ghc-git-" <> display commit <> "-" <> display flavour -instance ToJSON WantedCompiler where - toJSON = toJSON . utf8BuilderToText . display -instance FromJSON WantedCompiler where - parseJSON = withText "WantedCompiler" $ either (fail . show) pure . parseWantedCompiler -instance FromJSONKey WantedCompiler where - fromJSONKey = - FromJSONKeyTextParser $ \t -> - case parseWantedCompiler t of - Left e -> fail $ "Invalid WantedCompiler " ++ show t ++ ": " ++ show e - Right x -> pure x - --- | Parse a 'Text' into a 'WantedCompiler' value. --- --- @since 0.1.0.0 -parseWantedCompiler :: Text -> Either PantryException WantedCompiler -parseWantedCompiler t0 = maybe (Left $ InvalidWantedCompiler t0) Right $ - case T.stripPrefix "ghcjs-" t0 of - Just t1 -> parseGhcjs t1 - Nothing -> case T.stripPrefix "ghc-git-" t0 of - Just t1 -> parseGhcGit t1 - Nothing -> T.stripPrefix "ghc-" t0 >>= parseGhc - where - parseGhcjs t1 = do - let (ghcjsVT, t2) = T.break (== '_') t1 - ghcjsV <- parseVersion $ T.unpack ghcjsVT - ghcVT <- T.stripPrefix "_ghc-" t2 - ghcV <- parseVersion $ T.unpack ghcVT - pure $ WCGhcjs ghcjsV ghcV - parseGhcGit t1 = do - let (commit, flavour) = T.break (== '-') t1 - pure $ WCGhcGit commit (T.drop 1 flavour) - parseGhc = fmap WCGhc . parseVersion . T.unpack - -instance FromJSON (WithJSONWarnings (Unresolved RawSnapshotLocation)) where - parseJSON v = text v <|> obj v - where - text :: Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLocation)) - text = withText "UnresolvedSnapshotLocation (Text)" $ pure . noJSONWarnings . parseRawSnapshotLocation - - obj :: Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLocation)) - obj = withObjectWarnings "UnresolvedSnapshotLocation (Object)" $ \o -> - ((pure . RSLCompiler) <$> o ..: "compiler") <|> - ((\x y -> pure $ RSLUrl x y) <$> o ..: "url" <*> blobKey o) <|> - (parseRawSnapshotLocationPath <$> o ..: "filepath") - - blobKey o = do - msha <- o ..:? "sha256" - msize <- o ..:? "size" - case (msha, msize) of - (Nothing, Nothing) -> pure Nothing - (Just sha, Just size') -> pure $ Just $ BlobKey sha size' - (Just _sha, Nothing) -> fail "You must also specify the file size" - (Nothing, Just _) -> fail "You must also specify the file's SHA256" - -instance Display SnapshotLocation where - display (SLCompiler compiler) = display compiler - display (SLUrl url blob) = display url <> " (" <> display blob <> ")" - display (SLFilePath resolved) = display (resolvedRelative resolved) - --- | Parse a 'Text' into an 'Unresolved' 'RawSnapshotLocation'. --- --- @since 0.1.0.0 -parseRawSnapshotLocation :: Text -> Unresolved RawSnapshotLocation -parseRawSnapshotLocation t0 = fromMaybe (parseRawSnapshotLocationPath t0) $ - (either (const Nothing) (Just . pure . RSLCompiler) (parseWantedCompiler t0)) <|> - (pure <$> RSLSynonym <$> parseSnapName t0) <|> - parseGitHub <|> - parseUrl - where - parseGitHub = do - t1 <- T.stripPrefix "github:" t0 - let (user, t2) = T.break (== '/') t1 - t3 <- T.stripPrefix "/" t2 - let (repo, t4) = T.break (== ':') t3 - path <- T.stripPrefix ":" t4 - Just $ pure $ githubSnapshotLocation user repo path - - parseUrl = parseRequest (T.unpack t0) $> pure (RSLUrl t0 Nothing) - -parseRawSnapshotLocationPath :: Text -> Unresolved RawSnapshotLocation -parseRawSnapshotLocationPath t = - Unresolved $ \mdir -> - case mdir of - Nothing -> throwIO $ InvalidFilePathSnapshot t - Just dir -> do - abs' <- resolveFile dir (T.unpack t) `catchAny` \_ -> throwIO (InvalidSnapshotLocation dir t) - pure $ RSLFilePath $ ResolvedPath (RelFilePath t) abs' - -githubSnapshotLocation :: Text -> Text -> Text -> RawSnapshotLocation -githubSnapshotLocation user repo path = - let url = T.concat - [ "https://raw.githubusercontent.com/" - , user - , "/" - , repo - , "/master/" - , path - ] - in RSLUrl url Nothing - -defUser :: Text -defUser = "commercialhaskell" - -defRepo :: Text -defRepo = "stackage-snapshots" - --- | Default location of snapshot synonyms --- , i.e. commercialhaskell's GitHub repository. --- --- @since 0.5.0.0 -defaultSnapshotLocation - :: SnapName - -> RawSnapshotLocation -defaultSnapshotLocation (LTS x y) = - githubSnapshotLocation defUser defRepo $ - utf8BuilderToText $ - "lts/" <> display x <> "/" <> display y <> ".yaml" -defaultSnapshotLocation (Nightly date) = - githubSnapshotLocation defUser defRepo $ - utf8BuilderToText $ - "nightly/" <> display year <> "/" <> display month <> "/" <> display day <> ".yaml" - where - (year, month, day) = toGregorian date - --- | A snapshot synonym. --- It is expanded according to the field 'snapshotLocation' --- of a 'PantryConfig'. --- --- @ since 0.5.0.0 -data SnapName - -- | LTS Haskell snapshot, - -- displayed as @"lts-maj.min"@. - -- - -- @since 0.5.0.0 - = LTS - !Int -- ^ Major version - !Int -- ^ Minor version - -- | Stackage Nightly snapshot, - -- displayed as @"nighly-YYYY-MM-DD"@. - -- - -- @since 0.5.0.0 - | Nightly !Day - deriving (Eq, Ord, Generic) - -instance NFData SnapName - -instance Display SnapName where - display (LTS x y) = "lts-" <> display x <> "." <> display y - display (Nightly date) = "nightly-" <> displayShow date - -instance Show SnapName where - show = T.unpack . utf8BuilderToText . display - -instance ToJSON SnapName where - toJSON syn = String $ utf8BuilderToText $ display syn - --- | Parse the short representation of a 'SnapName'. --- --- @since 0.5.0.0 -parseSnapName :: MonadThrow m => Text -> m SnapName -parseSnapName t0 = - case lts <|> nightly of - Nothing -> throwM $ ParseSnapNameException t0 - Just sn -> return sn - where - lts = do - t1 <- T.stripPrefix "lts-" t0 - Right (x, t2) <- Just $ decimal t1 - t3 <- T.stripPrefix "." t2 - Right (y, "") <- Just $ decimal t3 - return $ LTS x y - nightly = do - t1 <- T.stripPrefix "nightly-" t0 - Nightly <$> readMaybe (T.unpack t1) - --- | Where to load a snapshot from in raw form --- (RSUrl could have a missing BlobKey) --- --- @since 0.1.0.0 -data RawSnapshotLocation - = RSLCompiler !WantedCompiler - -- ^ Don't use an actual snapshot, just a version of the compiler - -- with its shipped packages. - -- - -- @since 0.1.0.0 - | RSLUrl !Text !(Maybe BlobKey) - -- ^ Download the snapshot from the given URL. The optional - -- 'BlobKey' is used for reproducibility. - -- - -- @since 0.1.0.0 - | RSLFilePath !(ResolvedPath File) - -- ^ Snapshot at a local file path. - -- - -- @since 0.1.0.0 - | RSLSynonym !SnapName - -- ^ Snapshot synonym (LTS/Nightly). - -- - -- @since 0.5.0.0 - deriving (Show, Eq, Ord, Generic) - -instance NFData RawSnapshotLocation - -instance Display RawSnapshotLocation where - display (RSLCompiler compiler) = display compiler - display (RSLUrl url Nothing) = display url - display (RSLUrl url (Just blob)) = display url <> " (" <> display blob <> ")" - display (RSLFilePath resolved) = display (resolvedRelative resolved) - display (RSLSynonym syn) = display syn - -instance Pretty RawSnapshotLocation where - pretty (RSLCompiler compiler) = fromString . T.unpack $ textDisplay compiler - pretty (RSLUrl url Nothing) = style Url (fromString $ T.unpack url) - pretty (RSLUrl url (Just blob)) = fillSep - [ style Url (fromString $ T.unpack url) - , parens (fromString . T.unpack $ textDisplay blob) - ] - pretty (RSLFilePath resolved) = - style File (fromString . T.unpack $ textDisplay (resolvedRelative resolved)) - pretty (RSLSynonym syn) = - style Shell (fromString . T.unpack $ textDisplay syn) - -instance ToJSON RawSnapshotLocation where - toJSON (RSLCompiler compiler) = object ["compiler" .= compiler] - toJSON (RSLUrl url mblob) = object - $ "url" .= url - : maybe [] blobKeyPairs mblob - toJSON (RSLFilePath resolved) = object ["filepath" .= resolvedRelative resolved] - toJSON (RSLSynonym syn) = toJSON syn - --- | Where to load a snapshot from. --- --- @since 0.1.0.0 -data SnapshotLocation - = SLCompiler !WantedCompiler - -- ^ Don't use an actual snapshot, just a version of the compiler - -- with its shipped packages. - -- - -- @since 0.1.0.0 - | SLUrl !Text !BlobKey - -- ^ Download the snapshot from the given URL. The optional - -- 'BlobKey' is used for reproducibility. - -- - -- @since 0.1.0.0 - | SLFilePath !(ResolvedPath File) - -- ^ Snapshot at a local file path. - -- - -- @since 0.1.0.0 - deriving (Show, Eq, Ord, Generic) -instance NFData SnapshotLocation - -instance ToJSON SnapshotLocation where - toJSON sl = toJSON (toRawSL sl) - -instance FromJSON (WithJSONWarnings (Unresolved SnapshotLocation)) where - parseJSON v = file v <|> url v <|> compiler v - where - file = withObjectWarnings "SLFilepath" $ \o -> do - ufp <- o ..: "filepath" - pure $ Unresolved $ \mdir -> - case mdir of - Nothing -> throwIO $ InvalidFilePathSnapshot ufp - Just dir -> do - absolute <- resolveFile dir (T.unpack ufp) - let fp = ResolvedPath (RelFilePath ufp) absolute - pure $ SLFilePath fp - url = withObjectWarnings "SLUrl" $ \o -> do - url' <- o ..: "url" - sha <- o ..: "sha256" - size <- o ..: "size" - pure $ Unresolved $ \_ -> pure $ SLUrl url' (BlobKey sha size) - compiler = withObjectWarnings "SLCompiler" $ \o -> do - c <- o ..: "compiler" - pure $ Unresolved $ \_ -> pure $ SLCompiler c - --- | Convert snapshot location to its "raw" equivalent. --- --- @since 0.1.0.0 -toRawSL :: SnapshotLocation -> RawSnapshotLocation -toRawSL (SLCompiler c) = RSLCompiler c -toRawSL (SLUrl url blob) = RSLUrl url (Just blob) -toRawSL (SLFilePath fp) = RSLFilePath fp - --- | A flattened representation of all the layers in a snapshot. --- --- @since 0.1.0.0 -data RawSnapshot = RawSnapshot - { rsCompiler :: !WantedCompiler - -- ^ The compiler wanted for this snapshot. - , rsPackages :: !(Map PackageName RawSnapshotPackage) - -- ^ Packages available in this snapshot for installation. This will be - -- applied on top of any globally available packages. - , rsDrop :: !(Set PackageName) - -- ^ Global packages that should be dropped/ignored. - } - --- | A flattened representation of all the layers in a snapshot. --- --- @since 0.1.0.0 -data Snapshot = Snapshot - { snapshotCompiler :: !WantedCompiler - -- ^ The compiler wanted for this snapshot. - , snapshotPackages :: !(Map PackageName SnapshotPackage) - -- ^ Packages available in this snapshot for installation. This will be - -- applied on top of any globally available packages. - , snapshotDrop :: !(Set PackageName) - -- ^ Global packages that should be dropped/ignored. - } - --- | Settings for a package found in a snapshot. --- --- @since 0.1.0.0 -data RawSnapshotPackage = RawSnapshotPackage - { rspLocation :: !RawPackageLocationImmutable - -- ^ Where to get the package from - , rspFlags :: !(Map FlagName Bool) - -- ^ Same as 'slFlags' - , rspHidden :: !Bool - -- ^ Same as 'slHidden' - , rspGhcOptions :: ![Text] - -- ^ Same as 'slGhcOptions' - } - --- | Settings for a package found in a snapshot. --- --- @since 0.1.0.0 -data SnapshotPackage = SnapshotPackage - { spLocation :: !PackageLocationImmutable - -- ^ Where to get the package from - , spFlags :: !(Map FlagName Bool) - -- ^ Same as 'slFlags' - , spHidden :: !Bool - -- ^ Same as 'slHidden' - , spGhcOptions :: ![Text] - -- ^ Same as 'slGhcOptions' - } - deriving Show - --- | A single layer of a snapshot, i.e. a specific YAML configuration file. --- --- @since 0.1.0.0 -data RawSnapshotLayer = RawSnapshotLayer - { rslParent :: !RawSnapshotLocation - -- ^ The sl to extend from. This is either a specific - -- compiler, or a @SnapshotLocation@ which gives us more information - -- (like packages). Ultimately, we'll end up with a - -- @CompilerVersion@. - -- - -- @since 0.1.0.0 - , rslCompiler :: !(Maybe WantedCompiler) - -- ^ Override the compiler specified in 'slParent'. Must be - -- 'Nothing' if using 'SLCompiler'. - -- - -- @since 0.1.0.0 - , rslLocations :: ![RawPackageLocationImmutable] - -- ^ Where to grab all of the packages from. - -- - -- @since 0.1.0.0 - , rslDropPackages :: !(Set PackageName) - -- ^ Packages present in the parent which should not be included - -- here. - -- - -- @since 0.1.0.0 - , rslFlags :: !(Map PackageName (Map FlagName Bool)) - -- ^ Flag values to override from the defaults - -- - -- @since 0.1.0.0 - , rslHidden :: !(Map PackageName Bool) - -- ^ Packages which should be hidden when registering. This will - -- affect, for example, the import parser in the script - -- command. We use a 'Map' instead of just a 'Set' to allow - -- overriding the hidden settings in a parent sl. - -- - -- @since 0.1.0.0 - , rslGhcOptions :: !(Map PackageName [Text]) - -- ^ GHC options per package - -- - -- @since 0.1.0.0 - , rslPublishTime :: !(Maybe UTCTime) - -- ^ See 'slPublishTime' - -- - -- @since 0.1.0.0 - } - deriving (Show, Eq, Generic) - -instance NFData RawSnapshotLayer - -instance ToJSON RawSnapshotLayer where - toJSON rsnap = object $ concat - [ ["resolver" .= rslParent rsnap] - , maybe [] (\compiler -> ["compiler" .= compiler]) (rslCompiler rsnap) - , ["packages" .= rslLocations rsnap] - , if Set.null (rslDropPackages rsnap) - then [] - else ["drop-packages" .= Set.map CabalString (rslDropPackages rsnap)] - , if Map.null (rslFlags rsnap) - then [] - else ["flags" .= fmap toCabalStringMap (toCabalStringMap (rslFlags rsnap))] - , if Map.null (rslHidden rsnap) - then [] - else ["hidden" .= toCabalStringMap (rslHidden rsnap)] - , if Map.null (rslGhcOptions rsnap) - then [] - else ["ghc-options" .= toCabalStringMap (rslGhcOptions rsnap)] - , maybe [] (\time -> ["publish-time" .= time]) (rslPublishTime rsnap) - ] - -instance FromJSON (WithJSONWarnings (Unresolved RawSnapshotLayer)) where - parseJSON = withObjectWarnings "Snapshot" $ \o -> do - _ :: Maybe Text <- o ..:? "name" -- avoid warnings for old snapshot format - mcompiler <- o ..:? "compiler" - mresolver <- jsonSubWarningsT $ o ...:? ["snapshot", "resolver"] - unresolvedSnapshotParent <- - case (mcompiler, mresolver) of - (Nothing, Nothing) -> fail "Snapshot must have either resolver or compiler" - (Just compiler, Nothing) -> pure $ pure (RSLCompiler compiler, Nothing) - (_, Just (Unresolved usl)) -> pure $ Unresolved $ \mdir -> do - sl <- usl mdir - case (sl, mcompiler) of - (RSLCompiler c1, Just c2) -> throwIO $ InvalidOverrideCompiler c1 c2 - _ -> pure (sl, mcompiler) - - unresolvedLocs <- jsonSubWarningsT (o ..:? "packages" ..!= []) - rslDropPackages <- Set.map unCabalString <$> (o ..:? "drop-packages" ..!= Set.empty) - rslFlags <- (unCabalStringMap . fmap unCabalStringMap) <$> (o ..:? "flags" ..!= Map.empty) - rslHidden <- unCabalStringMap <$> (o ..:? "hidden" ..!= Map.empty) - rslGhcOptions <- unCabalStringMap <$> (o ..:? "ghc-options" ..!= Map.empty) - rslPublishTime <- o ..:? "publish-time" - pure $ (\rslLocations (rslParent, rslCompiler) -> RawSnapshotLayer {..}) - <$> ((concat . map NE.toList) <$> sequenceA unresolvedLocs) - <*> unresolvedSnapshotParent - --- | A single layer of a snapshot, i.e. a specific YAML configuration file. --- --- @since 0.1.0.0 -data SnapshotLayer = SnapshotLayer - { slParent :: !SnapshotLocation - -- ^ The sl to extend from. This is either a specific - -- compiler, or a @SnapshotLocation@ which gives us more information - -- (like packages). Ultimately, we'll end up with a - -- @CompilerVersion@. - -- - -- @since 0.1.0.0 - , slCompiler :: !(Maybe WantedCompiler) - -- ^ Override the compiler specified in 'slParent'. Must be - -- 'Nothing' if using 'SLCompiler'. - -- - -- @since 0.1.0.0 - , slLocations :: ![PackageLocationImmutable] - -- ^ Where to grab all of the packages from. - -- - -- @since 0.1.0.0 - , slDropPackages :: !(Set PackageName) - -- ^ Packages present in the parent which should not be included - -- here. - -- - -- @since 0.1.0.0 - , slFlags :: !(Map PackageName (Map FlagName Bool)) - -- ^ Flag values to override from the defaults - -- - -- @since 0.1.0.0 - , slHidden :: !(Map PackageName Bool) - -- ^ Packages which should be hidden when registering. This will - -- affect, for example, the import parser in the script - -- command. We use a 'Map' instead of just a 'Set' to allow - -- overriding the hidden settings in a parent sl. - -- - -- @since 0.1.0.0 - , slGhcOptions :: !(Map PackageName [Text]) - -- ^ GHC options per package - -- - -- @since 0.1.0.0 - , slPublishTime :: !(Maybe UTCTime) - -- ^ Publication timestamp for this snapshot. This field is optional, and - -- is for informational purposes only. - -- - -- @since 0.1.0.0 - } - deriving (Show, Eq, Generic) - -instance ToJSON SnapshotLayer where - toJSON snap = object $ concat - [ ["resolver" .= slParent snap] - , maybe [] (\compiler -> ["compiler" .= compiler]) (slCompiler snap) - , ["packages" .= slLocations snap] - , if Set.null (slDropPackages snap) then [] else ["drop-packages" .= Set.map CabalString (slDropPackages snap)] - , if Map.null (slFlags snap) then [] else ["flags" .= fmap toCabalStringMap (toCabalStringMap (slFlags snap))] - , if Map.null (slHidden snap) then [] else ["hidden" .= toCabalStringMap (slHidden snap)] - , if Map.null (slGhcOptions snap) then [] else ["ghc-options" .= toCabalStringMap (slGhcOptions snap)] - , maybe [] (\time -> ["publish-time" .= time]) (slPublishTime snap) - ] - --- | Convert snapshot layer into its "raw" equivalent. --- --- @since 0.1.0.0 -toRawSnapshotLayer :: SnapshotLayer -> RawSnapshotLayer -toRawSnapshotLayer sl = RawSnapshotLayer - { rslParent = toRawSL (slParent sl) - , rslCompiler = slCompiler sl - , rslLocations = map toRawPLI (slLocations sl) - , rslDropPackages = slDropPackages sl - , rslFlags = slFlags sl - , rslHidden = slHidden sl - , rslGhcOptions = slGhcOptions sl - , rslPublishTime = slPublishTime sl - } - --- | An arbitrary hash for a snapshot, used for finding module names --- in a snapshot. Mostly intended for Stack's usage. --- --- @since 0.1.0.0 -newtype SnapshotCacheHash = SnapshotCacheHash { unSnapshotCacheHash :: SHA256} - deriving (Show) - --- | Get the path to the global hints cache file -getGlobalHintsFile :: HasPantryConfig env => RIO env (Path Abs File) -getGlobalHintsFile = do - root <- view $ pantryConfigL.to pcRootDir - globalHintsRelFile <- parseRelFile "global-hints-cache.yaml" - pure $ root </> globalHintsRelFile - --- | Creates BlobKey for an input ByteString --- --- @since 0.1.0.0 -bsToBlobKey :: ByteString -> BlobKey -bsToBlobKey bs = - BlobKey (SHA256.hashBytes bs) (FileSize (fromIntegral (B.length bs))) - --- | Warn if the package uses 'PCHpack'. --- --- @since 0.4.0.0 -warnMissingCabalFile :: HasLogFunc env => RawPackageLocationImmutable -> RIO env () -warnMissingCabalFile loc = - logWarn $ - "DEPRECATED: The package at " <> display loc <> - " does not include a cabal file.\n" <> - "Instead, it includes an hpack package.yaml file for generating a cabal file.\n" <> - "This usage is deprecated; please see https://github.com/commercialhaskell/stack/issues/5210.\n" <> - "Support for this workflow will be removed in the future.\n" +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +module Pantry.Types + ( PantryConfig (..) + , PackageIndexConfig (..) + , HackageSecurityConfig (..) + , defaultHackageSecurityConfig + , Storage (..) + , HasPantryConfig (..) + , BlobKey (..) + , PackageName + , Version + , PackageIdentifier (..) + , Revision (..) + , ModuleName + , CabalFileInfo (..) + , PrintWarnings (..) + , PackageNameP (..) + , VersionP (..) + , ModuleNameP (..) + , PackageIdentifierRevision (..) + , pirForHash + , FileType (..) + , BuildFile (..) + , FileSize (..) + , TreeEntry (..) + , SafeFilePath + , unSafeFilePath + , mkSafeFilePath + , safeFilePathToPath + , hpackSafeFilePath + , TreeKey (..) + , Tree (..) + , renderTree + , parseTree + , parseTreeM + , SHA256 + , Unresolved + , resolvePaths + , Package (..) + , PackageCabal (..) + , PHpack (..) + -- , PackageTarball (..) + , RawPackageLocation (..) + , PackageLocation (..) + , toRawPL + , RawPackageLocationImmutable (..) + , PackageLocationImmutable (..) + , toRawPLI + , RawArchive (..) + , Archive (..) + , toRawArchive + , Repo (..) + , AggregateRepo (..) + , SimpleRepo (..) + , toAggregateRepos + , rToSimpleRepo + , arToSimpleRepo + , RepoType (..) + , parsePackageIdentifier + , parsePackageName + , parsePackageNameThrowing + , parseFlagName + , parseVersion + , parseVersionThrowing + , packageIdentifierString + , packageNameString + , flagNameString + , versionString + , moduleNameString + , OptionalSubdirs (..) + , ArchiveLocation (..) + , RelFilePath (..) + , CabalString (..) + , toCabalStringMap + , unCabalStringMap + , parsePackageIdentifierRevision + , Mismatch (..) + , PantryException (..) + , FuzzyResults (..) + , ResolvedPath (..) + , HpackExecutable (..) + , WantedCompiler (..) + --, resolveSnapshotLocation + , snapshotLocation + , defaultSnapshotLocation + , SnapName (..) + , parseSnapName + , RawSnapshotLocation (..) + , SnapshotLocation (..) + , toRawSL + , parseHackageText + , parseRawSnapshotLocation + , RawSnapshotLayer (..) + , SnapshotLayer (..) + , toRawSnapshotLayer + , RawSnapshot (..) + , Snapshot (..) + , RawSnapshotPackage (..) + , SnapshotPackage (..) + , parseWantedCompiler + , RawPackageMetadata (..) + , PackageMetadata (..) + , toRawPM + , cabalFileName + , SnapshotCacheHash (..) + , getGlobalHintsFile + , bsToBlobKey + , warnMissingCabalFile + , connRDBMS + ) where + +import Casa.Client ( CasaRepoPrefix ) +import Data.Aeson.Encoding.Internal ( unsafeToEncoding ) +import Data.Aeson.Types ( Parser, toJSONKeyText ) +import Data.ByteString.Builder + ( byteString, toLazyByteString, wordDec ) +import qualified Data.List.NonEmpty as NE +import Data.Text.Read ( decimal ) +import Distribution.CabalSpecVersion ( cabalSpecLatest ) +#if MIN_VERSION_Cabal(3,4,0) +import Distribution.CabalSpecVersion ( cabalSpecToVersionDigits ) +#else +import Distribution.CabalSpecVersion ( CabalSpecVersion (..) ) +#endif +import Distribution.ModuleName ( ModuleName ) +import Distribution.PackageDescription + ( FlagName, GenericPackageDescription, unFlagName ) +import Distribution.Parsec + ( PError (..), PWarning (..), ParsecParser + , explicitEitherParsec, parsec, showPos + ) +import qualified Distribution.Pretty +import qualified Distribution.Text +import Distribution.Types.PackageId ( PackageIdentifier (..) ) +import Distribution.Types.PackageName + ( PackageName, mkPackageName, unPackageName ) +import Distribution.Types.Version ( Version, mkVersion, nullVersion ) +import Distribution.Types.VersionRange ( VersionRange ) +import qualified Data.Conduit.Tar as Tar +import qualified Data.Map.Strict as Map ( mapKeysMonotonic ) +import Database.Persist +import Database.Persist.Sql +#if MIN_VERSION_persistent(2, 13, 0) +import Database.Persist.SqlBackend.Internal ( connRDBMS ) +#endif +import qualified Distribution.Compat.CharParsing as Parse +import qualified Hpack.Config as Hpack +import Network.HTTP.Client ( parseRequest ) +import Network.HTTP.Types ( Status, statusCode ) +import Pantry.Internal.AesonExtended + ( FromJSON (..), FromJSONKey (..), FromJSONKeyFunction (..) + , Object, ToJSON (..), ToJSONKey (..), ToJSONKeyFunction (..) + , Value (..), WarningParser, WithJSONWarnings, (..:), (..:?) + , (..!=), (.=), (.:), (...:?), jsonSubWarnings + , jsonSubWarningsT, noJSONWarnings, object, tellJSONField + , withObject, withObjectWarnings, withText + ) +import Pantry.SHA256 ( SHA256 ) +import qualified Pantry.SHA256 as SHA256 +import Path + ( Abs, Dir, File, Path, (</>), filename, parseRelFile + , toFilePath + ) +import Path.IO ( resolveDir, resolveFile ) +import qualified RIO.Set as Set +import RIO +import qualified RIO.ByteString as B +import qualified RIO.ByteString.Lazy as BL +import RIO.List ( groupBy, intersperse ) +import qualified RIO.Text as T +import RIO.Time ( Day, UTCTime, toGregorian ) +import qualified RIO.Map as Map +import RIO.PrettyPrint + ( bulletedList, fillSep, flow, hang, line, mkNarrativeList + , parens, string, style + ) +import RIO.PrettyPrint.Types ( Style (..) ) +import Text.PrettyPrint.Leijen.Extended ( Pretty (..), StyleDoc ) + +#if MIN_VERSION_aeson(2, 0, 0) +import qualified Data.Aeson.KeyMap as HM +import qualified Data.Aeson.Key + +type AesonKey = Data.Aeson.Key.Key +#else +import qualified RIO.HashMap as HM + +type AesonKey = Text +#endif + +-- | Parsed tree with more information on the Haskell package it contains. +-- +-- @since 0.1.0.0 +data Package = Package + { packageTreeKey :: !TreeKey + -- ^ The 'TreeKey' containing this package. + -- + -- This is a hash of the binary representation of 'packageTree'. + -- + -- @since 0.1.0.0 + , packageTree :: !Tree + -- ^ The 'Tree' containing this package. + -- + -- @since 0.1.0.0 + , packageCabalEntry :: !PackageCabal + -- ^ Information on the cabal file inside this package. + -- + -- @since 0.1.0.0 + , packageIdent :: !PackageIdentifier + -- ^ The package name and version in this package. + -- + -- @since 0.1.0.0 + } + deriving (Show, Eq, Ord) + +data PHpack = PHpack + { phOriginal :: !TreeEntry + -- ^ Original hpack file + , phGenerated :: !TreeEntry + -- ^ Generated Cabal file + , phVersion :: !Version + -- ^ Version of Hpack used + } + deriving (Show, Eq, Ord) + +data PackageCabal + = PCCabalFile !TreeEntry -- ^ TreeEntry of Cabal file + | PCHpack !PHpack + deriving (Show, Eq, Ord) + +cabalFileName :: PackageName -> SafeFilePath +cabalFileName name = + case mkSafeFilePath $ T.pack (packageNameString name) <> ".cabal" of + Nothing -> error $ "cabalFileName: failed for " ++ show name + Just sfp -> sfp + +-- | The revision number of a package from Hackage, counting upwards from 0 (the +-- original cabal file). +-- +-- See caveats on 'CFIRevision'. +-- +-- @since 0.1.0.0 +newtype Revision = Revision Word + deriving (Generic, Show, Eq, NFData, Data, Typeable, Ord, Hashable, Display, PersistField, PersistFieldSql) + +-- | Represents a SQL database connection. This used to be a newtype wrapper +-- around a connection pool. However, when investigating +-- <https://github.com/commercialhaskell/stack/issues/4471>, it appeared that +-- holding a pool resulted in overly long write locks being held on the +-- database. As a result, we now abstract away whether a pool is used, and the +-- default implementation in "Pantry.Storage" does not use a pool. +data Storage = Storage + { withStorage_ :: + forall env a. HasLogFunc env + => ReaderT SqlBackend (RIO env) a + -> RIO env a + , withWriteLock_ :: forall env a. HasLogFunc env => RIO env a -> RIO env a + } + +-- | Configuration value used by the entire pantry package. Create one using +-- 'withPantryConfig' or 'withPantryConfig''. See also 'PantryApp' for a +-- convenience approach to using pantry. +-- +-- @since 0.1.0.0 +data PantryConfig = PantryConfig + { pcPackageIndex :: !PackageIndexConfig + , pcHpackExecutable :: !HpackExecutable + , pcRootDir :: !(Path Abs Dir) + , pcStorage :: !Storage + , pcUpdateRef :: !(MVar Bool) + -- ^ Want to try updating the index once during a single run for missing + -- package identifiers. We also want to ensure we only update once at a + -- time. Start at @True@. + , pcParsedCabalFilesRawImmutable :: + !(IORef (Map RawPackageLocationImmutable GenericPackageDescription)) + -- ^ Cache of previously parsed cabal files, to save on slow parsing time. + , pcParsedCabalFilesMutable :: + !( IORef + ( Map + (Path Abs Dir) + ( PrintWarnings -> IO GenericPackageDescription + , PackageName + , Path Abs File + ) + ) + ) + -- ^ Cache for mutable packages. We want to allow for an optimization: + -- deferring parsing of the 'GenericPackageDescription' until its actually + -- needed. Therefore, we keep the filepath and the 'PackageName' derived + -- from that filepath. When the @IO GenericPackageDescription@ is run, it + -- will ensure that the @PackageName@ matches the value inside the cabal + -- file, and print out any warnings that still need to be printed. + , pcConnectionCount :: !Int + -- ^ concurrently open downloads + , pcCasaConfig :: !(Maybe (CasaRepoPrefix, Int)) + -- ^ Optionally, the Casa pull URL e.g. @https://casa.fpcomplete.com@ and + -- the maximum number of Casa keys to pull per request. + , pcSnapshotLocation :: SnapName -> RawSnapshotLocation + -- ^ The location of snapshot synonyms + } + +-- | Get the location of a snapshot synonym from the 'PantryConfig'. +-- +-- @since 0.5.0.0 +snapshotLocation :: + HasPantryConfig env + => SnapName + -> RIO env RawSnapshotLocation +snapshotLocation name = do + loc <- view $ pantryConfigL.to pcSnapshotLocation + pure $ loc name + +-- | Should we print warnings when loading a cabal file? +-- +-- @since 0.1.0.0 +data PrintWarnings = YesPrintWarnings | NoPrintWarnings + +-- | Wraps a value which potentially contains relative paths. Needs to be +-- provided with a base directory to resolve these paths. +-- +-- Unwrap this using 'resolvePaths'. +-- +-- @since 0.1.0.0 +newtype Unresolved a = Unresolved (Maybe (Path Abs Dir) -> IO a) + deriving Functor + +instance Applicative Unresolved where + pure = Unresolved . const . pure + Unresolved f <*> Unresolved x = Unresolved $ \mdir -> f mdir <*> x mdir + +-- | Resolve all of the file paths in an 'Unresolved' relative to the given +-- directory. +-- +-- @since 0.1.0.0 +resolvePaths :: + MonadIO m + => Maybe (Path Abs Dir) -- ^ directory to use for relative paths + -> Unresolved a + -> m a +resolvePaths mdir (Unresolved f) = liftIO (f mdir) + +-- | A combination of the relative path provided in a config file, together with +-- the resolved absolute path. +-- +-- @since 0.1.0.0 +data ResolvedPath t = ResolvedPath + { resolvedRelative :: !RelFilePath + -- ^ Original value parsed from a config file. + , resolvedAbsolute :: !(Path Abs t) + -- ^ Absolute path resolved against base directory loaded from. + } + deriving (Show, Eq, Generic, Ord) + +instance NFData (ResolvedPath t) + +-- | Location to load a package from. Can either be immutable (see +-- 'PackageLocationImmutable') or a local directory which is expected to change +-- over time. Raw version doesn't include exact package version (e.g. could +-- refer to the latest revision on Hackage) +-- +-- @since 0.1.0.0 +data RawPackageLocation + = RPLImmutable !RawPackageLocationImmutable + | RPLMutable !(ResolvedPath Dir) + deriving (Show, Eq, Generic) + +instance NFData RawPackageLocation + +-- | Location to load a package from. Can either be immutable (see +-- 'PackageLocationImmutable') or a local directory which is expected to change +-- over time. +-- +-- @since 0.1.0.0 +data PackageLocation + = PLImmutable !PackageLocationImmutable + | PLMutable !(ResolvedPath Dir) + deriving (Show, Eq, Generic) + +instance NFData PackageLocation + +instance Display PackageLocation where + display (PLImmutable loc) = display loc + display (PLMutable fp) = fromString $ toFilePath $ resolvedAbsolute fp + +-- | Convert `PackageLocation` to its "raw" equivalent +-- +-- @since 0.1.0.0 +toRawPL :: PackageLocation -> RawPackageLocation +toRawPL (PLImmutable im) = RPLImmutable (toRawPLI im) +toRawPL (PLMutable m) = RPLMutable m + +-- | Location for remote packages or archives assumed to be immutable. +-- as user specifies it i.e. not an exact location +-- +-- @since 0.1.0.0 +data RawPackageLocationImmutable + = RPLIHackage !PackageIdentifierRevision !(Maybe TreeKey) + | RPLIArchive !RawArchive !RawPackageMetadata + | RPLIRepo !Repo !RawPackageMetadata + deriving (Show, Eq, Ord, Generic) + +instance NFData RawPackageLocationImmutable + +instance Display RawPackageLocationImmutable where + display (RPLIHackage pir _tree) = display pir <> " (from Hackage)" + display (RPLIArchive archive _pm) = + "Archive from " <> display (raLocation archive) <> + (if T.null $ raSubdir archive + then mempty + else " in subdir " <> display (raSubdir archive)) + display (RPLIRepo repo _pm) = + "Repo from " <> display (repoUrl repo) <> + ", commit " <> display (repoCommit repo) <> + (if T.null $ repoSubdir repo + then mempty + else " in subdir " <> display (repoSubdir repo)) + +instance Pretty RawPackageLocationImmutable where + pretty (RPLIHackage pir _tree) = fillSep + [ fromString . T.unpack $ textDisplay pir + , parens (flow "from Hackage") + ] + pretty (RPLIArchive archive _pm) = fillSep + [ flow "Archive from" + , pretty (raLocation archive) + , if T.null $ raSubdir archive + then mempty + else fillSep + [ flow "in subdir" + , style Dir (fromString $ T.unpack (raSubdir archive)) + ] + ] + pretty (RPLIRepo repo _pm) = fillSep + [ flow "Repo from" + , style Url (fromString $ T.unpack (repoUrl repo)) <> "," + , "commit" + , fromString $ T.unpack (repoCommit repo) + , if T.null $ repoSubdir repo + then mempty + else fillSep + [ flow "in subdir" + , style Dir (fromString $ T.unpack (repoSubdir repo)) + ] + ] + +-- | Location for remote packages or archives assumed to be immutable. +-- +-- @since 0.1.0.0 +data PackageLocationImmutable + = PLIHackage !PackageIdentifier !BlobKey !TreeKey + | PLIArchive !Archive !PackageMetadata + | PLIRepo !Repo !PackageMetadata + deriving (Generic, Show, Eq, Ord, Typeable) + +instance NFData PackageLocationImmutable + +instance Display PackageLocationImmutable where + display (PLIHackage ident _cabalHash _tree) = + fromString (packageNameString $ pkgName ident) <> " (from Hackage)" + display (PLIArchive archive _pm) = + "Archive from " <> display (archiveLocation archive) <> + (if T.null $ archiveSubdir archive + then mempty + else " in subdir " <> display (archiveSubdir archive)) + display (PLIRepo repo _pm) = + "Repo from " <> display (repoUrl repo) <> + ", commit " <> display (repoCommit repo) <> + (if T.null $ repoSubdir repo + then mempty + else " in subdir " <> display (repoSubdir repo)) + +instance ToJSON PackageLocationImmutable where + toJSON = toJSON . toRawPLI + +-- | Package identifier and revision with a specified cabal file hash +-- +-- @since 0.1.0.0 +pirForHash :: PackageIdentifier -> BlobKey -> PackageIdentifierRevision +pirForHash (PackageIdentifier name ver) (BlobKey sha size') = + let cfi = CFIHash sha (Just size') + in PackageIdentifierRevision name ver cfi + +-- | Convert `PackageLocationImmutable` to its "raw" equivalent +-- +-- @since 0.1.0.0 +toRawPLI :: PackageLocationImmutable -> RawPackageLocationImmutable +toRawPLI (PLIHackage ident cfKey treeKey) = + RPLIHackage (pirForHash ident cfKey) (Just treeKey) +toRawPLI (PLIArchive archive pm) = + RPLIArchive (toRawArchive archive) (toRawPM pm) +toRawPLI (PLIRepo repo pm) = RPLIRepo repo (toRawPM pm) + +-- | A raw package archive, specified by a user, could have no +-- hash and file size information. +-- +-- @since 0.1.0.0 +data RawArchive = RawArchive + { raLocation :: !ArchiveLocation + -- ^ Location of the archive + -- + -- @since 0.1.0.0 + , raHash :: !(Maybe SHA256) + -- ^ Cryptographic hash of the archive file + -- + -- @since 0.1.0.0 + , raSize :: !(Maybe FileSize) + -- ^ Size of the archive file + -- + -- @since 0.1.0.0 + , raSubdir :: !Text + -- ^ Subdirectory within the archive to get the package from. + -- + -- @since 0.1.0.0 + } + deriving (Generic, Show, Eq, Ord, Typeable) + +instance NFData RawArchive + +-- | A package archive, could be from a URL or a local file path. Local file +-- path archives are assumed to be unchanging over time, and so are allowed in +-- custom snapshots. +-- +-- @since 0.1.0.0 +data Archive = Archive + { archiveLocation :: !ArchiveLocation + -- ^ Location of the archive + -- + -- @since 0.1.0.0 + , archiveHash :: !SHA256 + -- ^ Cryptographic hash of the archive file + -- + -- @since 0.1.0.0 + , archiveSize :: !FileSize + -- ^ Size of the archive file + -- + -- @since 0.1.0.0 + , archiveSubdir :: !Text + -- ^ Subdirectory within the archive to get the package from. + -- + -- @since 0.1.0.0 + } + deriving (Generic, Show, Eq, Ord, Typeable) + +instance NFData Archive + +-- | Convert archive to its "raw" equivalent. +-- +-- @since 0.1.0.0 +toRawArchive :: Archive -> RawArchive +toRawArchive archive = + RawArchive (archiveLocation archive) (Just $ archiveHash archive) + (Just $ archiveSize archive) (archiveSubdir archive) + +-- | The type of a source control repository. +-- +-- @since 0.1.0.0 +data RepoType = RepoGit | RepoHg + deriving (Generic, Show, Eq, Ord, Typeable) + +instance NFData RepoType + +instance PersistField RepoType where + toPersistValue RepoGit = toPersistValue (1 :: Int32) + toPersistValue RepoHg = toPersistValue (2 :: Int32) + fromPersistValue v = do + i <- fromPersistValue v + case i :: Int32 of + 1 -> pure RepoGit + 2 -> pure RepoHg + _ -> Left $ fromString $ "Invalid RepoType: " ++ show i + +instance PersistFieldSql RepoType where + sqlType _ = SqlInt32 + +-- | Information on packages stored in a source control repository. +-- +-- @since 0.1.0.0 +data Repo = Repo + { repoUrl :: !Text + -- ^ Location of the repo + -- + -- @since 0.1.0.0 + , repoCommit :: !Text + -- ^ Commit to use from the repo. It's strongly recommended to use + -- a hash instead of a tag or branch name. + -- + -- @since 0.1.0.0 + , repoType :: !RepoType + -- ^ The type of the repo + -- + -- @since 0.1.0.0 + , repoSubdir :: !Text + -- ^ Subdirectory within the archive to get the package from. + -- + -- @since 0.1.0.0 + } + deriving (Generic, Eq, Ord, Typeable) + +instance NFData Repo + +instance Show Repo where + show = T.unpack . utf8BuilderToText . display + +instance Display Repo where + display (Repo url commit typ subdir) = + (case typ of + RepoGit -> "Git" + RepoHg -> "Mercurial") <> + " repo at " <> + display url <> + ", commit " <> + display commit <> + (if T.null subdir + then mempty + else " in subdirectory " <> display subdir) + +rToSimpleRepo :: Repo -> SimpleRepo +rToSimpleRepo Repo {..} = SimpleRepo + { sRepoUrl = repoUrl + , sRepoCommit = repoCommit + , sRepoType = repoType + } + +data AggregateRepo = AggregateRepo + { aRepo :: !SimpleRepo + , aRepoSubdirs :: [(Text, RawPackageMetadata)] + } + deriving (Show, Generic, Eq, Ord, Typeable) + +-- | Group input repositories by non-subdir values. +toAggregateRepos :: [(Repo, RawPackageMetadata)] -> [AggregateRepo] +toAggregateRepos = mapMaybe toAggregateRepo . groupBy matchRepoExclSubdir + where + toAggregateRepo :: [(Repo, RawPackageMetadata)] -> Maybe AggregateRepo + toAggregateRepo [] = Nothing + toAggregateRepo xs@((repo, _):_) = + Just $ AggregateRepo (rToSimpleRepo repo) (fmap (first repoSubdir) xs) + + matchRepoExclSubdir x1 x2 = + let (Repo url1 commit1 type1 _, _) = x1 + (Repo url2 commit2 type2 _, _) = x2 + in (url1, commit1, type1) == (url2, commit2, type2) + +arToSimpleRepo :: AggregateRepo -> SimpleRepo +arToSimpleRepo AggregateRepo {..} = aRepo + +-- | Repository without subdirectory information. +-- +-- @since 0.5.3 +data SimpleRepo = SimpleRepo + { sRepoUrl :: !Text + , sRepoCommit :: !Text + , sRepoType :: !RepoType + } + deriving (Show, Generic, Eq, Ord, Typeable) + +instance Display SimpleRepo where + display (SimpleRepo url commit typ) = + (case typ of + RepoGit -> "Git" + RepoHg -> "Mercurial") <> + " repo at " <> + display url <> + ", commit " <> + display commit + +-- An unexported newtype wrapper to hang a 'FromJSON' instance off of. Contains +-- a GitHub user and repo name separated by a forward slash, e.g. "foo/bar". +newtype GitHubRepo = GitHubRepo Text + +instance FromJSON GitHubRepo where + parseJSON = withText "GitHubRepo" $ \s -> do + case T.split (== '/') s of + [x, y] | not (T.null x || T.null y) -> pure (GitHubRepo s) + _ -> fail "expecting \"user/repo\"" + +-- | Configuration to securely download package metadata and contents. For most +-- purposes, you'll want to use the default Hackage settings via +-- @defaultPackageIndexConfig@. +-- +-- /NOTE/ It's highly recommended to only use the official Hackage +-- server or a mirror. See +-- <https://github.com/commercialhaskell/stack/issues/4137>. +-- +-- @since 0.6.0 +data PackageIndexConfig = PackageIndexConfig + { picDownloadPrefix :: !Text + , picHackageSecurityConfig :: !HackageSecurityConfig + } + deriving Show + +-- | If the @hackage-security@ key is absent from the JSON object, assigns +-- default value 'defaultHackageSecurityConfig'. +-- +-- @since 0.6.0 +instance FromJSON (WithJSONWarnings PackageIndexConfig) where + parseJSON = withObjectWarnings "PackageIndexConfig" $ \o -> do + picDownloadPrefix <- o ..: "download-prefix" + picHackageSecurityConfig <- jsonSubWarnings $ + o ..:? "hackage-security" ..!= noJSONWarnings defaultHackageSecurityConfig + pure PackageIndexConfig {..} + +-- | Default 'HackageSecurityConfig' value using the official Hackage server. +-- The value of the 'hscIgnoreExpiry' field is 'True'. +-- +-- @since 0.7.0 +defaultHackageSecurityConfig :: HackageSecurityConfig +defaultHackageSecurityConfig = HackageSecurityConfig + { hscKeyIds = + [ "0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d" + , "1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42" + , "2c6c3627bd6c982990239487f1abd02e08a02e6cf16edb105a8012d444d870c3" + , "51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921" + , "fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0" + ] + , hscKeyThreshold = 3 + , hscIgnoreExpiry = True + } + +-- | Configuration for Hackage Security to securely download package metadata +-- and contents. For most purposes, you'll want to use the default Hackage +-- settings via @defaultHackageSecurityConfig@. +-- +-- /NOTE/ It's highly recommended to only use the official Hackage +-- server or a mirror. See +-- <https://github.com/commercialhaskell/stack/issues/4137>. +-- +-- @since 0.6.0 +data HackageSecurityConfig = HackageSecurityConfig + { hscKeyIds :: ![Text] + , hscKeyThreshold :: !Int + , hscIgnoreExpiry :: !Bool + } + deriving Show + +-- | If the @ignore-expiry@ key is absent from the JSON object, assigns default +-- value 'True'. +-- +-- @since 0.1.1.0 +instance FromJSON (WithJSONWarnings HackageSecurityConfig) where + parseJSON = withObjectWarnings "HackageSecurityConfig" $ \o -> do + hscKeyIds <- o ..: "keyids" + hscKeyThreshold <- o ..: "key-threshold" + hscIgnoreExpiry <- o ..:? "ignore-expiry" ..!= True + pure HackageSecurityConfig {..} + +-- | An environment which contains a 'PantryConfig'. +-- +-- @since 0.1.0.0 +class HasPantryConfig env where + -- | Lens to get or set the 'PantryConfig' + -- + -- @since 0.1.0.0 + pantryConfigL :: Lens' env PantryConfig + + +-- | File size in bytes +-- +-- @since 0.1.0.0 +newtype FileSize = FileSize Word + deriving ( Show, Eq, Ord, Typeable, Generic, Display, Hashable, NFData + , PersistField, PersistFieldSql, ToJSON, FromJSON + ) + +-- | A key for looking up a blob, which combines the SHA256 hash of the contents +-- and the file size. +-- +-- The file size may seem redundant with the hash. However, it is necessary for +-- safely downloading blobs from an untrusted source. See +-- <https://www.fpcomplete.com/blog/2018/07/pantry-part-2-trees-keys>. +-- +-- @since 0.1.0.0 +data BlobKey = BlobKey !SHA256 !FileSize + deriving (Eq, Ord, Typeable, Generic) + +instance NFData BlobKey + +instance Show BlobKey where + show = T.unpack . utf8BuilderToText . display + +instance Display BlobKey where + display (BlobKey sha size') = display sha <> "," <> display size' + +blobKeyPairs :: BlobKey -> [(AesonKey, Value)] +blobKeyPairs (BlobKey sha size') = + [ "sha256" .= sha + , "size" .= size' + ] + +instance ToJSON BlobKey where + toJSON = object . blobKeyPairs + +instance FromJSON BlobKey where + parseJSON = withObject "BlobKey" $ \o -> BlobKey + <$> o .: "sha256" + <*> o .: "size" + +newtype PackageNameP = PackageNameP { unPackageNameP :: PackageName } + deriving (Eq, Ord, Show, Read, NFData) + +instance Display PackageNameP where + display = fromString . packageNameString . unPackageNameP + +instance PersistField PackageNameP where + toPersistValue (PackageNameP pn) = PersistText $ T.pack $ packageNameString pn + fromPersistValue v = do + str <- fromPersistValue v + case parsePackageName str of + Nothing -> Left $ "Invalid package name: " <> T.pack str + Just pn -> Right $ PackageNameP pn + +instance PersistFieldSql PackageNameP where + sqlType _ = SqlString + +instance ToJSON PackageNameP where + toJSON (PackageNameP pn) = String $ T.pack $ packageNameString pn + +instance FromJSON PackageNameP where + parseJSON = + withText "PackageNameP" $ pure . PackageNameP . mkPackageName . T.unpack + +instance ToJSONKey PackageNameP where + toJSONKey = + ToJSONKeyText + (fromString . packageNameString . unPackageNameP) + (unsafeToEncoding . getUtf8Builder . display) + +instance FromJSONKey PackageNameP where + fromJSONKey = FromJSONKeyText $ PackageNameP . mkPackageName . T.unpack + +newtype VersionP = VersionP { unVersionP :: Version } + deriving (Eq, Ord, Show, Read, NFData) + +instance PersistField VersionP where + toPersistValue (VersionP v) = PersistText $ T.pack $ versionString v + fromPersistValue v = do + str <- fromPersistValue v + case parseVersion str of + Nothing -> Left $ "Invalid version number: " <> T.pack str + Just ver -> Right $ VersionP ver + +instance PersistFieldSql VersionP where + sqlType _ = SqlString + +instance Display VersionP where + display (VersionP v) = fromString $ versionString v + +instance ToJSON VersionP where + toJSON (VersionP v) = String $ T.pack $ versionString v + +instance FromJSON VersionP where + parseJSON = + withText "VersionP" $ + either (fail . displayException) (pure . VersionP) . parseVersionThrowing . T.unpack + +newtype ModuleNameP = ModuleNameP + { unModuleNameP :: ModuleName + } + deriving (Eq, Ord, Show, NFData) + +instance Display ModuleNameP where + display = fromString . moduleNameString . unModuleNameP + +instance PersistField ModuleNameP where + toPersistValue (ModuleNameP mn) = PersistText $ T.pack $ moduleNameString mn + fromPersistValue v = do + str <- fromPersistValue v + case parseModuleName str of + Nothing -> Left $ "Invalid module name: " <> T.pack str + Just pn -> Right $ ModuleNameP pn + +instance PersistFieldSql ModuleNameP where + sqlType _ = SqlString + +-- | How to choose a cabal file for a package from Hackage. This is to work with +-- Hackage cabal file revisions, which makes @PackageIdentifier@ insufficient +-- for specifying a package from Hackage. +-- +-- @since 0.1.0.0 +data CabalFileInfo + = CFILatest + -- ^ Take the latest revision of the cabal file available. This + -- isn't reproducible at all, but the running assumption (not + -- necessarily true) is that cabal file revisions do not change + -- semantics of the build. + -- + -- @since 0.1.0.0 + | CFIHash !SHA256 !(Maybe FileSize) + -- ^ Identify by contents of the cabal file itself. Only reason for + -- @Maybe@ on @FileSize@ is for compatibility with input that + -- doesn't include the file size. + -- + -- @since 0.1.0.0 + | CFIRevision !Revision + -- ^ Identify by revision number, with 0 being the original and + -- counting upward. This relies on Hackage providing consistent + -- versioning. @CFIHash@ should be preferred wherever possible for + -- reproducibility. + -- + -- @since 0.1.0.0 + deriving (Generic, Show, Eq, Ord, Typeable) + +instance NFData CabalFileInfo + +instance Hashable CabalFileInfo + +instance Display CabalFileInfo where + display CFILatest = mempty + display (CFIHash hash' msize) = + "@sha256:" <> display hash' <> maybe mempty (\i -> "," <> display i) msize + display (CFIRevision rev) = "@rev:" <> display rev + +-- | A full specification for a package from Hackage, including the package +-- name, version, and how to load up the correct cabal file revision. +-- +-- @since 0.1.0.0 +data PackageIdentifierRevision + = PackageIdentifierRevision !PackageName !Version !CabalFileInfo + deriving (Generic, Eq, Ord, Typeable) + +instance NFData PackageIdentifierRevision + +instance Show PackageIdentifierRevision where + show = T.unpack . utf8BuilderToText . display + +instance Display PackageIdentifierRevision where + display (PackageIdentifierRevision name version cfi) = + fromString (packageNameString name) + <> "-" + <> fromString (versionString version) + <> display cfi + +instance ToJSON PackageIdentifierRevision where + toJSON = toJSON . utf8BuilderToText . display + +instance FromJSON PackageIdentifierRevision where + parseJSON = withText "PackageIdentifierRevision" $ \t -> + case parsePackageIdentifierRevision t of + Left e -> fail $ show e + Right pir -> pure pir + +-- | Parse a hackage text. +-- +-- @since 0.1.0.0 +parseHackageText :: Text -> Either PantryException (PackageIdentifier, BlobKey) +parseHackageText t = + either (\x -> error (show x) $ const $ Left $ PackageIdentifierRevisionParseFail t) Right $ + explicitEitherParsec (hackageTextParsec <* Parse.eof) $ + T.unpack t + +hackageTextParsec :: ParsecParser (PackageIdentifier, BlobKey) +hackageTextParsec = do + ident <- packageIdentifierParsec + _ <- Parse.string "@sha256:" + + shaT <- Parse.munch (/= ',') + sha <- either (const mzero) pure $ SHA256.fromHexText $ fromString shaT + + _ <- Parse.char ',' + size' <- Parse.integral -- FIXME probably need to handle overflow, since unfortunately Cabal doesn't + pure (ident, BlobKey sha (FileSize size')) + +splitColon :: Text -> Maybe (Text, Text) +splitColon t' = + let (x, y) = T.break (== ':') t' + in (x, ) <$> T.stripPrefix ":" y + +-- | Parse a 'PackageIdentifierRevision' +-- +-- @since 0.1.0.0 +parsePackageIdentifierRevision :: + Text + -> Either PantryException PackageIdentifierRevision +parsePackageIdentifierRevision t = + maybe (Left $ PackageIdentifierRevisionParseFail t) Right $ do + let (identT, cfiT) = T.break (== '@') t + PackageIdentifier name version <- parsePackageIdentifier $ T.unpack identT + cfi <- + case splitColon cfiT of + Just ("@sha256", shaSizeT) -> do + let (shaT, sizeT) = T.break (== ',') shaSizeT + sha <- either (const Nothing) Just $ SHA256.fromHexText shaT + msize <- + case T.stripPrefix "," sizeT of + Nothing -> Just Nothing + Just sizeT' -> + case decimal sizeT' of + Right (size', "") -> Just $ Just $ FileSize size' + _ -> Nothing + pure $ CFIHash sha msize + Just ("@rev", revT) -> + case decimal revT of + Right (rev, "") -> pure $ CFIRevision $ Revision rev + _ -> Nothing + Nothing -> pure CFILatest + _ -> Nothing + pure $ PackageIdentifierRevision name version cfi + +data Mismatch a = Mismatch + { mismatchExpected :: !a + , mismatchActual :: !a + } + +-- | Things that can go wrong in pantry. Note two things: +-- +-- * Many other exception types may be thrown from underlying libraries. Pantry +-- does not attempt to wrap these underlying exceptions. +-- +-- * We may add more constructors to this data type in minor version bumps of +-- pantry. This technically breaks the PVP. You should not be writing pattern +-- matches against this type that expect total matching. +-- +-- @since 0.1.0.0 +data PantryException + = PackageIdentifierRevisionParseFail !Text + | InvalidCabalFile + !(Either RawPackageLocationImmutable (Path Abs File)) + !(Maybe Version) + ![PError] + ![PWarning] + | TreeWithoutCabalFile !RawPackageLocationImmutable + | TreeWithMultipleCabalFiles !RawPackageLocationImmutable ![SafeFilePath] + | MismatchedCabalName !(Path Abs File) !PackageName + | NoLocalPackageDirFound !(Path Abs Dir) + | NoCabalFileFound !(Path Abs Dir) + | MultipleCabalFilesFound !(Path Abs Dir) ![Path Abs File] + | InvalidWantedCompiler !Text + | InvalidSnapshotLocation !(Path Abs Dir) !Text + | InvalidOverrideCompiler !WantedCompiler !WantedCompiler + | InvalidFilePathSnapshot !Text + | InvalidSnapshot !RawSnapshotLocation !SomeException + | MismatchedPackageMetadata + !RawPackageLocationImmutable + !RawPackageMetadata + !(Maybe TreeKey) + !PackageIdentifier + | Non200ResponseStatus !Status + | InvalidBlobKey !(Mismatch BlobKey) + | Couldn'tParseSnapshot !RawSnapshotLocation !String + | WrongCabalFileName !RawPackageLocationImmutable !SafeFilePath !PackageName + | DownloadInvalidSHA256 !Text !(Mismatch SHA256) + | DownloadInvalidSize !Text !(Mismatch FileSize) + | DownloadTooLarge !Text !(Mismatch FileSize) + -- ^ Different from 'DownloadInvalidSize' since 'mismatchActual' is + -- a lower bound on the size from the server. + | LocalInvalidSHA256 !(Path Abs File) !(Mismatch SHA256) + | LocalInvalidSize !(Path Abs File) !(Mismatch FileSize) + | UnknownArchiveType !ArchiveLocation + | InvalidTarFileType !ArchiveLocation !FilePath !Tar.FileType + | UnsupportedTarball !ArchiveLocation !Text + | NoHackageCryptographicHash !PackageIdentifier + | FailedToCloneRepo !SimpleRepo + | TreeReferencesMissingBlob !RawPackageLocationImmutable !SafeFilePath !BlobKey + | CompletePackageMetadataMismatch !RawPackageLocationImmutable !PackageMetadata + | CRC32Mismatch !ArchiveLocation !FilePath !(Mismatch Word32) + | UnknownHackagePackage !PackageIdentifierRevision !FuzzyResults + | CannotCompleteRepoNonSHA1 !Repo + | MutablePackageLocationFromUrl !Text + | MismatchedCabalFileForHackage !PackageIdentifierRevision !(Mismatch PackageIdentifier) + | PackageNameParseFail !Text + | PackageVersionParseFail !Text + | InvalidCabalFilePath !(Path Abs File) + | DuplicatePackageNames !Utf8Builder ![(PackageName, [RawPackageLocationImmutable])] + | MigrationFailure !Text !(Path Abs File) !SomeException + | NoCasaConfig + | InvalidTreeFromCasa !BlobKey !ByteString + | ParseSnapNameException !Text + | HpackLibraryException !(Path Abs File) !String + | HpackExeException !FilePath !(Path Abs Dir) !SomeException + deriving Typeable + +instance Exception PantryException where + +instance Show PantryException where + show = T.unpack . utf8BuilderToText . display + +-- To support the Haskell Foundation's +-- [Haskell Error Index](https://errors.haskell.org/) initiative, all Pantry +-- error messages generated by Pantry itself begin with an unique code in the +-- form `[S-nnn]`, where `nnn` is a three-digit number in the range 100 to 999. +-- The numbers are selected at random, not in sequence. +-- +-- Prettier versions of these error messages are also provided. See the instance +-- of Pretty. +instance Display PantryException where + display NoCasaConfig = + "Error: [S-889]\n" + <> "The Pantry configuration has no Casa configuration." + display (InvalidTreeFromCasa blobKey _bs) = + "Error: [S-258]\n" + <> "Invalid tree from casa: " + <> display blobKey + display (PackageIdentifierRevisionParseFail text) = + "Error: [S-360]\n" + <> "Invalid package identifier (with optional revision): " + <> display text + display (InvalidCabalFile loc mversion errs warnings) = + "Error: [S-242]\n" + <> "Unable to parse cabal file from package " + <> either display (fromString . toFilePath) loc + <> "\n\n" + <> foldMap + ( \(PError pos msg) -> + "- " + <> fromString (showPos pos) + <> ": " + <> fromString msg + <> "\n" + ) + errs + <> foldMap + ( \(PWarning _ pos msg) -> + "- " + <> fromString (showPos pos) + <> ": " + <> fromString msg + <> "\n" + ) + warnings + <> ( case mversion of + Just version + | version > cabalSpecLatestVersion -> + "\n\nThe cabal file uses the cabal specification version " + <> fromString (versionString version) + <> ", but we only support up to version " + <> fromString (versionString cabalSpecLatestVersion) + <> ".\nRecommended action: upgrade your build tool (e.g., `stack upgrade`)." + _ -> mempty + ) + display (TreeWithoutCabalFile pl) = + "Error: [S-654]\n" + <> "No cabal file found for " + <> display pl + display (TreeWithMultipleCabalFiles pl sfps) = + "Error: [S-500]\n" + <> "Multiple cabal files found for " + <> display pl + <> ": " + <> fold (intersperse ", " (map display sfps)) + display (MismatchedCabalName fp name) = + "Error: [S-910]\n" + <> "The Cabal file:\n" + <> fromString (toFilePath fp) + <> "\nis not named after the package that it defines.\n" + <> "Please rename the file to: " + <> fromString (packageNameString name) + <> ".cabal\n" + <> "Hackage rejects packages where the first part of the Cabal file name " + <> "is not the package name." + display (NoLocalPackageDirFound dir) = + "Error: [S-395]\n" + <> "Stack looks for packages in the directories configured in\n" + <> "the 'packages' and 'extra-deps' fields defined in your stack.yaml\n" + <> "The current entry points to " + <> fromString (toFilePath dir) + <> ",\nbut no such directory could be found. If, alternatively, a package\n" + <> "in the package index was intended, its name and version must be\n" + <> "specified as an extra-dep." + display (NoCabalFileFound dir) = + "Error: [S-636]\n" + <> "Stack looks for packages in the directories configured in\n" + <> "the 'packages' and 'extra-deps' fields defined in your stack.yaml\n" + <> "The current entry points to " + <> fromString (toFilePath dir) + <> ",\nbut no .cabal or package.yaml file could be found there." + display (MultipleCabalFilesFound dir files) = + "Error: [S-368]\n" + <> "Multiple .cabal files found in directory " + <> fromString (toFilePath dir) + <> ":\n" + <> fold + ( intersperse + "\n" + (map (\x -> "- " <> fromString (toFilePath (filename x))) files) + ) + display (InvalidWantedCompiler t) = + "Error: [S-204]\n" + <> "Invalid wanted compiler: " + <> display t + display (InvalidSnapshotLocation dir t) = + "Error: [S-935]\n" + <> "Invalid snapshot location " + <> displayShow t + <> " relative to directory " + <> displayShow (toFilePath dir) + display (InvalidOverrideCompiler x y) = + "Error: [S-287]\n" + <> "Specified compiler for a resolver (" + <> display x + <> "), but also specified an override compiler (" + <> display y + <> ")" + display (InvalidFilePathSnapshot t) = + "Error: [S-617]\n" + <> "Specified snapshot as file path with " + <> displayShow t + <> ", but not reading from a local file" + display (InvalidSnapshot loc err) = + "Error: [S-775]\n" + <> "Exception while reading snapshot from " + <> display loc + <> ":\n" + <> displayShow err + display (MismatchedPackageMetadata loc pm mtreeKey foundIdent) = + "Error: [S-427]\n" + <> "Mismatched package metadata for " + <> display loc + <> "\nFound: " + <> fromString (packageIdentifierString foundIdent) + <> ( case mtreeKey of + Nothing -> mempty + Just treeKey -> " with tree " <> display treeKey + ) + <> "\nExpected: " + <> display pm + display (Non200ResponseStatus status) = + "Error: [S-571]\n" + <> "Unexpected non-200 HTTP status code: " + <> displayShow (statusCode status) + display (InvalidBlobKey Mismatch{..}) = + "Error: [S-236]\n" + <> "Invalid blob key found, expected: " + <> display mismatchExpected + <> ", actual: " + <> display mismatchActual + display (Couldn'tParseSnapshot sl err) = + "Error: [S-645]\n" + <> "Couldn't parse snapshot from " + <> display sl + <> ": " + <> fromString err + display (WrongCabalFileName pl sfp name) = + "Error: [S-575]\n" + <> "Wrong cabal file name for package " + <> display pl + <> "\nThe cabal file is named " + <> display sfp + <> ", but package name is " + <> fromString (packageNameString name) + <> "\nFor more information, see:\n - https://github.com/commercialhaskell/stack/issues/317\n -https://github.com/commercialhaskell/stack/issues/895" + display (DownloadInvalidSHA256 url Mismatch {..}) = + "Error: [S-394]\n" + <> "Mismatched SHA256 hash from " + <> display url + <> "\nExpected: " + <> display mismatchExpected + <> "\nActual: " + <> display mismatchActual + display (DownloadInvalidSize url Mismatch {..}) = + "Error: [S-401]\n" + <> "Mismatched download size from " + <> display url + <> "\nExpected: " + <> display mismatchExpected + <> "\nActual: " + <> display mismatchActual + display (DownloadTooLarge url Mismatch {..}) = + "Error: [S-113]\n" + <> "Download from " + <> display url + <> " was too large.\n" + <> "Expected: " + <> display mismatchExpected + <> ", stopped after receiving: " + <> display mismatchActual + display (LocalInvalidSHA256 path Mismatch {..}) = + "Error: [S-834]\n" + <> "Mismatched SHA256 hash from " + <> fromString (toFilePath path) + <> "\nExpected: " + <> display mismatchExpected + <> "\nActual: " + <> display mismatchActual + display (LocalInvalidSize path Mismatch {..}) = + "Error: [S-713]\n" + <> "Mismatched file size from " + <> fromString (toFilePath path) + <> "\nExpected: " + <> display mismatchExpected + <> "\nActual: " + <> display mismatchActual + display (UnknownArchiveType loc) = + "Error: [S-372]\n" + <> "Unable to determine archive type of: " + <> display loc + display (InvalidTarFileType loc fp x) = + "Error: [S-950]\n" + <> "Unsupported tar file type in archive " + <> display loc + <> " at file " + <> fromString fp + <> ": " + <> displayShow x + display (UnsupportedTarball loc err) = + "Error: [S-760]\n" + <> "Unsupported tarball from " + <> display loc + <> ": " + <> display err + display (NoHackageCryptographicHash ident) = + "Error: [S-922]\n" + <> "No cryptographic hash found for Hackage package " + <> fromString (packageIdentifierString ident) + display (FailedToCloneRepo repo) = + "Error: [S-109]\n" + <> "Failed to clone repo " + <> display repo + display (TreeReferencesMissingBlob loc sfp key) = + "Error: [S-237]\n" + <> "The package " + <> display loc + <> " needs blob " + <> display key + <> " for file path " + <> display sfp + <> ", but the blob is not available" + display (CompletePackageMetadataMismatch loc pm) = + "Error: [S-984]\n" + <> "When completing package metadata for " + <> display loc + <> ", some values changed in the new package metadata: " + <> display pm + display (CRC32Mismatch loc fp Mismatch {..}) = + "Error: [S-607]\n" + <> "CRC32 mismatch in ZIP file from " + <> display loc + <> " on internal file " + <> fromString fp + <> "\nExpected: " + <> display mismatchExpected + <> "\nActual: " + <> display mismatchActual + display (UnknownHackagePackage pir fuzzy) = + "Error: [S-476]\n" + <> "Could not find " + <> display pir + <> " on Hackage" + <> displayFuzzy fuzzy + display (CannotCompleteRepoNonSHA1 repo) = + "Error: [S-112]\n" + <> "Cannot complete repo information for a non SHA1 commit due to non-reproducibility: " + <> display repo + display (MutablePackageLocationFromUrl t) = + "Error: [S-321]\n" + <> "Cannot refer to a mutable package location from a URL: " + <> display t + display (MismatchedCabalFileForHackage pir Mismatch{..}) = + "Error: [S-377]\n" + <> "When processing cabal file for Hackage package " + <> display pir + <> ":\nMismatched package identifier." + <> "\nExpected: " + <> fromString (packageIdentifierString mismatchExpected) + <> "\nActual: " + <> fromString (packageIdentifierString mismatchActual) + display (PackageNameParseFail t) = + "Error: [S-580]\n" + <> "Invalid package name: " + <> display t + display (PackageVersionParseFail t) = + "Error: [S-479]\n" + <> "Invalid version: " + <> display t + display (InvalidCabalFilePath fp) = + "Error: [S-824]\n" + <> "File path contains a name which is not a valid package name: " + <> fromString (toFilePath fp) + display (DuplicatePackageNames source pairs') = + "Error: [S-674]\n" + <> "Duplicate package names (" + <> source + <> "):\n" + <> foldMap + ( \(name, locs) -> + fromString (packageNameString name) + <> ":\n" + <> foldMap (\loc -> "- " <> display loc <> "\n") locs + ) + pairs' + display (MigrationFailure desc fp err) = + "Error: [S-536]\n" + <> "Encountered error while migrating database " + <> display desc + <> "\nlocated at " + <> fromString (toFilePath fp) + <> ":" + <> "\n " + <> displayShow err + display (ParseSnapNameException t) = + "Error: [S-994]\n" + <> "Invalid snapshot name: " + <> display t + display (HpackLibraryException file err) = + "Error: [S-305]\n" + <> "Failed to generate a Cabal file using the Hpack library on file:\n" + <> fromString (toFilePath file) + <> "\n\n" + <> "The error encountered was:\n\n" + <> fromString err + display (HpackExeException fp dir err) = + "Error: [S-720]\n" + <> "Failed to generate a Cabal file using the Hpack executable:\n" + <> fromString fp + <> "in directory: " + <> fromString (toFilePath dir) + <> "\n\n" + <> "The error encountered was:\n\n" + <> fromString (show err) + +-- See also the instance of Display. Although prettier, these messages are +-- intended to be substantively the same as the corresponding 'black and white' +-- versions. +instance Pretty PantryException where + pretty NoCasaConfig = + "[S-889]" + <> line + <> flow "The Pantry configuration has no Casa configuration." + pretty (InvalidTreeFromCasa blobKey _bs) = + "[S-258]" + <> line + <> fillSep + [ flow "Invalid tree from casa:" + , fromString . T.unpack $ textDisplay blobKey + ] + pretty (PackageIdentifierRevisionParseFail text) = + "[S-360]" + <> line + <> fillSep + [ flow "Invalid package identifier (with optional revision):" + , fromString $ T.unpack text + ] + pretty (InvalidCabalFile loc mversion errs warnings) = + "[S-242]" + <> line + <> fillSep + [ flow "Unable to parse Cabal file from package" + , either pretty pretty loc <> ":" + ] + <> line + <> bulletedList + ( map (\(PError pos msg) -> fillSep + [ fromString (showPos pos) <> ":" + , fromString msg + ]) + errs + ) + <> line + <> bulletedList + ( map (\(PWarning _ pos msg) -> fillSep + [ fromString (showPos pos) <> ":" + , fromString msg + ]) + warnings + ) + <> ( case mversion of + Just version | version > cabalSpecLatestVersion -> + line + <> fillSep + [ flow "The Cabal file uses the Cabal specification version" + , style Current (fromString $ versionString version) <> "," + , flow "but we only support up to version" + , fromString (versionString cabalSpecLatestVersion) <> "." + , flow "Recommended action: upgrade your build tool" + , parens (fillSep + [ "e.g." + , style Shell (flow "stack upgrade") + ]) <> "." + ] + _ -> mempty + ) + pretty (TreeWithoutCabalFile loc) = + "[S-654]" + <> line + <> fillSep + [ flow "No Cabal file found for" + , pretty loc <> "." + ] + pretty (TreeWithMultipleCabalFiles loc sfps) = + "[S-500]" + <> line + <> fillSep + ( flow "Multiple Cabal files found for" + : (pretty loc <> ":") + : mkNarrativeList (Just File) False + (map (fromString . T.unpack . textDisplay) sfps :: [StyleDoc]) + ) + pretty (MismatchedCabalName fp name) = + "[S-910]" + <> line + <> fillSep + [ flow "The Cabal file" + , pretty fp + , flow "is not named after the package that it defines. Please rename" + , flow "the file to" + , style File (fromString $ packageNameString name <> ".cabal") <> "." + , flow "Hackage rejects packages where the first part of the Cabal" + , flow "file name is not the package name." + ] + pretty (NoLocalPackageDirFound dir) = + "[S-395]" + <> line + <> fillSep + [ flow "Stack looks for packages in the directories configured in the" + , style Shell "packages" + , "and" + , style Shell "extra-deps" + , flow "fields defined in your" + , style File "stack.yaml" <> "." + , flow "The current entry points to" + , pretty dir + , flow "but no such directory could be found. If, alternatively, a" + , flow "package in the package index was intended, its name and" + , flow "version must be specified as an extra-dep." + ] + pretty (NoCabalFileFound dir) = + "[S-636]" + <> line + <> fillSep + [ flow "Stack looks for packages in the directories configured in the" + , style Shell "packages" + , "and" + , style Shell "extra-deps" + , flow "fields defined in your" + , style File "stack.yaml" <> "." + , flow "The current entry points to" + , pretty dir + , flow "but no Cabal file or" + , style File "package.yaml" + , flow "could be found there." + ] + pretty (MultipleCabalFilesFound dir files) = + "[S-368]" + <> line + <> fillSep + ( flow "Multiple Cabal files found in directory" + : (pretty dir <> ":") + : mkNarrativeList (Just File) False + (map (pretty . filename) files) + ) + pretty (InvalidWantedCompiler t) = + "[S-204]" + <> line + <> fillSep + [ flow "Invalid wanted compiler:" + , style Current (fromString $ T.unpack t) <> "." + ] + pretty (InvalidSnapshotLocation dir t) = + "[S-935]" + <> line + <> fillSep + [ flow "Invalid snapshot location" + , style Current (fromString $ T.unpack t) + , flow "relative to directory" + , pretty dir <> "." + ] + pretty (InvalidOverrideCompiler x y) = + "[S-287]" + <> line + <> fillSep + [ flow "Specified compiler for a resolver" + , parens (style Shell (fromString . T.unpack $ textDisplay x)) + , flow "but also specified an override compiler" + , parens (style Shell (fromString . T.unpack $ textDisplay y)) <> "." + ] + pretty (InvalidFilePathSnapshot t) = + "[S-617]" + <> line + <> fillSep + [ flow "Specified snapshot as file path with" + , style File (fromString $ T.unpack t) <> "," + , flow "but not reading from a local file." + ] + pretty (InvalidSnapshot loc err) = + "[S-775]" + <> line + <> fillSep + [ flow "Exception while reading snapshot from" + , pretty loc <> ":" + ] + <> blankLine + <> string (displayException err) + pretty (MismatchedPackageMetadata loc pm mtreeKey foundIdent) = + "[S-427]" + <> line + <> fillSep + [ flow "Mismatched package metadata for" + , pretty loc <> "." + ] + <> blankLine + <> hang 10 (fillSep + [ "Expected:" + , let t = textDisplay pm + in if T.null t + then "nothing." + else fromString $ T.unpack t <> "." + ]) + <> line + <> hang 10 (fillSep + [ "Found: " + , fromString $ packageIdentifierString foundIdent <> case mtreeKey of + Nothing -> "." + _ -> mempty + , case mtreeKey of + Nothing -> mempty + Just treeKey -> fillSep + [ "with tree" + , fromString . T.unpack $ textDisplay treeKey <> "." + ] + ]) + pretty (Non200ResponseStatus status) = + "[S-571]" + <> line + <> fillSep + [ flow "Unexpected non-200 HTTP status code:" + , (fromString . show $ statusCode status) <> "." + ] + pretty (InvalidBlobKey Mismatch{..}) = + "[S-236]" + <> line + <> fillSep + [ flow "Invalid blob key found, expected:" + , fromString . T.unpack $ textDisplay mismatchExpected <> "," + , "actual:" + , fromString . T.unpack $ textDisplay mismatchActual <> "." + ] + pretty (Couldn'tParseSnapshot sl err) = + "[S-645]" + <> line + <> fillSep + [ flow "Couldn't parse snapshot from" + , pretty sl <> ":" + ] + <> blankLine + <> string err + pretty (WrongCabalFileName loc sfp name) = + "[S-575]" + <> line + <> fillSep + [ flow "Wrong Cabal file name for package" + , pretty loc <> "." + , flow "The Cabal file is named" + , style File (fromString . T.unpack $ textDisplay sfp) <> "," + , flow "but package name is" + , fromString (packageNameString name) <> "." + , flow "For more information, see" + , style Url "https://github.com/commercialhaskell/stack/issues/317" + , "and" + , style Url "https://github.com/commercialhaskell/stack/issues/895" <> "." + ] + pretty (DownloadInvalidSHA256 url Mismatch {..}) = + "[S-394]" + <> line + <> fillSep + [ flow "Mismatched SHA256 hash from" + , style Url (fromString $ T.unpack url) <> "." + ] + <> blankLine + <> hang 10 (fillSep + [ "Expected:" + , fromString . T.unpack $ textDisplay mismatchExpected <> "." + ]) + <> line + <> hang 10 (fillSep + [ "Actual: " + , fromString . T.unpack $ textDisplay mismatchActual <> "." + ]) + pretty (DownloadInvalidSize url Mismatch {..}) = + "[S-401]" + <> line + <> fillSep + [ flow "Mismatched download size from" + , style Url (fromString $ T.unpack url) <> "." + ] + <> blankLine + <> hang 10 (fillSep + [ "Expected:" + , fromString . T.unpack $ textDisplay mismatchExpected <> "." + ]) + <> line + <> hang 10 (fillSep + [ "Actual: " + , fromString . T.unpack $ textDisplay mismatchActual <> "." + ]) + pretty (DownloadTooLarge url Mismatch {..}) = + "[S-113]" + <> line + <> fillSep + [ flow "Download from" + , style Url (fromString $ T.unpack url) + , flow "was too large. Expected:" + , fromString . T.unpack $ textDisplay mismatchExpected <> "," + , flow "stopped after receiving:" + , fromString . T.unpack $ textDisplay mismatchActual <> "." + ] + pretty (LocalInvalidSHA256 path Mismatch {..}) = + "[S-834]" + <> line + <> fillSep + [ flow "Mismatched SHA256 hash from" + , pretty path <> "." + ] + <> blankLine + <> hang 10 (fillSep + [ "Expected:" + , fromString . T.unpack $ textDisplay mismatchExpected <> "." + ]) + <> line + <> hang 10 (fillSep + [ "Actual: " + , fromString . T.unpack $ textDisplay mismatchActual <> "." + ]) + pretty (LocalInvalidSize path Mismatch {..}) = + "[S-713]" + <> line + <> fillSep + [ flow "Mismatched file size from" + , pretty path <> "." + ] + <> blankLine + <> hang 10 (fillSep + [ "Expected:" + , fromString . T.unpack $ textDisplay mismatchExpected <> "." + ]) + <> line + <> hang 10 (fillSep + [ "Actual: " + , fromString . T.unpack $ textDisplay mismatchActual <> "." + ]) + pretty (UnknownArchiveType loc) = + "[S-372]" + <> line + <> fillSep + [ flow "Unable to determine archive type of:" + , pretty loc <> "." + ] + pretty (InvalidTarFileType loc fp x) = + "[S-950]" + <> line + <> fillSep + [ flow "Unsupported tar file type in archive" + , pretty loc + , flow "at file" + , style File (fromString fp) <> ":" + , fromString $ show x <> "." + ] + pretty (UnsupportedTarball loc err) = + "[S-760]" + <> line + <> fillSep + [ flow "Unsupported tarball from" + , pretty loc <> ":" + ] + <> blankLine + <> string (T.unpack err) + pretty (NoHackageCryptographicHash ident) = + "[S-922]" + <> line + <> fillSep + [ flow "No cryptographic hash found for Hackage package" + , fromString (packageIdentifierString ident) <> "." + ] + pretty (FailedToCloneRepo repo) = + "[S-109]" + <> line + <> fillSep + [ flow "Failed to clone repository" + , fromString . T.unpack $ textDisplay repo + ] + pretty (TreeReferencesMissingBlob loc sfp key) = + "[S-237]" + <> line + <> fillSep + [ flow "The package" + , pretty loc + , flow "needs blob" + , fromString . T.unpack $ textDisplay key + , flow "for file path" + , style File (fromString . T.unpack $ textDisplay sfp) <> "," + , flow "but the blob is not available." + ] + pretty (CompletePackageMetadataMismatch loc pm) = + "[S-984]" + <> line + <> fillSep + [ flow "When completing package metadata for" + , pretty loc <> "," + , flow "some values changed in the new package metadata:" + , fromString . T.unpack $ textDisplay pm <> "." + ] + pretty (CRC32Mismatch loc fp Mismatch {..}) = + "[S-607]" + <> line + <> fillSep + [ flow "CRC32 mismatch in Zip file from" + , pretty loc + , flow "on internal file" + , style File (fromString fp) + ] + <> blankLine + <> hang 10 (fillSep + [ "Expected:" + , fromString . T.unpack $ textDisplay mismatchExpected <> "." + ]) + <> line + <> hang 10 (fillSep + [ "Actual: " + , fromString . T.unpack $ textDisplay mismatchActual <> "." + ]) + pretty (UnknownHackagePackage pir fuzzy) = + "[S-476]" + <> line + <> fillSep + [ flow "Could not find" + , style Error (fromString . T.unpack $ textDisplay pir) + , flow "on Hackage." + ] + <> prettyFuzzy fuzzy + pretty (CannotCompleteRepoNonSHA1 repo) = + "[S-112]" + <> line + <> fillSep + [ flow "Cannot complete repo information for a non SHA1 commit due to" + , "non-reproducibility:" + , fromString . T.unpack $ textDisplay repo <> "." + ] + pretty (MutablePackageLocationFromUrl t) = + "[S-321]" + <> line + <> fillSep + [ flow "Cannot refer to a mutable package location from a URL:" + , style Url (fromString $ T.unpack t) <> "." + ] + pretty (MismatchedCabalFileForHackage pir Mismatch{..}) = + "[S-377]" + <> line + <> fillSep + [ flow "When processing Cabal file for Hackage package" + , fromString . T.unpack $ textDisplay pir <> "," + , flow "mismatched package identifier." + ] + <> blankLine + <> hang 10 (fillSep + [ "Expected:" + , fromString (packageIdentifierString mismatchExpected) <> "." + ]) + <> line + <> hang 10 (fillSep + [ "Actual: " + , fromString (packageIdentifierString mismatchActual) <> "." + ]) + pretty (PackageNameParseFail t) = + "[S-580]" + <> line + <> fillSep + [ flow "Invalid package name:" + , fromString $ T.unpack t <> "." + ] + pretty (PackageVersionParseFail t) = + "[S-479]" + <> line + <> fillSep + [ flow "Invalid version:" + , fromString $ T.unpack t <> "." + ] + pretty (InvalidCabalFilePath fp) = + "[S-824]" + <> line + <> fillSep + [ flow "File path contains a name which is not a valid package name:" + , pretty fp <> "." + ] + pretty (DuplicatePackageNames source pairs') = + "[S-674]" + <> line + <> fillSep + [ flow "Duplicate package names" + , parens (fromString . T.unpack $ textDisplay source) <> ":" + ] + <> line + <> foldMap + ( \(name, locs) -> + fromString (packageNameString name) <> ":" + <> line + <> bulletedList (map pretty locs) + <> line + ) + pairs' + pretty (MigrationFailure desc fp err) = + "[S-536]" + <> line + <> fillSep + [ flow "Encountered error while migrating database" + , fromString $ T.unpack desc + , flow "located at" + , pretty fp <> ":" + ] + <> blankLine + <> string (displayException err) + pretty (ParseSnapNameException t) = + "[S-994]" + <> line + <> fillSep + [ flow "Invalid snapshot name:" + , fromString $ T.unpack t <> "." + ] + pretty (HpackLibraryException file err) = + "[S-305]" + <> line + <> fillSep + [ flow "Failed to generate a Cabal file using the Hpack library on" + , "file:" + , pretty file <> "." + , flow "The error encountered was:" + ] + <> blankLine + <> string err + pretty (HpackExeException fp dir err) = + "[S-720]" + <> line + <> fillSep + [ flow "Failed to generate a Cabal file using the Hpack executable:" + , style File (fromString fp) + , flow "in directory:" + , pretty dir <> "." + , flow "The error encountered was:" + ] + <> blankLine + <> string (displayException err) + +blankLine :: StyleDoc +blankLine = line <> line + +data FuzzyResults + = FRNameNotFound ![PackageName] + | FRVersionNotFound !(NonEmpty PackageIdentifierRevision) + | FRRevisionNotFound !(NonEmpty PackageIdentifierRevision) + +displayFuzzy :: FuzzyResults -> Utf8Builder +displayFuzzy (FRNameNotFound names) = + case NE.nonEmpty names of + Nothing -> "" + Just names' -> + "\nPerhaps you meant " <> + orSeparated (NE.map (fromString . packageNameString) names') <> + "?" +displayFuzzy (FRVersionNotFound pirs) = + "\nPossible candidates: " <> + commaSeparated (NE.map display pirs) <> + "." +displayFuzzy (FRRevisionNotFound pirs) = + "\nThe specified revision was not found.\nPossible candidates: " <> + commaSeparated (NE.map display pirs) <> + "." + +prettyFuzzy :: FuzzyResults -> StyleDoc +prettyFuzzy (FRNameNotFound names) = + case NE.nonEmpty names of + Nothing -> mempty + Just names' -> + line + <> fillSep + ( flow "Perhaps you meant one of" + : mkNarrativeList Nothing False + (NE.toList $ NE.map (fromString . packageNameString) names' :: [StyleDoc]) + ) +prettyFuzzy (FRVersionNotFound pirs) = + line + <> fillSep + ( flow "Possible candidates:" + : mkNarrativeList Nothing False + (NE.toList $ NE.map (fromString . T.unpack . textDisplay) pirs :: [StyleDoc]) + ) +prettyFuzzy (FRRevisionNotFound pirs) = + line + <> fillSep + ( flow "The specified revision was not found. Possible candidates:" + : mkNarrativeList Nothing False + (NE.toList $ NE.map (fromString . T.unpack . textDisplay) pirs :: [StyleDoc]) + ) + +orSeparated :: NonEmpty Utf8Builder -> Utf8Builder +orSeparated xs + | NE.length xs == 1 = NE.head xs + | NE.length xs == 2 = NE.head xs <> " or " <> NE.last xs + | otherwise = fold (intersperse ", " (NE.init xs)) <> ", or " <> NE.last xs + +commaSeparated :: NonEmpty Utf8Builder -> Utf8Builder +commaSeparated = fold . NE.intersperse ", " + +cabalSpecLatestVersion :: Version +cabalSpecLatestVersion = mkVersion $ cabalSpecToVersionDigits cabalSpecLatest + +#if !MIN_VERSION_Cabal(3,4,0) +cabalSpecToVersionDigits :: CabalSpecVersion -> [Int] +cabalSpecToVersionDigits CabalSpecV3_0 = [3,0] +cabalSpecToVersionDigits CabalSpecV2_4 = [2,4] +cabalSpecToVersionDigits CabalSpecV2_2 = [2,2] +cabalSpecToVersionDigits CabalSpecV2_0 = [2,0] +cabalSpecToVersionDigits CabalSpecV1_24 = [1,24] +cabalSpecToVersionDigits CabalSpecV1_22 = [1,22] +cabalSpecToVersionDigits CabalSpecV1_20 = [1,20] +cabalSpecToVersionDigits CabalSpecV1_18 = [1,18] +cabalSpecToVersionDigits CabalSpecV1_12 = [1,12] +cabalSpecToVersionDigits CabalSpecV1_10 = [1,10] +cabalSpecToVersionDigits CabalSpecV1_8 = [1,8] +cabalSpecToVersionDigits CabalSpecV1_6 = [1,6] +cabalSpecToVersionDigits CabalSpecV1_4 = [1,4] +cabalSpecToVersionDigits CabalSpecV1_2 = [1,2] +cabalSpecToVersionDigits CabalSpecV1_0 = [1,0] +#endif + +data BuildFile + = BFCabal !SafeFilePath !TreeEntry + | BFHpack !TreeEntry + -- We don't need SafeFilePath for Hpack since it has to be package.yaml file + deriving (Show, Eq) + +data FileType = FTNormal | FTExecutable + deriving (Show, Eq, Enum, Bounded, Ord) + +instance PersistField FileType where + toPersistValue FTNormal = PersistInt64 1 + toPersistValue FTExecutable = PersistInt64 2 + + fromPersistValue v = do + i <- fromPersistValue v + case i :: Int64 of + 1 -> Right FTNormal + 2 -> Right FTExecutable + _ -> Left $ "Invalid FileType: " <> tshow i + +instance PersistFieldSql FileType where + sqlType _ = SqlInt32 + +data TreeEntry = TreeEntry + { teBlob :: !BlobKey + , teType :: !FileType + } + deriving (Show, Eq, Ord) + +newtype SafeFilePath = SafeFilePath Text + deriving (Show, Eq, Ord, Display) + +instance PersistField SafeFilePath where + toPersistValue = toPersistValue . unSafeFilePath + fromPersistValue v = do + t <- fromPersistValue v + maybe (Left $ "Invalid SafeFilePath: " <> t) Right $ mkSafeFilePath t + +instance PersistFieldSql SafeFilePath where + sqlType _ = SqlString + +unSafeFilePath :: SafeFilePath -> Text +unSafeFilePath (SafeFilePath t) = t + +safeFilePathToPath :: (MonadThrow m) => Path Abs Dir -> SafeFilePath -> m (Path Abs File) +safeFilePathToPath dir (SafeFilePath path) = do + fpath <- parseRelFile (T.unpack path) + pure $ dir </> fpath + +mkSafeFilePath :: Text -> Maybe SafeFilePath +mkSafeFilePath t = do + guard $ not $ "\\" `T.isInfixOf` t + guard $ not $ "//" `T.isInfixOf` t + guard $ not $ "\n" `T.isInfixOf` t + guard $ not $ "\0" `T.isInfixOf` t + + (c, _) <- T.uncons t + guard $ c /= '/' + + guard $ (not . any (T.all (== '.'))) $ T.split (== '/') t + + Just $ SafeFilePath t + +-- | SafeFilePath for `package.yaml` file. +hpackSafeFilePath :: SafeFilePath +hpackSafeFilePath = + let fpath = mkSafeFilePath (T.pack Hpack.packageConfig) + in case fpath of + Nothing -> error $ + "hpackSafeFilePath: Not able to encode " <> Hpack.packageConfig + Just sfp -> sfp + +-- | The hash of the binary representation of a 'Tree'. +-- +-- @since 0.1.0.0 +newtype TreeKey = TreeKey BlobKey + deriving (Show, Eq, Ord, Generic, Typeable, ToJSON, FromJSON, NFData, Display) + +-- | Represents the contents of a tree, which is a mapping from +-- relative file paths to 'TreeEntry's. +-- +-- @since 0.1.0.0 +newtype Tree + = TreeMap (Map SafeFilePath TreeEntry) + -- In the future, consider allowing more lax parsing + -- See: https://www.fpcomplete.com/blog/2018/07/pantry-part-2-trees-keys + -- TreeTarball !PackageTarball + deriving (Show, Eq, Ord) + +renderTree :: Tree -> ByteString +renderTree = BL.toStrict . toLazyByteString . go + where + go :: Tree -> Builder + go (TreeMap m) = "map:" <> Map.foldMapWithKey goEntry m + + goEntry sfp (TreeEntry (BlobKey sha (FileSize size')) ft) = + netstring (unSafeFilePath sfp) <> + byteString (SHA256.toRaw sha) <> + netword size' <> + (case ft of + FTNormal -> "N" + FTExecutable -> "X") + +netstring :: Text -> Builder +netstring t = + let bs = encodeUtf8 t + in netword (fromIntegral (B.length bs)) <> byteString bs + +netword :: Word -> Builder +netword w = wordDec w <> ":" + +parseTreeM :: MonadThrow m => (BlobKey, ByteString) -> m (TreeKey, Tree) +parseTreeM (blobKey, blob) = + case parseTree blob of + Nothing -> throwM (InvalidTreeFromCasa blobKey blob) + Just tree -> pure (TreeKey blobKey, tree) + +parseTree :: ByteString -> Maybe Tree +parseTree bs1 = do + tree <- parseTree' bs1 + let bs2 = renderTree tree + guard $ bs1 == bs2 + Just tree + +parseTree' :: ByteString -> Maybe Tree +parseTree' bs0 = do + entriesBS <- B.stripPrefix "map:" bs0 + TreeMap <$> loop Map.empty entriesBS + where + loop !m bs1 + | B.null bs1 = pure m + | otherwise = do + (sfpBS, bs2) <- takeNetstring bs1 + sfp <- + case decodeUtf8' sfpBS of + Left _ -> Nothing + Right sfpT -> mkSafeFilePath sfpT + (sha, bs3) <- takeSha bs2 + (size', bs4) <- takeNetword bs3 + (typeW, bs5) <- B.uncons bs4 + ft <- + case typeW of + 78 -> Just FTNormal -- 'N' + 88 -> Just FTExecutable -- 'X' + _ -> Nothing + let entry = TreeEntry (BlobKey sha (FileSize (fromIntegral size'))) ft + loop (Map.insert sfp entry m) bs5 + + takeNetstring bs1 = do + (size', bs2) <- takeNetword bs1 + guard $ B.length bs2 >= size' + Just $ B.splitAt size' bs2 + + takeSha bs = do + let (x, y) = B.splitAt 32 bs + x' <- either (const Nothing) Just (SHA256.fromRaw x) + Just (x', y) + + takeNetword = + go 0 + where + go !accum bs = do + (next, rest) <- B.uncons bs + if + | next == 58 -> pure (accum, rest) -- ':' + | next >= 48 && next <= 57 -> + go + (accum * 10 + fromIntegral (next - 48)) + rest + | otherwise -> Nothing + + {- +data PackageTarball = PackageTarball + { ptBlob :: !BlobKey + -- ^ Contains the tarball itself + , ptCabal :: !BlobKey + -- ^ Contains the cabal file contents + , ptSubdir :: !FilePath + -- ^ Subdir containing the files we want for this package. + -- + -- There must be precisely one file with a @.cabal@ file extension + -- located there. Thanks to Hackage revisions, its contents will be + -- overwritten by the value of @ptCabal@. + } + deriving Show + -} + +-- | This is almost a copy of Cabal's parser for package identifiers, +-- the main difference is in the fact that Stack requires version to be +-- present while Cabal uses "null version" as a default value +-- +-- @since 0.1.0.0 +parsePackageIdentifier :: String -> Maybe PackageIdentifier +parsePackageIdentifier = either (const Nothing) Just . explicitEitherParsec (packageIdentifierParsec <* Parse.eof) + +packageIdentifierParsec :: ParsecParser PackageIdentifier +packageIdentifierParsec = do + ident@(PackageIdentifier _ v) <- parsec + + -- version is a required component of a package identifier for Stack + guard (v /= nullVersion) + + pure ident + +-- | Parse a package name from a 'String'. +-- +-- @since 0.1.0.0 +parsePackageName :: String -> Maybe PackageName +parsePackageName = Distribution.Text.simpleParse + +-- | Parse a package name from a 'String' throwing on failure +-- +-- @since 0.1.0.0 +parsePackageNameThrowing :: MonadThrow m => String -> m PackageName +parsePackageNameThrowing str = + case parsePackageName str of + Nothing -> throwM $ PackageNameParseFail $ T.pack str + Just pn -> pure pn + +-- | Parse a version from a 'String'. +-- +-- @since 0.1.0.0 +parseVersion :: String -> Maybe Version +parseVersion = Distribution.Text.simpleParse + +-- | Parse a package version from a 'String' throwing on failure +-- +-- @since 0.1.0.0 +parseVersionThrowing :: MonadThrow m => String -> m Version +parseVersionThrowing str = + case parseVersion str of + Nothing -> throwM $ PackageVersionParseFail $ T.pack str + Just v -> pure v + +-- | Parse a version range from a 'String'. +-- +-- @since 0.1.0.0 +parseVersionRange :: String -> Maybe VersionRange +parseVersionRange = Distribution.Text.simpleParse + +-- | Parse a module name from a 'String'. +-- +-- @since 0.1.0.0 +parseModuleName :: String -> Maybe ModuleName +parseModuleName = Distribution.Text.simpleParse + +-- | Parse a flag name from a 'String'. +-- +-- @since 0.1.0.0 +parseFlagName :: String -> Maybe FlagName +parseFlagName = Distribution.Text.simpleParse + +-- | Render a package name as a 'String'. +-- +-- @since 0.1.0.0 +packageNameString :: PackageName -> String +packageNameString = unPackageName + +-- | Render a package identifier as a 'String'. +-- +-- @since 0.1.0.0 +packageIdentifierString :: PackageIdentifier -> String +packageIdentifierString = Distribution.Text.display + +-- | Render a version as a 'String'. +-- +-- @since 0.1.0.0 +versionString :: Version -> String +versionString = Distribution.Text.display + +-- | Render a flag name as a 'String'. +-- +-- @since 0.1.0.0 +flagNameString :: FlagName -> String +flagNameString = unFlagName + +-- | Render a module name as a 'String'. +-- +-- @since 0.1.0.0 +moduleNameString :: ModuleName -> String +moduleNameString = Distribution.Text.display + +data OptionalSubdirs + = OSSubdirs !(NonEmpty Text) + | OSPackageMetadata !Text !RawPackageMetadata + -- ^ subdirectory and package metadata + deriving (Show, Eq, Generic) + +instance NFData OptionalSubdirs + +-- | Metadata provided by a config file for archives and repos. This information +-- can be used for optimized lookups of information like package identifiers, or +-- for validating that the user configuration has the expected information. +-- +-- @since 0.1.0.0 +data RawPackageMetadata = RawPackageMetadata + { rpmName :: !(Maybe PackageName) + -- ^ Package name in the cabal file + -- + -- @since 0.1.0.0 + , rpmVersion :: !(Maybe Version) + -- ^ Package version in the cabal file + -- + -- @since 0.1.0.0 + , rpmTreeKey :: !(Maybe TreeKey) + -- ^ Tree key of the loaded up package + -- + -- @since 0.1.0.0 + } + deriving (Show, Eq, Ord, Generic, Typeable) + +instance NFData RawPackageMetadata + +instance Display RawPackageMetadata where + display rpm = fold $ intersperse ", " $ catMaybes + [ (\name -> "name == " <> fromString (packageNameString name)) <$> rpmName rpm + , (\version -> "version == " <> fromString (versionString version)) <$> rpmVersion rpm + , (\tree -> "tree == " <> display tree) <$> rpmTreeKey rpm + ] + +-- | Exact metadata specifying concrete package +-- +-- @since 0.1.0.0 +data PackageMetadata = PackageMetadata + { pmIdent :: !PackageIdentifier + -- ^ Package identifier in the cabal file + -- + -- @since 0.1.0.0 + , pmTreeKey :: !TreeKey + -- ^ Tree key of the loaded up package + -- + -- @since 0.1.0.0 + } + deriving (Show, Eq, Ord, Generic, Typeable) + +-- i PackageMetadata +instance NFData PackageMetadata + +instance Display PackageMetadata where + display pm = fold $ intersperse ", " + [ "ident == " <> fromString (packageIdentifierString $ pmIdent pm) + , "tree == " <> display (pmTreeKey pm) + ] + +parsePackageMetadata :: Object -> WarningParser PackageMetadata +parsePackageMetadata o = do + _oldCabalFile :: Maybe BlobKey <- o ..:? "cabal-file" + pantryTree :: BlobKey <- o ..: "pantry-tree" + CabalString pkgName <- o ..: "name" + CabalString pkgVersion <- o ..: "version" + let pmTreeKey = TreeKey pantryTree + pmIdent = PackageIdentifier {..} + pure PackageMetadata {..} + + +-- | Convert package metadata to its "raw" equivalent. +-- +-- @since 0.1.0.0 +toRawPM :: PackageMetadata -> RawPackageMetadata +toRawPM pm = RawPackageMetadata (Just name) (Just version) (Just $ pmTreeKey pm) + where + PackageIdentifier name version = pmIdent pm + +-- | File path relative to the configuration file it was parsed from +-- +-- @since 0.1.0.0 +newtype RelFilePath = RelFilePath Text + deriving (Show, ToJSON, FromJSON, Eq, Ord, Generic, Typeable, NFData, Display) + +-- | Location that an archive is stored at +-- +-- @since 0.1.0.0 +data ArchiveLocation + = ALUrl !Text + -- ^ Archive stored at an HTTP(S) URL + -- + -- @since 0.1.0.0 + | ALFilePath !(ResolvedPath File) + -- ^ Archive stored at a local file path + -- + -- @since 0.1.0.0 + deriving (Show, Eq, Ord, Generic, Typeable) + +instance NFData ArchiveLocation + +instance Display ArchiveLocation where + display (ALUrl url) = display url + display (ALFilePath resolved) = + fromString $ toFilePath $ resolvedAbsolute resolved + +instance Pretty ArchiveLocation where + pretty (ALUrl url) = style Url (fromString $ T.unpack url) + pretty (ALFilePath resolved) = pretty $ resolvedAbsolute resolved + +parseArchiveLocationObject :: + Object + -> WarningParser (Unresolved ArchiveLocation) +parseArchiveLocationObject o = + ((o ..: "url") >>= either (fail . T.unpack) pure . validateUrl) + <|> ((o ..: "filepath") >>= either (fail . T.unpack) pure . validateFilePath) + <|> ((o ..: "archive") >>= either (fail . T.unpack) pure . parseArchiveLocationText) + <|> ((o ..: "location") >>= either (fail . T.unpack) pure . parseArchiveLocationText) + +parseArchiveLocationText :: Text -> Either Text (Unresolved ArchiveLocation) +parseArchiveLocationText t = + case validateUrl t of + Left e1 -> + case validateFilePath t of + Left e2 -> Left $ T.unlines + [ "Invalid archive location, neither a URL nor a file path" + , " URL error: " <> e1 + , " File path error: " <> e2 + ] + Right x -> Right x + Right x -> Right x + +validateUrl :: Text -> Either Text (Unresolved ArchiveLocation) +validateUrl t = + case parseRequest $ T.unpack t of + Left _ -> Left $ "Could not parse URL: " <> t + Right _ -> pure $ pure $ ALUrl t + +validateFilePath :: Text -> Either Text (Unresolved ArchiveLocation) +validateFilePath t = + if any (`T.isSuffixOf` t) (T.words ".zip .tar .tar.gz") + then pure $ Unresolved $ \case + Nothing -> throwIO $ InvalidFilePathSnapshot t + Just dir -> do + abs' <- resolveFile dir $ T.unpack t + pure $ ALFilePath $ ResolvedPath (RelFilePath t) abs' + else Left $ "Does not have an archive file extension: " <> t + +instance ToJSON RawPackageLocation where + toJSON (RPLImmutable rpli) = toJSON rpli + toJSON (RPLMutable resolved) = toJSON (resolvedRelative resolved) + +instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocation))) where + parseJSON v = + (fmap . fmap . fmap . fmap) RPLImmutable (parseJSON v) <|> + (noJSONWarnings . mkMutable <$> parseJSON v) + where + mkMutable :: Text -> Unresolved (NonEmpty RawPackageLocation) + mkMutable t = Unresolved $ \mdir -> do + case mdir of + Nothing -> throwIO $ MutablePackageLocationFromUrl t + Just dir -> do + abs' <- resolveDir dir $ T.unpack t + pure $ pure $ RPLMutable $ ResolvedPath (RelFilePath t) abs' + +instance ToJSON RawPackageLocationImmutable where + toJSON (RPLIHackage pir mtree) = object $ + ("hackage" .= pir) : maybe [] (\tree -> ["pantry-tree" .= tree]) mtree + toJSON (RPLIArchive (RawArchive loc msha msize subdir) rpm) = object $ concat + [ case loc of + ALUrl url -> ["url" .= url] + ALFilePath resolved -> ["filepath" .= resolvedRelative resolved] + , maybe [] (\sha -> ["sha256" .= sha]) msha + , maybe [] (\size' -> ["size" .= size']) msize + , [ "subdir" .= subdir | not (T.null subdir) ] + , rpmToPairs rpm + ] + toJSON (RPLIRepo (Repo url commit typ subdir) rpm) = object $ concat + [ [ urlKey .= url + , "commit" .= commit + ] + , ["subdir" .= subdir | not (T.null subdir) ] + , rpmToPairs rpm + ] + where + urlKey = + case typ of + RepoGit -> "git" + RepoHg -> "hg" + +rpmToPairs :: RawPackageMetadata -> [(AesonKey, Value)] +rpmToPairs (RawPackageMetadata mname mversion mtree) = concat + [ maybe [] (\name -> ["name" .= CabalString name]) mname + , maybe [] (\version -> ["version" .= CabalString version]) mversion + , maybe [] (\tree -> ["pantry-tree" .= tree]) mtree + ] + +instance FromJSON (WithJSONWarnings (Unresolved PackageLocationImmutable)) where + parseJSON v = + repoObject v + <|> archiveObject v + <|> hackageObject v + <|> github v + <|> fail ("Could not parse a UnresolvedPackageLocationImmutable from: " ++ show v) + where + repoObject :: + Value + -> Parser (WithJSONWarnings (Unresolved PackageLocationImmutable)) + repoObject = + withObjectWarnings "UnresolvedPackageLocationImmutable.PLIRepo" $ \o -> do + pm <- parsePackageMetadata o + repoSubdir <- o ..:? "subdir" ..!= "" + repoCommit <- o ..: "commit" + (repoType, repoUrl) <- + (o ..: "git" >>= \url -> pure (RepoGit, url)) <|> + (o ..: "hg" >>= \url -> pure (RepoHg, url)) + pure $ pure $ PLIRepo Repo {..} pm + + archiveObject = + withObjectWarnings "UnresolvedPackageLocationImmutable.PLIArchive" $ \o -> do + pm <- parsePackageMetadata o + Unresolved mkArchiveLocation <- parseArchiveLocationObject o + archiveHash <- o ..: "sha256" + archiveSize <- o ..: "size" + archiveSubdir <- o ..:? "subdir" ..!= "" + pure $ Unresolved $ \mdir -> do + archiveLocation <- mkArchiveLocation mdir + pure $ PLIArchive Archive {..} pm + + hackageObject = + withObjectWarnings "UnresolvedPackagelocationimmutable.PLIHackage (Object)" $ \o -> do + treeKey <- o ..: "pantry-tree" + htxt <- o ..: "hackage" + case parseHackageText htxt of + Left e -> fail $ show e + Right (pkgIdentifier, blobKey) -> + pure $ pure $ PLIHackage pkgIdentifier blobKey (TreeKey treeKey) + + github = + withObjectWarnings "UnresolvedPackagelocationimmutable.PLIArchive:github" (\o -> do + pm <- parsePackageMetadata o + GitHubRepo ghRepo <- o ..: "github" + commit <- o ..: "commit" + let archiveLocation = ALUrl $ T.concat + [ "https://github.com/" + , ghRepo + , "/archive/" + , commit + , ".tar.gz" + ] + archiveHash <- o ..: "sha256" + archiveSize <- o ..: "size" + archiveSubdir <- o ..:? "subdir" ..!= "" + pure $ pure $ PLIArchive Archive {..} pm) + +instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) where + parseJSON v = + http v + <|> hackageText v + <|> hackageObject v + <|> repo v + <|> archiveObject v + <|> github v + <|> fail ("Could not parse a UnresolvedRawPackageLocationImmutable from: " ++ show v) + where + http :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) + http = withText "UnresolvedPackageLocationImmutable.RPLIArchive (Text)" $ \t -> + case parseArchiveLocationText t of + Left _ -> fail $ "Invalid archive location: " ++ T.unpack t + Right (Unresolved mkArchiveLocation) -> + pure $ noJSONWarnings $ Unresolved $ \mdir -> do + raLocation <- mkArchiveLocation mdir + let raHash = Nothing + raSize = Nothing + raSubdir = T.empty + pure $ pure $ RPLIArchive RawArchive {..} rpmEmpty + + hackageText = withText "UnresolvedPackageLocationImmutable.UPLIHackage (Text)" $ \t -> + case parsePackageIdentifierRevision t of + Left e -> fail $ show e + Right pir -> pure $ noJSONWarnings $ pure $ pure $ RPLIHackage pir Nothing + + hackageObject = withObjectWarnings "UnresolvedPackageLocationImmutable.UPLIHackage" $ \o -> pure . pure <$> (RPLIHackage + <$> o ..: "hackage" + <*> o ..:? "pantry-tree") + + optionalSubdirs :: Object -> WarningParser OptionalSubdirs + optionalSubdirs o = + -- if subdirs exists, it needs to be valid + case HM.lookup "subdirs" o of + Just v' -> do + tellJSONField "subdirs" + subdirs <- lift $ parseJSON v' + case NE.nonEmpty subdirs of + Nothing -> fail "Invalid empty subdirs" + Just x -> pure $ OSSubdirs x + Nothing -> OSPackageMetadata + <$> o ..:? "subdir" ..!= T.empty + <*> ( rawPackageMetadataHelper + <$> (fmap unCabalString <$> (o ..:? "name")) + <*> (fmap unCabalString <$> (o ..:? "version")) + <*> o ..:? "pantry-tree" + <*> o ..:? "cabal-file" + ) + + rawPackageMetadataHelper :: + Maybe PackageName + -> Maybe Version + -> Maybe TreeKey + -> Maybe BlobKey + -> RawPackageMetadata + rawPackageMetadataHelper name version pantryTree _ignoredCabalFile = + RawPackageMetadata name version pantryTree + + repo = withObjectWarnings "UnresolvedPackageLocationImmutable.UPLIRepo" $ \o -> do + (repoType, repoUrl) <- + ((RepoGit, ) <$> o ..: "git") <|> + ((RepoHg, ) <$> o ..: "hg") + repoCommit <- o ..: "commit" + os <- optionalSubdirs o + pure $ pure $ NE.map (\(repoSubdir, pm) -> RPLIRepo Repo {..} pm) (osToRpms os) + + archiveObject = withObjectWarnings "UnresolvedPackageLocationImmutable.RPLIArchive" $ \o -> do + Unresolved mkArchiveLocation <- parseArchiveLocationObject o + raHash <- o ..:? "sha256" + raSize <- o ..:? "size" + os <- optionalSubdirs o + pure $ Unresolved $ \mdir -> do + raLocation <- mkArchiveLocation mdir + pure $ NE.map (\(raSubdir, pm) -> RPLIArchive RawArchive {..} pm) (osToRpms os) + + github = withObjectWarnings "PLArchive:github" $ \o -> do + GitHubRepo ghRepo <- o ..: "github" + commit <- o ..: "commit" + let raLocation = ALUrl $ T.concat + [ "https://github.com/" + , ghRepo + , "/archive/" + , commit + , ".tar.gz" + ] + raHash <- o ..:? "sha256" + raSize <- o ..:? "size" + os <- optionalSubdirs o + pure $ pure $ + NE.map (\(raSubdir, pm) -> RPLIArchive RawArchive {..} pm) (osToRpms os) + +-- | Returns pairs of subdirectory and 'PackageMetadata'. +osToRpms :: OptionalSubdirs -> NonEmpty (Text, RawPackageMetadata) +osToRpms (OSSubdirs subdirs) = NE.map (, rpmEmpty) subdirs +osToRpms (OSPackageMetadata subdir rpm) = pure (subdir, rpm) + +rpmEmpty :: RawPackageMetadata +rpmEmpty = RawPackageMetadata Nothing Nothing Nothing + +-- | Newtype wrapper for easier JSON integration with Cabal types. +-- +-- @since 0.1.0.0 +newtype CabalString a = CabalString { unCabalString :: a } + deriving (Show, Eq, Ord, Typeable) + +-- I'd like to use coerce here, but can't due to roles. unsafeCoerce +-- could work, but let's avoid unsafe code. + +-- | Wrap the keys in a 'Map' with a 'CabalString' to get a 'ToJSON' +-- instance. +-- +-- @since 0.1.0.0 +toCabalStringMap :: Map a v -> Map (CabalString a) v +toCabalStringMap = Map.mapKeysMonotonic CabalString + +-- | Unwrap the 'CabalString' from the keys in a 'Map' to use a +-- 'FromJSON' instance. +-- +-- @since 0.1.0.0 +unCabalStringMap :: Map (CabalString a) v -> Map a v +unCabalStringMap = Map.mapKeysMonotonic unCabalString + +instance Distribution.Pretty.Pretty a => ToJSON (CabalString a) where + toJSON = toJSON . Distribution.Text.display . unCabalString + +instance Distribution.Pretty.Pretty a => ToJSONKey (CabalString a) where + toJSONKey = toJSONKeyText $ T.pack . Distribution.Text.display . unCabalString + +instance forall a. IsCabalString a => FromJSON (CabalString a) where + parseJSON = withText name $ \t -> + case cabalStringParser $ T.unpack t of + Nothing -> fail $ "Invalid " ++ name ++ ": " ++ T.unpack t + Just x -> pure $ CabalString x + where + name = cabalStringName (Nothing :: Maybe a) + +instance forall a. IsCabalString a => FromJSONKey (CabalString a) where + fromJSONKey = + FromJSONKeyTextParser $ \t -> + case cabalStringParser $ T.unpack t of + Nothing -> fail $ "Invalid " ++ name ++ ": " ++ T.unpack t + Just x -> pure $ CabalString x + where + name = cabalStringName (Nothing :: Maybe a) + +class IsCabalString a where + cabalStringName :: proxy a -> String + cabalStringParser :: String -> Maybe a + +instance IsCabalString PackageName where + cabalStringName _ = "package name" + cabalStringParser = parsePackageName + +instance IsCabalString Version where + cabalStringName _ = "version" + cabalStringParser = parseVersion + +instance IsCabalString VersionRange where + cabalStringName _ = "version range" + cabalStringParser = parseVersionRange + +instance IsCabalString PackageIdentifier where + cabalStringName _ = "package identifier" + cabalStringParser = parsePackageIdentifier + +instance IsCabalString FlagName where + cabalStringName _ = "flag name" + cabalStringParser = parseFlagName + +-- | What to use for running hpack +-- +-- @since 0.1.0.0 +data HpackExecutable + = HpackBundled + -- ^ Compiled in library + | HpackCommand !FilePath + -- ^ Executable at the provided path + deriving (Show, Read, Eq, Ord) + + +-- | Which compiler a snapshot wants to use. The build tool may elect to do some +-- fuzzy matching of versions (e.g., allowing different patch versions). +-- +-- @since 0.1.0.0 +data WantedCompiler + = WCGhc !Version + | WCGhcGit !Text !Text + | WCGhcjs + !Version + !Version + -- ^ GHCJS version followed by GHC version + deriving (Show, Eq, Ord, Generic) + +instance NFData WantedCompiler + +instance Display WantedCompiler where + display (WCGhc vghc) = "ghc-" <> fromString (versionString vghc) + display (WCGhcjs vghcjs vghc) = + "ghcjs-" + <> fromString (versionString vghcjs) + <> "_ghc-" <> fromString (versionString vghc) + display (WCGhcGit commit flavour) = + "ghc-git-" <> display commit <> "-" <> display flavour + +instance ToJSON WantedCompiler where + toJSON = toJSON . utf8BuilderToText . display + +instance FromJSON WantedCompiler where + parseJSON = + withText "WantedCompiler" $ either (fail . show) pure . parseWantedCompiler + +instance FromJSONKey WantedCompiler where + fromJSONKey = + FromJSONKeyTextParser $ \t -> + case parseWantedCompiler t of + Left e -> fail $ "Invalid WantedCompiler " ++ show t ++ ": " ++ show e + Right x -> pure x + +-- | Parse a 'Text' into a 'WantedCompiler' value. +-- +-- @since 0.1.0.0 +parseWantedCompiler :: Text -> Either PantryException WantedCompiler +parseWantedCompiler t0 = maybe (Left $ InvalidWantedCompiler t0) Right $ + case T.stripPrefix "ghcjs-" t0 of + Just t1 -> parseGhcjs t1 + Nothing -> case T.stripPrefix "ghc-git-" t0 of + Just t1 -> parseGhcGit t1 + Nothing -> T.stripPrefix "ghc-" t0 >>= parseGhc + where + parseGhcjs t1 = do + let (ghcjsVT, t2) = T.break (== '_') t1 + ghcjsV <- parseVersion $ T.unpack ghcjsVT + ghcVT <- T.stripPrefix "_ghc-" t2 + ghcV <- parseVersion $ T.unpack ghcVT + pure $ WCGhcjs ghcjsV ghcV + parseGhcGit t1 = do + let (commit, flavour) = T.break (== '-') t1 + pure $ WCGhcGit commit (T.drop 1 flavour) + parseGhc = fmap WCGhc . parseVersion . T.unpack + +instance FromJSON (WithJSONWarnings (Unresolved RawSnapshotLocation)) where + parseJSON v = text v <|> obj v + where + text :: Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLocation)) + text = + withText "UnresolvedSnapshotLocation (Text)" $ + pure . noJSONWarnings . parseRawSnapshotLocation + + obj :: Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLocation)) + obj = withObjectWarnings "UnresolvedSnapshotLocation (Object)" $ \o -> + (pure . RSLCompiler <$> o ..: "compiler") <|> + ((\x y -> pure $ RSLUrl x y) <$> o ..: "url" <*> blobKey o) <|> + (parseRawSnapshotLocationPath <$> o ..: "filepath") + + blobKey o = do + msha <- o ..:? "sha256" + msize <- o ..:? "size" + case (msha, msize) of + (Nothing, Nothing) -> pure Nothing + (Just sha, Just size') -> pure $ Just $ BlobKey sha size' + (Just _sha, Nothing) -> fail "You must also specify the file size" + (Nothing, Just _) -> fail "You must also specify the file's SHA256" + +instance Display SnapshotLocation where + display (SLCompiler compiler) = display compiler + display (SLUrl url blob) = display url <> " (" <> display blob <> ")" + display (SLFilePath resolved) = display (resolvedRelative resolved) + +-- | Parse a 'Text' into an 'Unresolved' 'RawSnapshotLocation'. +-- +-- @since 0.1.0.0 +parseRawSnapshotLocation :: Text -> Unresolved RawSnapshotLocation +parseRawSnapshotLocation t0 = fromMaybe (parseRawSnapshotLocationPath t0) $ + either (const Nothing) (Just . pure . RSLCompiler) (parseWantedCompiler t0) <|> + (pure . RSLSynonym <$> parseSnapName t0) <|> + parseGitHub <|> + parseUrl + where + parseGitHub = do + t1 <- T.stripPrefix "github:" t0 + let (user, t2) = T.break (== '/') t1 + t3 <- T.stripPrefix "/" t2 + let (repo, t4) = T.break (== ':') t3 + path <- T.stripPrefix ":" t4 + Just $ pure $ githubSnapshotLocation user repo path + + parseUrl = parseRequest (T.unpack t0) $> pure (RSLUrl t0 Nothing) + +parseRawSnapshotLocationPath :: Text -> Unresolved RawSnapshotLocation +parseRawSnapshotLocationPath t = + Unresolved $ \case + Nothing -> throwIO $ InvalidFilePathSnapshot t + Just dir -> do + abs' <- resolveFile dir (T.unpack t) `catchAny` \_ -> throwIO (InvalidSnapshotLocation dir t) + pure $ RSLFilePath $ ResolvedPath (RelFilePath t) abs' + +githubSnapshotLocation :: Text -> Text -> Text -> RawSnapshotLocation +githubSnapshotLocation user repo path = + let url = T.concat + [ "https://raw.githubusercontent.com/" + , user + , "/" + , repo + , "/master/" + , path + ] + in RSLUrl url Nothing + +defUser :: Text +defUser = "commercialhaskell" + +defRepo :: Text +defRepo = "stackage-snapshots" + +-- | Default location of snapshot synonyms, i.e. commercialhaskell's GitHub +-- repository. +-- +-- @since 0.5.0.0 +defaultSnapshotLocation :: + SnapName + -> RawSnapshotLocation +defaultSnapshotLocation (LTS x y) = + githubSnapshotLocation defUser defRepo $ + utf8BuilderToText $ + "lts/" <> display x <> "/" <> display y <> ".yaml" +defaultSnapshotLocation (Nightly date) = + githubSnapshotLocation defUser defRepo + $ utf8BuilderToText + $ "nightly/" + <> display year + <> "/" + <> display month + <> "/" + <> display day + <> ".yaml" + where + (year, month, day) = toGregorian date + +-- | A snapshot synonym. It is expanded according to the field +-- 'snapshotLocation' of a 'PantryConfig'. +-- +-- @ since 0.5.0.0 +data SnapName + = LTS + !Int -- ^ Major version + !Int -- ^ Minor version + -- ^ LTS Haskell snapshot, displayed as @"lts-maj.min"@. + -- + -- @since 0.5.0.0 + | Nightly !Day + -- ^ Stackage Nightly snapshot, displayed as @"nighly-YYYY-MM-DD"@. + -- + -- @since 0.5.0.0 + deriving (Eq, Ord, Generic) + +instance NFData SnapName + +instance Display SnapName where + display (LTS x y) = "lts-" <> display x <> "." <> display y + display (Nightly date) = "nightly-" <> displayShow date + +instance Show SnapName where + show = T.unpack . utf8BuilderToText . display + +instance ToJSON SnapName where + toJSON syn = String $ utf8BuilderToText $ display syn + +-- | Parse the short representation of a 'SnapName'. +-- +-- @since 0.5.0.0 +parseSnapName :: MonadThrow m => Text -> m SnapName +parseSnapName t0 = + case lts <|> nightly of + Nothing -> throwM $ ParseSnapNameException t0 + Just sn -> pure sn + where + lts = do + t1 <- T.stripPrefix "lts-" t0 + Right (x, t2) <- Just $ decimal t1 + t3 <- T.stripPrefix "." t2 + Right (y, "") <- Just $ decimal t3 + pure $ LTS x y + nightly = do + t1 <- T.stripPrefix "nightly-" t0 + Nightly <$> readMaybe (T.unpack t1) + +-- | Where to load a snapshot from in raw form (RSUrl could have a missing +-- BlobKey) +-- +-- @since 0.1.0.0 +data RawSnapshotLocation + = RSLCompiler !WantedCompiler + -- ^ Don't use an actual snapshot, just a version of the compiler with its + -- shipped packages. + -- + -- @since 0.1.0.0 + | RSLUrl !Text !(Maybe BlobKey) + -- ^ Download the snapshot from the given URL. The optional 'BlobKey' is + -- used for reproducibility. + -- + -- @since 0.1.0.0 + | RSLFilePath !(ResolvedPath File) + -- ^ Snapshot at a local file path. + -- + -- @since 0.1.0.0 + | RSLSynonym !SnapName + -- ^ Snapshot synonym (LTS/Nightly). + -- + -- @since 0.5.0.0 + deriving (Show, Eq, Ord, Generic) + +instance NFData RawSnapshotLocation + +instance Display RawSnapshotLocation where + display (RSLCompiler compiler) = display compiler + display (RSLUrl url Nothing) = display url + display (RSLUrl url (Just blob)) = display url <> " (" <> display blob <> ")" + display (RSLFilePath resolved) = display (resolvedRelative resolved) + display (RSLSynonym syn) = display syn + +instance Pretty RawSnapshotLocation where + pretty (RSLCompiler compiler) = fromString . T.unpack $ textDisplay compiler + pretty (RSLUrl url Nothing) = style Url (fromString $ T.unpack url) + pretty (RSLUrl url (Just blob)) = fillSep + [ style Url (fromString $ T.unpack url) + , parens (fromString . T.unpack $ textDisplay blob) + ] + pretty (RSLFilePath resolved) = + style File (fromString . T.unpack $ textDisplay (resolvedRelative resolved)) + pretty (RSLSynonym syn) = + style Shell (fromString . T.unpack $ textDisplay syn) + +instance ToJSON RawSnapshotLocation where + toJSON (RSLCompiler compiler) = object ["compiler" .= compiler] + toJSON (RSLUrl url mblob) = object + $ "url" .= url + : maybe [] blobKeyPairs mblob + toJSON (RSLFilePath resolved) = + object ["filepath" .= resolvedRelative resolved] + toJSON (RSLSynonym syn) = toJSON syn + +-- | Where to load a snapshot from. +-- +-- @since 0.1.0.0 +data SnapshotLocation + = SLCompiler !WantedCompiler + -- ^ Don't use an actual snapshot, just a version of the compiler + -- with its shipped packages. + -- + -- @since 0.1.0.0 + | SLUrl !Text !BlobKey + -- ^ Download the snapshot from the given URL. The optional + -- 'BlobKey' is used for reproducibility. + -- + -- @since 0.1.0.0 + | SLFilePath !(ResolvedPath File) + -- ^ Snapshot at a local file path. + -- + -- @since 0.1.0.0 + deriving (Show, Eq, Ord, Generic) + +instance NFData SnapshotLocation + +instance ToJSON SnapshotLocation where + toJSON sl = toJSON (toRawSL sl) + +instance FromJSON (WithJSONWarnings (Unresolved SnapshotLocation)) where + parseJSON v = file v <|> url v <|> compiler v + where + file = withObjectWarnings "SLFilepath" $ \o -> do + ufp <- o ..: "filepath" + pure $ Unresolved $ \case + Nothing -> throwIO $ InvalidFilePathSnapshot ufp + Just dir -> do + absolute <- resolveFile dir (T.unpack ufp) + let fp = ResolvedPath (RelFilePath ufp) absolute + pure $ SLFilePath fp + url = withObjectWarnings "SLUrl" $ \o -> do + url' <- o ..: "url" + sha <- o ..: "sha256" + size <- o ..: "size" + pure $ Unresolved $ \_ -> pure $ SLUrl url' (BlobKey sha size) + compiler = withObjectWarnings "SLCompiler" $ \o -> do + c <- o ..: "compiler" + pure $ Unresolved $ \_ -> pure $ SLCompiler c + +-- | Convert snapshot location to its "raw" equivalent. +-- +-- @since 0.1.0.0 +toRawSL :: SnapshotLocation -> RawSnapshotLocation +toRawSL (SLCompiler c) = RSLCompiler c +toRawSL (SLUrl url blob) = RSLUrl url (Just blob) +toRawSL (SLFilePath fp) = RSLFilePath fp + +-- | A flattened representation of all the layers in a snapshot. +-- +-- @since 0.1.0.0 +data RawSnapshot = RawSnapshot + { rsCompiler :: !WantedCompiler + -- ^ The compiler wanted for this snapshot. + , rsPackages :: !(Map PackageName RawSnapshotPackage) + -- ^ Packages available in this snapshot for installation. This will be + -- applied on top of any globally available packages. + , rsDrop :: !(Set PackageName) + -- ^ Global packages that should be dropped/ignored. + } + +-- | A flattened representation of all the layers in a snapshot. +-- +-- @since 0.1.0.0 +data Snapshot = Snapshot + { snapshotCompiler :: !WantedCompiler + -- ^ The compiler wanted for this snapshot. + , snapshotPackages :: !(Map PackageName SnapshotPackage) + -- ^ Packages available in this snapshot for installation. This will be + -- applied on top of any globally available packages. + , snapshotDrop :: !(Set PackageName) + -- ^ Global packages that should be dropped/ignored. + } + +-- | Settings for a package found in a snapshot. +-- +-- @since 0.1.0.0 +data RawSnapshotPackage = RawSnapshotPackage + { rspLocation :: !RawPackageLocationImmutable + -- ^ Where to get the package from + , rspFlags :: !(Map FlagName Bool) + -- ^ Same as 'slFlags' + , rspHidden :: !Bool + -- ^ Same as 'slHidden' + , rspGhcOptions :: ![Text] + -- ^ Same as 'slGhcOptions' + } + +-- | Settings for a package found in a snapshot. +-- +-- @since 0.1.0.0 +data SnapshotPackage = SnapshotPackage + { spLocation :: !PackageLocationImmutable + -- ^ Where to get the package from + , spFlags :: !(Map FlagName Bool) + -- ^ Same as 'slFlags' + , spHidden :: !Bool + -- ^ Same as 'slHidden' + , spGhcOptions :: ![Text] + -- ^ Same as 'slGhcOptions' + } + deriving Show + +-- | A single layer of a snapshot, i.e. a specific YAML configuration file. +-- +-- @since 0.1.0.0 +data RawSnapshotLayer = RawSnapshotLayer + { rslParent :: !RawSnapshotLocation + -- ^ The sl to extend from. This is either a specific compiler, or a + -- @SnapshotLocation@ which gives us more information (like packages). + -- Ultimately, we'll end up with a @CompilerVersion@. + -- + -- @since 0.1.0.0 + , rslCompiler :: !(Maybe WantedCompiler) + -- ^ Override the compiler specified in 'slParent'. Must be 'Nothing' if + -- using 'SLCompiler'. + -- + -- @since 0.1.0.0 + , rslLocations :: ![RawPackageLocationImmutable] + -- ^ Where to grab all of the packages from. + -- + -- @since 0.1.0.0 + , rslDropPackages :: !(Set PackageName) + -- ^ Packages present in the parent which should not be included here. + -- + -- @since 0.1.0.0 + , rslFlags :: !(Map PackageName (Map FlagName Bool)) + -- ^ Flag values to override from the defaults + -- + -- @since 0.1.0.0 + , rslHidden :: !(Map PackageName Bool) + -- ^ Packages which should be hidden when registering. This will affect, for + -- example, the import parser in the script command. We use a 'Map' instead + -- of just a 'Set' to allow overriding the hidden settings in a parent sl. + -- + -- @since 0.1.0.0 + , rslGhcOptions :: !(Map PackageName [Text]) + -- ^ GHC options per package + -- + -- @since 0.1.0.0 + , rslPublishTime :: !(Maybe UTCTime) + -- ^ See 'slPublishTime' + -- + -- @since 0.1.0.0 + } + deriving (Show, Eq, Generic) + +instance NFData RawSnapshotLayer + +instance ToJSON RawSnapshotLayer where + toJSON rsnap = object $ concat + [ ["resolver" .= rslParent rsnap] + , maybe [] (\compiler -> ["compiler" .= compiler]) (rslCompiler rsnap) + , ["packages" .= rslLocations rsnap] + , [ "drop-packages" .= Set.map CabalString (rslDropPackages rsnap) + | not (Set.null (rslDropPackages rsnap)) + ] + , [ "flags" .= fmap toCabalStringMap (toCabalStringMap (rslFlags rsnap)) + | not(Map.null (rslFlags rsnap)) + ] + , [ "hidden" .= toCabalStringMap (rslHidden rsnap) + | not (Map.null (rslHidden rsnap)) + ] + , [ "ghc-options" .= toCabalStringMap (rslGhcOptions rsnap) + | not (Map.null (rslGhcOptions rsnap)) + ] + , maybe [] (\time -> ["publish-time" .= time]) (rslPublishTime rsnap) + ] + +instance FromJSON (WithJSONWarnings (Unresolved RawSnapshotLayer)) where + parseJSON = withObjectWarnings "Snapshot" $ \o -> do + _ :: Maybe Text <- o ..:? "name" -- avoid warnings for old snapshot format + mcompiler <- o ..:? "compiler" + mresolver <- jsonSubWarningsT $ o ...:? ["snapshot", "resolver"] + unresolvedSnapshotParent <- + case (mcompiler, mresolver) of + (Nothing, Nothing) -> fail "Snapshot must have either resolver or compiler" + (Just compiler, Nothing) -> pure $ pure (RSLCompiler compiler, Nothing) + (_, Just (Unresolved usl)) -> pure $ Unresolved $ \mdir -> do + sl <- usl mdir + case (sl, mcompiler) of + (RSLCompiler c1, Just c2) -> throwIO $ InvalidOverrideCompiler c1 c2 + _ -> pure (sl, mcompiler) + + unresolvedLocs <- jsonSubWarningsT (o ..:? "packages" ..!= []) + rslDropPackages <- Set.map unCabalString <$> (o ..:? "drop-packages" ..!= Set.empty) + rslFlags <- unCabalStringMap . fmap unCabalStringMap <$> (o ..:? "flags" ..!= Map.empty) + rslHidden <- unCabalStringMap <$> (o ..:? "hidden" ..!= Map.empty) + rslGhcOptions <- unCabalStringMap <$> (o ..:? "ghc-options" ..!= Map.empty) + rslPublishTime <- o ..:? "publish-time" + pure $ (\rslLocations (rslParent, rslCompiler) -> RawSnapshotLayer {..}) + <$> (concatMap NE.toList <$> sequenceA unresolvedLocs) + <*> unresolvedSnapshotParent + +-- | A single layer of a snapshot, i.e. a specific YAML configuration file. +-- +-- @since 0.1.0.0 +data SnapshotLayer = SnapshotLayer + { slParent :: !SnapshotLocation + -- ^ The sl to extend from. This is either a specific compiler, or a + -- @SnapshotLocation@ which gives us more information (like packages). + -- Ultimately, we'll end up with a @CompilerVersion@. + -- + -- @since 0.1.0.0 + , slCompiler :: !(Maybe WantedCompiler) + -- ^ Override the compiler specified in 'slParent'. Must be 'Nothing' if + -- using 'SLCompiler'. + -- + -- @since 0.1.0.0 + , slLocations :: ![PackageLocationImmutable] + -- ^ Where to grab all of the packages from. + -- + -- @since 0.1.0.0 + , slDropPackages :: !(Set PackageName) + -- ^ Packages present in the parent which should not be included here. + -- + -- @since 0.1.0.0 + , slFlags :: !(Map PackageName (Map FlagName Bool)) + -- ^ Flag values to override from the defaults + -- + -- @since 0.1.0.0 + , slHidden :: !(Map PackageName Bool) + -- ^ Packages which should be hidden when registering. This will affect, for + -- example, the import parser in the script command. We use a 'Map' instead + -- of just a 'Set' to allow overriding the hidden settings in a parent sl. + -- + -- @since 0.1.0.0 + , slGhcOptions :: !(Map PackageName [Text]) + -- ^ GHC options per package + -- + -- @since 0.1.0.0 + , slPublishTime :: !(Maybe UTCTime) + -- ^ Publication timestamp for this snapshot. This field is optional, and is + -- for informational purposes only. + -- + -- @since 0.1.0.0 + } + deriving (Show, Eq, Generic) + +instance ToJSON SnapshotLayer where + toJSON snap = object $ concat + [ ["resolver" .= slParent snap] + , maybe [] (\compiler -> ["compiler" .= compiler]) (slCompiler snap) + , ["packages" .= slLocations snap] + , [ "drop-packages" .= Set.map CabalString (slDropPackages snap) + | not (Set.null (slDropPackages snap)) + ] + , [ "flags" .= fmap toCabalStringMap (toCabalStringMap (slFlags snap)) + | not (Map.null (slFlags snap)) + ] + , [ "hidden" .= toCabalStringMap (slHidden snap) + | not (Map.null (slHidden snap)) + ] + , [ "ghc-options" .= toCabalStringMap (slGhcOptions snap) + | not (Map.null (slGhcOptions snap)) + ] + , maybe [] (\time -> ["publish-time" .= time]) (slPublishTime snap) + ] + +-- | Convert snapshot layer into its "raw" equivalent. +-- +-- @since 0.1.0.0 +toRawSnapshotLayer :: SnapshotLayer -> RawSnapshotLayer +toRawSnapshotLayer sl = RawSnapshotLayer + { rslParent = toRawSL (slParent sl) + , rslCompiler = slCompiler sl + , rslLocations = map toRawPLI (slLocations sl) + , rslDropPackages = slDropPackages sl + , rslFlags = slFlags sl + , rslHidden = slHidden sl + , rslGhcOptions = slGhcOptions sl + , rslPublishTime = slPublishTime sl + } + +-- | An arbitrary hash for a snapshot, used for finding module names in a +-- snapshot. Mostly intended for Stack's usage. +-- +-- @since 0.1.0.0 +newtype SnapshotCacheHash = SnapshotCacheHash { unSnapshotCacheHash :: SHA256} + deriving (Show) + +-- | Get the path to the global hints cache file +getGlobalHintsFile :: HasPantryConfig env => RIO env (Path Abs File) +getGlobalHintsFile = do + root <- view $ pantryConfigL.to pcRootDir + globalHintsRelFile <- parseRelFile "global-hints-cache.yaml" + pure $ root </> globalHintsRelFile + +-- | Creates BlobKey for an input ByteString +-- +-- @since 0.1.0.0 +bsToBlobKey :: ByteString -> BlobKey +bsToBlobKey bs = + BlobKey (SHA256.hashBytes bs) (FileSize (fromIntegral (B.length bs))) + +-- | Warn if the package uses 'PCHpack'. +-- +-- @since 0.4.0.0 +warnMissingCabalFile :: HasLogFunc env => RawPackageLocationImmutable -> RIO env () +warnMissingCabalFile loc = + logWarn $ + "DEPRECATED: The package at " + <> display loc + <> " does not include a cabal file.\n" + <> "Instead, it includes an hpack package.yaml file for generating a cabal file.\n" + <> "This usage is deprecated; please see " + <> "https://github.com/commercialhaskell/stack/issues/5210.\n" + <> "Support for this workflow will be removed in the future.\n"
src/unix/System/IsWindows.hs view
@@ -1,9 +1,10 @@ {-# LANGUAGE NoImplicitPrelude #-} + module System.IsWindows ( osIsWindows ) where -import RIO (Bool (..)) +import RIO ( Bool (..) ) -- | False if not using Windows OS. osIsWindows :: Bool
src/windows/System/IsWindows.hs view
@@ -1,9 +1,10 @@ {-# LANGUAGE NoImplicitPrelude #-} + module System.IsWindows ( osIsWindows ) where -import RIO (Bool (..)) +import RIO ( Bool (..) ) -- | True if using Windows OS. osIsWindows :: Bool
test/Pantry/ArchiveSpec.hs view
@@ -1,15 +1,18 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -module Pantry.ArchiveSpec (spec) where +{-# LANGUAGE RecordWildCards #-} -import Test.Hspec -import Data.Maybe (fromJust) -import RIO -import RIO.Text as T -import Pantry -import Path.IO (resolveFile') +module Pantry.ArchiveSpec + ( spec + ) where +import Data.Maybe ( fromJust ) +import Pantry +import Path.IO ( resolveFile' ) +import RIO +import RIO.Text as T +import Test.Hspec + data TestLocation = TLFilePath String | TLUrl Text @@ -24,11 +27,11 @@ testLocation' <- case testLocation of TLFilePath relPath -> do absPath <- resolveFile' relPath - return $ ALFilePath $ ResolvedPath + pure $ ALFilePath $ ResolvedPath { resolvedRelative = RelFilePath $ fromString relPath , resolvedAbsolute = absPath } - TLUrl url -> return $ ALUrl url + TLUrl url -> pure $ ALUrl url let archive = RawArchive { raLocation = testLocation' , raHash = Nothing
test/Pantry/BuildPlanSpec.hs view
@@ -3,14 +3,14 @@ module Pantry.BuildPlanSpec where -import Pantry.Internal.AesonExtended (WithJSONWarnings(..)) -import RIO +import Control.Monad.Catch ( MonadThrow ) import qualified Data.ByteString.Char8 as S8 -import Data.Yaml (decodeThrow) +import Data.List.NonEmpty ( NonEmpty ) +import Data.Yaml ( decodeThrow ) import Pantry +import Pantry.Internal.AesonExtended ( WithJSONWarnings(..) ) +import RIO import Test.Hspec -import Control.Monad.Catch (MonadThrow) -import Data.List.NonEmpty (NonEmpty) spec :: Spec spec =
test/Pantry/CabalSpec.hs view
@@ -1,13 +1,16 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -module Pantry.CabalSpec (spec) where -import Test.Hspec -import Pantry +module Pantry.CabalSpec + ( spec + ) where + +import Distribution.Types.PackageName ( mkPackageName ) +import Distribution.Types.Version ( mkVersion ) +import Pantry import qualified Pantry.SHA256 as SHA256 -import RIO -import Distribution.Types.PackageName (mkPackageName) -import Distribution.Types.Version (mkVersion) +import RIO +import Test.Hspec spec :: Spec spec = describe "wrong cabal file" $ do
test/Pantry/CasaSpec.hs view
@@ -1,10 +1,13 @@ {-# LANGUAGE OverloadedStrings #-} -module Pantry.CasaSpec (spec) where -import Distribution.Types.Version (mkVersion) -import Pantry -import Pantry.SHA256 -import Test.Hspec +module Pantry.CasaSpec + ( spec + ) where + +import Distribution.Types.Version ( mkVersion ) +import Pantry +import Pantry.SHA256 +import Test.Hspec spec :: Spec spec = do
test/Pantry/FileSpec.hs view
@@ -1,10 +1,12 @@-module Pantry.FileSpec (spec) where +module Pantry.FileSpec + ( spec + ) where -import Test.Hspec -import Pantry -import Path -import Path.IO -import Control.Monad (void) +import Control.Monad ( void ) +import Pantry +import Path +import Path.IO +import Test.Hspec spec :: Spec spec = describe "loadCabalFilePath" $ do
test/Pantry/GlobalHintsSpec.hs view
@@ -1,16 +1,19 @@-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -module Pantry.GlobalHintsSpec (spec) where -import Distribution.Types.PackageName (mkPackageName) -import Distribution.Version (mkVersion) -import RIO -import Pantry (loadGlobalHints, WantedCompiler (..), runPantryAppClean) +module Pantry.GlobalHintsSpec + ( spec + ) where + +import Distribution.Types.PackageName ( mkPackageName ) +import Distribution.Version ( mkVersion ) +import Pantry ( WantedCompiler (..), loadGlobalHints, runPantryAppClean ) import Pantry.Internal -import Test.Hspec +import Path ( toFilePath ) +import RIO import qualified RIO.Map as Map -import Path (toFilePath) +import Test.Hspec spec :: Spec spec = do
test/Pantry/HackageSpec.hs view
@@ -1,11 +1,14 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -module Pantry.HackageSpec (spec) where -import Test.Hspec -import Pantry -import RIO -import Distribution.Types.Version (mkVersion) +module Pantry.HackageSpec + ( spec + ) where + +import Distribution.Types.Version ( mkVersion ) +import Pantry +import RIO +import Test.Hspec spec :: Spec spec = do
test/Pantry/Internal/StaticBytesSpec.hs view
@@ -1,20 +1,23 @@-{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE NoImplicitPrelude #-} -module Pantry.Internal.StaticBytesSpec (spec) where -import RIO -import Pantry.Internal.StaticBytes -import Control.Monad (replicateM) +module Pantry.Internal.StaticBytesSpec + ( spec + ) where + +import Control.Monad ( replicateM ) import qualified Data.ByteString as B -import qualified Data.Vector.Unboxed as VU -import qualified Data.Vector.Primitive as VP -import qualified Data.Vector.Storable as VS -import Test.Hspec -import Test.Hspec.QuickCheck -import Test.QuickCheck import qualified Data.Text as T import qualified Data.Text.Encoding as TE +import qualified Data.Vector.Primitive as VP +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Unboxed as VU +import Pantry.Internal.StaticBytes +import RIO +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck spec :: Spec spec = do
test/Pantry/InternalSpec.hs view
@@ -1,8 +1,11 @@-module Pantry.InternalSpec (spec) where +module Pantry.InternalSpec + ( spec + ) where -import Test.Hspec -import Pantry (runPantryApp) -import Pantry.Internal (normalizeParents, makeTarRelative, hpackVersion) +import Pantry ( runPantryApp ) +import Pantry.Internal + ( hpackVersion, makeTarRelative, normalizeParents ) +import Test.Hspec spec :: Spec spec = do
test/Pantry/TreeSpec.hs view
@@ -1,13 +1,16 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -module Pantry.TreeSpec (spec) where -import Test.Hspec -import RIO -import Pantry +module Pantry.TreeSpec + ( spec + ) where + +import Distribution.Types.PackageName ( mkPackageName ) +import Distribution.Types.Version ( mkVersion ) +import Pantry import qualified Pantry.SHA256 as SHA256 -import Distribution.Types.PackageName (mkPackageName) -import Distribution.Types.Version (mkVersion) +import RIO +import Test.Hspec spec :: Spec spec = do
test/Pantry/TypesSpec.hs view
@@ -1,37 +1,34 @@-{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} module Pantry.TypesSpec ( spec ) where -import Pantry.Internal.AesonExtended import qualified Data.ByteString.Char8 as S8 import qualified Data.Yaml as Yaml -import Distribution.Types.PackageName (mkPackageName) -import Distribution.Types.Version (mkVersion) -import Hedgehog +import Distribution.Types.PackageName ( mkPackageName ) +import Distribution.Types.Version ( mkVersion ) +import Hedgehog import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range -import Pantry -import Pantry.Internal - ( Tree(..) - , TreeEntry(..) - , mkSafeFilePath - , parseTree - , renderTree - ) +import Pantry +import Pantry.Internal + ( Tree (..), TreeEntry (..), mkSafeFilePath, parseTree + , renderTree + ) +import Pantry.Internal.AesonExtended import qualified Pantry.SHA256 as SHA256 -import RIO +import RIO import qualified RIO.Text as T -import Test.Hspec -import Text.RawString.QQ -import RIO.Time (Day (..)) +import RIO.Time ( Day (..) ) +import Test.Hspec +import Text.RawString.QQ hh :: HasCallStack => String -> Property -> Spec hh name p = it name $ do