diff --git a/app/Foliage/Meta.hs b/app/Foliage/Meta.hs index b5642d8..93de8a9 100644 --- a/app/Foliage/Meta.hs +++ b/app/Foliage/Meta.hs @@ -37,10 +37,11 @@ import Data.Maybe (fromMaybe) import Data.Ord (Down (Down)) import Data.Text (Text) import Data.Text qualified as T -import Data.Time.LocalTime (utc, utcToZonedTime, zonedTimeToUTC) import Development.Shake.Classes (Binary, Hashable, NFData) import Distribution.Aeson () import Distribution.Types.Orphans () +import Foliage.Meta.Hash (SHA256, sha256Codec) +import Foliage.Meta.Toml (timeCodec) import Foliage.Time (UTCTime) import GHC.Generics (Generic) import Network.URI (URI, parseURI) @@ -111,6 +112,8 @@ data PackageVersionSpec = PackageVersionSpec packageVersionTimestamp :: Maybe UTCTime, -- | source parameters packageVersionSource :: PackageVersionSource, + -- | source distribution hash + packageVersionHash :: Maybe SHA256, -- | revisions packageVersionRevisions :: [RevisionSpec], -- | deprecations @@ -128,6 +131,8 @@ sourceMetaCodec = .= packageVersionTimestamp <*> packageSourceCodec .= packageVersionSource + <*> Toml.dioptional sha256Codec + .= packageVersionHash <*> Toml.list revisionMetaCodec "revisions" .= packageVersionRevisions <*> Toml.list deprecationMetaCodec "deprecations" @@ -174,16 +179,13 @@ deprecationMetaCodec = <*> withDefault True (Toml.bool "deprecated") .= deprecationIsDeprecated -timeCodec :: Toml.Key -> TomlCodec UTCTime -timeCodec key = Toml.dimap (utcToZonedTime utc) zonedTimeToUTC $ Toml.zonedTime key - latestRevisionNumber :: PackageVersionSpec -> Maybe Int latestRevisionNumber sm = case sortOn (Down . revisionNumber) (packageVersionRevisions sm) of [] -> Nothing rev : _ -> Just (revisionNumber rev) -withDefault :: Eq a => a -> TomlCodec a -> TomlCodec a +withDefault :: (Eq a) => a -> TomlCodec a -> TomlCodec a withDefault d c = (fromMaybe d <$> Toml.dioptional c) .= f where f a = if a == d then Nothing else Just a diff --git a/app/Foliage/Meta/Hash.hs b/app/Foliage/Meta/Hash.hs new file mode 100644 index 0000000..5eb3814 --- /dev/null +++ b/app/Foliage/Meta/Hash.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} + +module Foliage.Meta.Hash + ( SHA256 (SHA256, unSHA256), + readFileHashValue, + sha256Codec, + hashlazy, + ) +where + +import Control.Category ((>>>)) +import Control.Monad ((>=>)) +import Crypto.Hash.SHA256 qualified as SHA256 +import Data.Aeson +import Data.Aeson.Types (parseFail) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Base64 (decodeBase64, encodeBase64) +import Data.ByteString.Lazy qualified as BL +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Development.Shake.Classes +import Foliage.Meta.Toml +import GHC.Generics (Generic) +import Toml qualified + +newtype SHA256 = SHA256 {unSHA256 :: ByteString} + deriving (Eq, Generic) + deriving anyclass (Binary, Hashable, NFData) + +instance Show SHA256 where + show (SHA256 bs) = show (T.unpack $ encodeBase64 bs) + +instance ToJSON SHA256 where + toJSON (SHA256 bs) = toJSON (encodeBase64 bs) + +instance FromJSON SHA256 where + parseJSON = + parseJSON + >=> either (parseFail . T.unpack) (pure . SHA256) . decodeBase64 . T.encodeUtf8 + +sha256Codec :: Toml.TomlCodec SHA256 +sha256Codec = Toml.match (Toml.iso unSHA256 SHA256 >>> _ByteStringBase16) "sha256" + +readFileHashValue :: FilePath -> IO SHA256 +readFileHashValue = fmap (SHA256 . SHA256.hash) . BS.readFile + +hashlazy :: BL.ByteString -> SHA256 +hashlazy = SHA256 . SHA256.hashlazy diff --git a/app/Foliage/Meta/Toml.hs b/app/Foliage/Meta/Toml.hs new file mode 100644 index 0000000..798012a --- /dev/null +++ b/app/Foliage/Meta/Toml.hs @@ -0,0 +1,27 @@ +module Foliage.Meta.Toml where + +import Control.Category ((>>>)) +import Data.ByteString (ByteString) +import Data.ByteString.Base16 (decodeBase16', encodeBase16) +import Data.Text (Text) +import Foliage.Time (UTCTime, utc, utcToZonedTime, zonedTimeToUTC) +import Toml (TomlCodec) +import Toml qualified + +timeCodec :: Toml.Key -> TomlCodec UTCTime +timeCodec key = Toml.dimap (utcToZonedTime utc) zonedTimeToUTC $ Toml.zonedTime key + +-- | Like 'Toml.Codec.BiMap.Conversion._ByteStringText' but uses base16 encoding +_ByteStringTextBase16 :: Toml.TomlBiMap ByteString Text +_ByteStringTextBase16 = Toml.invert $ Toml.prism encodeBase16 eitherByteString + where + eitherByteString :: Text -> Either Toml.TomlBiMapError ByteString + eitherByteString = either (Left . Toml.ArbitraryError) Right . decodeBase16' + +-- | Like 'Toml.Codec.BiMap.Conversion._ByteString' but uses base16 encoding +_ByteStringBase16 :: Toml.TomlBiMap ByteString Toml.AnyValue +_ByteStringBase16 = _ByteStringTextBase16 >>> Toml._Text + +-- | Like 'Toml.Codec.Combinator.Primitive.byteString' but uses base16 encoding +byteStringBase16 :: Toml.Key -> TomlCodec ByteString +byteStringBase16 = Toml.match _ByteStringBase16 diff --git a/app/Foliage/Paths.hs b/app/Foliage/Paths.hs new file mode 100644 index 0000000..b9aa332 --- /dev/null +++ b/app/Foliage/Paths.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TypeFamilies #-} + +module Foliage.Paths where + +-- let scheme = dropWhileEnd (not . isAlpha) $ uriScheme uri +-- +-- let host = maybe (error $ "invalid uri " ++ show uri) uriRegName (uriAuthority uri) +-- +-- let path = cacheDir joinPath (scheme : host : pathSegments uri) diff --git a/app/Foliage/PreparePackageVersion.hs b/app/Foliage/PreparePackageVersion.hs index ed6867c..7b7ed2b 100644 --- a/app/Foliage/PreparePackageVersion.hs +++ b/app/Foliage/PreparePackageVersion.hs @@ -33,10 +33,13 @@ import Distribution.Pretty (prettyShow) import Distribution.Types.GenericPackageDescription (GenericPackageDescription (packageDescription)) import Distribution.Types.PackageDescription (PackageDescription (package)) import Distribution.Types.PackageId +import Foliage.HackageSecurity (anchorRepoPathLocally, repoLayoutPkgTarGz) import Foliage.Meta (DeprecationSpec (..), PackageVersionSource, PackageVersionSpec (..), RevisionSpec (..), UTCTime, latestRevisionNumber) import Foliage.PrepareSdist (prepareSdist) import Foliage.PrepareSource (prepareSource) import Foliage.Shake (readGenericPackageDescription', readPackageVersionSpec') +import Hackage.Security.Client (hackageRepoLayout) +import Hackage.Security.Util.Path (toFilePath) import System.FilePath (takeBaseName, takeFileName, (<.>), ()) -- TODO: can we ensure that `pkgVersionDeprecationChanges` and `cabalFileRevisions` are @@ -172,6 +175,10 @@ preparePackageVersion inputDir metaFile = do pkgDesc <- readGenericPackageDescription' cabalFilePath + let packagePath = repoLayoutPkgTarGz hackageRepoLayout pkgId + path = toFilePath $ anchorRepoPathLocally outputDirRoot packagePath + + -- IO.createDirectoryIfMissing True (takeDirectory path) sdistPath <- prepareSdist srcDir let expectedSdistName = prettyShow pkgId <.> "tar.gz" diff --git a/app/Foliage/PrepareSdist.hs b/app/Foliage/PrepareSdist.hs index 3f461b1..a9b7f01 100644 --- a/app/Foliage/PrepareSdist.hs +++ b/app/Foliage/PrepareSdist.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE TypeFamilies #-} @@ -9,41 +10,53 @@ module Foliage.PrepareSdist where import Control.Monad (when) -import Crypto.Hash.SHA256 qualified as SHA256 import Data.Binary qualified as Binary import Data.ByteString qualified as BS -import Data.ByteString.Base16 import Data.ByteString.Lazy qualified as BSL -import Data.Text qualified as T import Development.Shake import Development.Shake.Classes import Development.Shake.FilePath import Development.Shake.Rule import Distribution.Client.SrcDist (packageDirToSdist) -import Distribution.Package (packageId) +import Distribution.Package (PackageId, packageId) import Distribution.Simple.PackageDescription (readGenericPackageDescription) +import Distribution.Types.Orphans () import Distribution.Verbosity qualified as Verbosity import Foliage.HackageSecurity -import Foliage.Meta () +import Foliage.Meta.Hash import GHC.Generics (Generic) import Hackage.Security.Util.Path (toFilePath) import System.Directory qualified as IO import System.IO.Error (tryIOError) -newtype PrepareSdistRule = PrepareSdistRule FilePath +-- newtype SDist = SDist PackageId +-- deriving (Show, Eq, Generic) +-- deriving newtype (Hashable, Binary, NFData) +-- +-- type instance RuleResult SDist = () +-- +-- data SDistRule = SDistRule SDist (Action ()) +-- +-- sdistRule :: PackageId -> Action () -> Rules () +-- sdistRule pkgId act = addUserRule $ SDistRule (SDist pkgId) act +-- +-- sdistNeed :: PackageId -> Action () +-- sdistNeed = apply1 . SDist +-- +data PrepareSdistRule = PrepareSdistRule FilePath (Maybe SHA256) deriving (Show, Eq, Generic) deriving (Hashable, Binary, NFData) type instance RuleResult PrepareSdistRule = FilePath -prepareSdist :: FilePath -> Action FilePath -prepareSdist srcDir = apply1 $ PrepareSdistRule srcDir +prepareSdist :: FilePath -> Maybe SHA256 -> Action FilePath +prepareSdist srcDir mHash = apply1 $ PrepareSdistRule srcDir mHash addPrepareSdistRule :: Path Absolute -> Rules () addPrepareSdistRule outputDirRoot = addBuiltinRule noLint noIdentity run where run :: PrepareSdistRule -> Maybe BS.ByteString -> RunMode -> Action (RunResult FilePath) - run (PrepareSdistRule srcDir) (Just old) RunDependenciesSame = do + run (PrepareSdistRule srcDir mHash) (Just old) RunDependenciesSame = do let (hvExpected, path) = load old -- Check of has of the sdist, if the sdist is still there and it is @@ -55,12 +68,12 @@ addPrepareSdistRule outputDirRoot = addBuiltinRule noLint noIdentity run | hvExisting == hvExpected -> return RunResult {runChanged = ChangedNothing, runStore = old, runValue = path} Right hvExisting -> do - putWarn $ "Changed " ++ path ++ " (expecting hash " ++ showHashValue hvExpected ++ " found " ++ showHashValue hvExisting ++ "). I will rebuild it." - run (PrepareSdistRule srcDir) (Just old) RunDependenciesChanged + putWarn $ "Changed " ++ path ++ " (expecting hash " ++ show hvExpected ++ " found " ++ show hvExisting ++ "). I will rebuild it." + run (PrepareSdistRule srcDir mHash) (Just old) RunDependenciesChanged Left _e -> do putWarn $ "Unable to read " ++ path ++ ". I will rebuild it." - run (PrepareSdistRule srcDir) (Just old) RunDependenciesChanged - run (PrepareSdistRule srcDir) old _mode = do + run (PrepareSdistRule srcDir mHash) (Just old) RunDependenciesChanged + run (PrepareSdistRule srcDir mHash) old _mode = do -- create the sdist distribution (hv, path) <- makeSdist srcDir @@ -71,10 +84,10 @@ addPrepareSdistRule outputDirRoot = addBuiltinRule noLint noIdentity run _differentOrMissing -> ChangedRecomputeDiff when (changed == ChangedRecomputeSame) $ - putInfo ("Wrote " ++ path ++ " (same hash " ++ showHashValue hv ++ ")") + putInfo ("Wrote " ++ path ++ " (same hash " ++ show hv ++ ")") when (changed == ChangedRecomputeDiff) $ - putInfo ("Wrote " ++ path ++ " (new hash " ++ showHashValue hv ++ ")") + putInfo ("Wrote " ++ path ++ " (new hash " ++ show hv ++ ")") return $ RunResult {runChanged = changed, runStore = new, runValue = path} @@ -98,16 +111,10 @@ addPrepareSdistRule outputDirRoot = addBuiltinRule noLint noIdentity run IO.createDirectoryIfMissing True (takeDirectory path) sdist <- packageDirToSdist Verbosity.normal gpd srcDir BSL.writeFile path sdist - return (SHA256.hashlazy sdist, path) + return (hashlazy sdist, path) - save :: (BS.ByteString, FilePath) -> BS.ByteString + save :: (SHA256, FilePath) -> BS.ByteString save = BSL.toStrict . Binary.encode - load :: BS.ByteString -> (BS.ByteString, FilePath) + load :: BS.ByteString -> (SHA256, FilePath) load = Binary.decode . BSL.fromStrict - -readFileHashValue :: FilePath -> IO BS.ByteString -readFileHashValue = fmap SHA256.hash . BS.readFile - -showHashValue :: BS.ByteString -> [Char] -showHashValue = T.unpack . encodeBase16 diff --git a/app/Foliage/Shake.hs b/app/Foliage/Shake.hs index a28883a..93d305e 100644 --- a/app/Foliage/Shake.hs +++ b/app/Foliage/Shake.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TypeFamilies #-} + module Foliage.Shake ( computeFileInfoSimple', readKeysAt, @@ -8,6 +10,7 @@ where import Data.Traversable (for) import Development.Shake +import Development.Shake.Classes import Development.Shake.FilePath import Distribution.Simple.PackageDescription import Distribution.Types.GenericPackageDescription @@ -15,6 +18,16 @@ import Distribution.Verbosity qualified as Verbosity import Foliage.HackageSecurity import Foliage.Meta +newtype CacheDir = CacheDir () + deriving (Show, Typeable, Eq, Hashable, Binary, NFData) + +type instance RuleResult CacheDir = FilePath + +newtype OutputDir = OutputDir () + deriving (Show, Typeable, Eq, Hashable, Binary, NFData) + +type instance RuleResult OutputDir = FilePath + computeFileInfoSimple' :: FilePath -> Action FileInfo computeFileInfoSimple' fp = do need [fp] diff --git a/app/Foliage/Time.hs b/app/Foliage/Time.hs index 0e16286..073b3d3 100644 --- a/app/Foliage/Time.hs +++ b/app/Foliage/Time.hs @@ -4,12 +4,10 @@ module Foliage.Time ( iso8601ParseM, iso8601Show, - getCurrentTime, - UTCTime (..), - utcTimeToPOSIXSeconds, - addUTCTime, - nominalDay, truncateSeconds, + module Data.Time, + module Data.Time.LocalTime, + module Data.Time.Clock.POSIX, ) where @@ -17,6 +15,7 @@ import Data.Time import Data.Time.Clock.POSIX import Data.Time.Compat () import Data.Time.Format.ISO8601 +import Data.Time.LocalTime import Development.Shake.Classes instance Binary UTCTime where diff --git a/cabal.project b/cabal.project index 50c2224..1552626 100644 --- a/cabal.project +++ b/cabal.project @@ -1,3 +1,5 @@ +with-compiler: ghc-9.2 + +index-state: 2023-05-30T03:40:17Z + packages: . -index-state: 2023-03-17T03:33:00Z -with-compiler: ghc-9.2.7 diff --git a/foliage.cabal b/foliage.cabal index b694cd6..30c9a3b 100644 --- a/foliage.cabal +++ b/foliage.cabal @@ -24,8 +24,11 @@ executable foliage Foliage.HackageSecurity Foliage.Meta Foliage.Meta.Aeson + Foliage.Meta.Hash + Foliage.Meta.Toml Foliage.Options Foliage.Pages + Foliage.Paths Foliage.PreparePackageVersion Foliage.PrepareSource Foliage.PrepareSdist @@ -45,6 +48,7 @@ executable foliage base >=4.14.3.0 && <4.18, aeson >=2.0.3.0 && <2.2, base16 >=0.3.2.0 && <0.4, + base64 >=0.4.2.4 && <0.5, binary >=0.8.9.0 && <0.9, bytestring >=0.10.12.0 && <0.12, Cabal >=3.10 && <3.11,