mirror of
https://github.com/input-output-hk/foliage.git
synced 2024-09-11 12:25:55 +03:00
Implement GitHub backend
This commit is contained in:
parent
cbb726a6f5
commit
9151ec36b2
@ -10,6 +10,7 @@ import Data.ByteString.Lazy qualified as BSL
|
||||
import Data.Foldable (for_)
|
||||
import Data.List (sortOn)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text qualified as T
|
||||
import Data.Traversable (for)
|
||||
import Development.Shake
|
||||
import Development.Shake.FilePath
|
||||
@ -27,6 +28,7 @@ import Foliage.Shake
|
||||
import Foliage.Shake.Oracle
|
||||
import Foliage.Time qualified as Time
|
||||
import Foliage.UpdateCabalFile (rewritePackageVersion)
|
||||
import Network.URI
|
||||
import System.Directory qualified as IO
|
||||
|
||||
cmdBuild :: BuildOptions -> IO ()
|
||||
@ -138,6 +140,33 @@ cmdBuild
|
||||
tdir = fix2 $ fix1 tmpDir
|
||||
|
||||
cmd_ ["cp", "--recursive", "--no-target-directory", "--dereference", tdir, srcDir]
|
||||
--
|
||||
-- This is almost identical to the above but we get to keep the
|
||||
-- metadata.
|
||||
--
|
||||
GitHubSource repo rev mSubdir -> do
|
||||
let url =
|
||||
nullURI
|
||||
{ uriScheme = "https:",
|
||||
uriAuthority = Just nullURIAuth {uriRegName = "github.com"},
|
||||
uriPath = "/" </> T.unpack (unGitHubRepo repo) </> "tarball" </> T.unpack (unGitHubRev rev)
|
||||
}
|
||||
tarballPath <- remoteAssetNeed url
|
||||
withTempDir $ \tmpDir -> do
|
||||
cmd_ ["tar", "xzf", tarballPath, "-C", tmpDir]
|
||||
|
||||
-- Special treatment of top-level directory: we remove it
|
||||
--
|
||||
-- Note: Don't let shake look into tmpDir! it will cause
|
||||
-- unnecessary rework because tmpDir is always new
|
||||
ls <- liftIO $ IO.getDirectoryContents tmpDir
|
||||
let ls' = filter (not . all (== '.')) ls
|
||||
|
||||
let fix1 = case ls' of [l] -> (</> l); _ -> id
|
||||
fix2 = case mSubdir of Just s -> (</> s); _ -> id
|
||||
tdir = fix2 $ fix1 tmpDir
|
||||
|
||||
cmd_ ["cp", "--recursive", "--no-target-directory", "--dereference", tdir, srcDir]
|
||||
|
||||
applyPatches inputDir srcDir pkgId
|
||||
|
||||
|
@ -18,6 +18,7 @@ import Distribution.Pretty (prettyShow)
|
||||
import Distribution.Types.PackageName (unPackageName)
|
||||
import Foliage.Meta
|
||||
import Foliage.Options
|
||||
import Network.URI hiding (path)
|
||||
import System.Directory (createDirectoryIfMissing)
|
||||
import System.Environment (getEnv)
|
||||
import System.FilePath
|
||||
@ -78,9 +79,13 @@ importIndex _f Tar.Done m =
|
||||
importIndex _f (Tar.Fail e) _ =
|
||||
error $ show e
|
||||
|
||||
pkgIdToHackageUrl :: PackageIdentifier -> String
|
||||
pkgIdToHackageUrl :: PackageIdentifier -> URI
|
||||
pkgIdToHackageUrl pkgId =
|
||||
"https://hackage.haskell.org/package" </> prettyShow pkgId </> prettyShow pkgId <.> "tar.gz"
|
||||
nullURI
|
||||
{ uriScheme = "https:",
|
||||
uriAuthority = Just $ nullURIAuth {uriRegName = "hackage.haskell.org"},
|
||||
uriPath = "/package" </> prettyShow pkgId </> prettyShow pkgId <.> "tar.gz"
|
||||
}
|
||||
|
||||
finalise ::
|
||||
PackageIdentifier ->
|
||||
|
@ -20,16 +20,21 @@ module Foliage.Meta
|
||||
revisionNumber,
|
||||
PackageVersionSource,
|
||||
pattern TarballSource,
|
||||
pattern GitHubSource,
|
||||
GitHubRepo (..),
|
||||
GitHubRev (..),
|
||||
UTCTime,
|
||||
latestRevisionNumber,
|
||||
consolidateRanges,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Monad (void)
|
||||
import Data.List (sortOn)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Ord
|
||||
import Data.Text (Text)
|
||||
import Data.Text qualified as T
|
||||
import Data.Time.LocalTime (utc, utcToZonedTime, zonedTimeToUTC)
|
||||
import Development.Shake.Classes
|
||||
@ -54,6 +59,8 @@ import Distribution.Version
|
||||
)
|
||||
import Foliage.Time (UTCTime)
|
||||
import GHC.Generics (Generic)
|
||||
import Network.URI
|
||||
import Network.URI.Orphans ()
|
||||
import Toml (TomlCodec, (.=))
|
||||
import Toml qualified
|
||||
|
||||
@ -105,23 +112,56 @@ _VersionRange = Toml._TextBy showVersion parseVersion
|
||||
Nothing -> Left $ T.pack $ "unable to parse version" ++ T.unpack t
|
||||
Just v -> Right v
|
||||
|
||||
newtype GitHubRepo = GitHubRepo {unGitHubRepo :: Text}
|
||||
deriving (Show, Eq, Binary, Hashable, NFData) via Text
|
||||
|
||||
newtype GitHubRev = GitHubRev {unGitHubRev :: Text}
|
||||
deriving (Show, Eq, Binary, Hashable, NFData) via Text
|
||||
|
||||
data PackageVersionSource
|
||||
= TarballSource String (Maybe String)
|
||||
= TarballSource URI (Maybe String)
|
||||
| GitHubSource GitHubRepo GitHubRev (Maybe String)
|
||||
deriving (Show, Eq, Generic)
|
||||
deriving anyclass (Binary, Hashable, NFData)
|
||||
|
||||
packageSourceCodec :: TomlCodec PackageVersionSource
|
||||
packageSourceCodec =
|
||||
Toml.dimatch matchTarballSource (uncurry TarballSource) tarballSourceCodec
|
||||
<|> Toml.dimatch matchGitHubSource (\((repo, rev), mSubdir) -> GitHubSource repo rev mSubdir) githubSourceCodec
|
||||
|
||||
tarballSourceCodec :: TomlCodec (String, Maybe String)
|
||||
uri :: Toml.Key -> TomlCodec URI
|
||||
uri = Toml.textBy to from
|
||||
where
|
||||
to = T.pack . show
|
||||
from t = case parseURI (T.unpack t) of
|
||||
Nothing -> Left $ "Invalid url: " <> t
|
||||
Just uri' -> Right uri'
|
||||
|
||||
tarballSourceCodec :: TomlCodec (URI, Maybe String)
|
||||
tarballSourceCodec =
|
||||
Toml.pair
|
||||
(Toml.string "url")
|
||||
(uri "url")
|
||||
(Toml.dioptional $ Toml.string "subdir")
|
||||
|
||||
matchTarballSource :: PackageVersionSource -> Maybe (String, Maybe String)
|
||||
matchTarballSource :: PackageVersionSource -> Maybe (URI, Maybe String)
|
||||
matchTarballSource (TarballSource url mSubdir) = Just (url, mSubdir)
|
||||
matchTarballSource _ = Nothing
|
||||
|
||||
gitHubRepo :: Toml.Key -> TomlCodec GitHubRepo
|
||||
gitHubRepo = Toml.dimap unGitHubRepo GitHubRepo . Toml.text
|
||||
|
||||
gitHubRev :: Toml.Key -> TomlCodec GitHubRev
|
||||
gitHubRev = Toml.dimap unGitHubRev GitHubRev . Toml.text
|
||||
|
||||
githubSourceCodec :: TomlCodec ((GitHubRepo, GitHubRev), Maybe String)
|
||||
githubSourceCodec =
|
||||
Toml.pair
|
||||
(Toml.table (Toml.pair (gitHubRepo "repo") (gitHubRev "rev")) "github")
|
||||
(Toml.dioptional $ Toml.string "subdir")
|
||||
|
||||
matchGitHubSource :: PackageVersionSource -> Maybe ((GitHubRepo, GitHubRev), Maybe String)
|
||||
matchGitHubSource (GitHubSource repo rev mSubdir) = Just ((repo, rev), mSubdir)
|
||||
matchGitHubSource _ = Nothing
|
||||
|
||||
data PackageVersionMeta = PackageVersionMeta
|
||||
{ -- | timestamp
|
||||
|
@ -8,6 +8,7 @@ module Foliage.RemoteAsset
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad (unless)
|
||||
import Data.ByteString qualified as BS
|
||||
import Data.Char (isAlpha)
|
||||
import Data.List (dropWhileEnd)
|
||||
@ -16,33 +17,38 @@ import Development.Shake
|
||||
import Development.Shake.Classes
|
||||
import Development.Shake.FilePath
|
||||
import Development.Shake.Rule
|
||||
import Network.URI (URI (uriAuthority, uriFragment, uriQuery, uriScheme), URIAuth (uriRegName), pathSegments)
|
||||
import Network.URI.Orphans ()
|
||||
import System.Directory (createDirectoryIfMissing)
|
||||
import System.FilePath.Posix qualified as Posix
|
||||
|
||||
type Url = String
|
||||
|
||||
newtype RemoteAsset = RemoteAsset Url
|
||||
newtype RemoteAsset = RemoteAsset URI
|
||||
deriving (Show, Eq)
|
||||
deriving (Hashable, Binary, NFData) via Url
|
||||
deriving (Hashable, Binary, NFData) via URI
|
||||
|
||||
type instance RuleResult RemoteAsset = FilePath
|
||||
|
||||
data RemoteAssetRule = RemoteAssetRule RemoteAsset (Action FilePath)
|
||||
|
||||
remoteAssetRule :: Url -> Action FilePath -> Rules ()
|
||||
remoteAssetRule :: URI -> Action FilePath -> Rules ()
|
||||
remoteAssetRule url act = addUserRule $ RemoteAssetRule (RemoteAsset url) act
|
||||
|
||||
remoteAssetNeed :: Url -> Action FilePath
|
||||
remoteAssetNeed :: URI -> Action FilePath
|
||||
remoteAssetNeed = apply1 . RemoteAsset
|
||||
|
||||
addBuiltinRemoteAssetRule :: FilePath -> Rules ()
|
||||
addBuiltinRemoteAssetRule cacheDir = addBuiltinRule noLint noIdentity run
|
||||
where
|
||||
run :: BuiltinRun RemoteAsset FilePath
|
||||
run (RemoteAsset url) old _mode = do
|
||||
let scheme : rest = Posix.splitPath url
|
||||
scheme' = dropWhileEnd (not . isAlpha) scheme
|
||||
path = cacheDir </> joinPath (scheme' : rest)
|
||||
run (RemoteAsset uri) old _mode = do
|
||||
unless (uriQuery uri == "") $
|
||||
fail $ "Query elements in URI are not supported: " <> show uri
|
||||
|
||||
unless (uriFragment uri == "") $
|
||||
fail $ "Fragments in URI are not supported: " <> show uri
|
||||
|
||||
let scheme = dropWhileEnd (not . isAlpha) $ uriScheme uri
|
||||
Just host = uriRegName <$> uriAuthority uri
|
||||
path = cacheDir </> joinPath (scheme : host : pathSegments uri)
|
||||
|
||||
-- parse etag from store
|
||||
let oldETag = fromMaybe BS.empty old
|
||||
@ -51,7 +57,7 @@ addBuiltinRemoteAssetRule cacheDir = addBuiltinRule noLint noIdentity run
|
||||
withTempFile $ \fp -> do
|
||||
liftIO $ BS.writeFile fp oldETag
|
||||
liftIO $ createDirectoryIfMissing True (takeDirectory path)
|
||||
cmd_ Shell ["curl", "--silent", "--location", "--etag-compare", fp, "--etag-save", fp, "--output", path, url]
|
||||
cmd_ Shell ["curl", "--silent", "--location", "--etag-compare", fp, "--etag-save", fp, "--output", path, show uri]
|
||||
liftIO $ BS.readFile fp
|
||||
|
||||
let changed = if newETag == oldETag then ChangedNothing else ChangedRecomputeDiff
|
||||
|
14
app/Network/URI/Orphans.hs
Normal file
14
app/Network/URI/Orphans.hs
Normal file
@ -0,0 +1,14 @@
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module Network.URI.Orphans where
|
||||
|
||||
import Development.Shake.Classes
|
||||
import Network.URI
|
||||
|
||||
instance Binary URIAuth
|
||||
|
||||
instance Binary URI
|
||||
|
||||
instance Hashable URIAuth
|
||||
|
||||
instance Hashable URI
|
@ -27,6 +27,7 @@ executable foliage
|
||||
Foliage.Shake.Oracle
|
||||
Foliage.Time
|
||||
Foliage.UpdateCabalFile
|
||||
Network.URI.Orphans
|
||||
|
||||
default-language: Haskell2010
|
||||
default-extensions:
|
||||
@ -46,6 +47,7 @@ executable foliage
|
||||
directory >=1.3.6.0 && <1.4,
|
||||
filepath >=1.4.2.1 && <1.5,
|
||||
hackage-security >=0.6.2.1 && <0.7,
|
||||
network-uri ^>=2.6.4.1,
|
||||
optparse-applicative >=0.17.0.0 && <0.18,
|
||||
shake >=0.19.6 && <0.20,
|
||||
tar >=0.5.1.1 && <0.6,
|
||||
|
Loading…
Reference in New Issue
Block a user