Allow pinning the content of remote sources with hashes

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

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

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

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)

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"

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

app/Foliage/Shake.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE TypeFamilies #-}
+
 module Foliage.Shake
   ( computeFileInfoSimple',
     readKeysAt,
@@ -8,13 +10,24 @@ where
 
 import Data.Traversable (for)
 import Development.Shake
+import Development.Shake.Classes
 import Development.Shake.FilePath
 import Distribution.Simple.PackageDescription
 import Distribution.Types.GenericPackageDescription
 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]

app/Foliage/Time.hs

@@ -4,19 +4,18 @@
 module Foliage.Time
   ( iso8601ParseM,
     iso8601Show,
-    getCurrentTime,
-    UTCTime (..),
-    utcTimeToPOSIXSeconds,
-    addUTCTime,
-    nominalDay,
     truncateSeconds,
+    module Data.Time,
+    module Data.Time.LocalTime,
+    module Data.Time.Clock.POSIX,
   )
 where
 
 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

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

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,