Implement GitHub backend

app/Foliage/CmdBuild.hs

@@ -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
 

app/Foliage/CmdImportIndex.hs

@@ -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 ->

app/Foliage/Meta.hs

@@ -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

app/Foliage/RemoteAsset.hs

@@ -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

app/Network/URI/Orphans.hs

@@ -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

foliage.cabal

@@ -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,