Reject URLs for github

CHANGELOG.md

@@ -1,5 +1,6 @@
 ## Changes in 0.34.0 (upcoming)
   - Add support for library `visibility` (see #382)
+  - Reject URLs for `github`
 
 ## Changes in 0.33.0
   - Support GHC 8.8.1: `fail` is no longer a part of `Monad`. Instead, it lives

src/Hpack/Config.hs

@@ -534,7 +534,7 @@ data PackageConfig_ library executable = PackageConfig {
 , packageConfigExtraDocFiles :: Maybe (List FilePath)
 , packageConfigDataFiles :: Maybe (List FilePath)
 , packageConfigDataDir :: Maybe FilePath
-, packageConfigGithub :: Maybe Text
+, packageConfigGithub :: Maybe GitHub
 , packageConfigGit :: Maybe String
 , packageConfigCustomSetup :: Maybe CustomSetupSection
 , packageConfigLibrary :: Maybe library
@@ -545,6 +545,20 @@ data PackageConfig_ library executable = PackageConfig {
 , packageConfigBenchmarks :: Maybe (Map String executable)
 } deriving Generic
 
+data GitHub = GitHub {
+  _gitHubOwner :: String
+, _gitHubRepo :: String
+, _gitHubSubdir :: Maybe String
+}
+
+instance FromValue GitHub where
+  fromValue v = do
+    input <- fromValue v
+    case map T.unpack $ T.splitOn "/" input of
+      [owner, repo, subdir] -> return $ GitHub owner repo (Just subdir)
+      [owner, repo] -> return $ GitHub owner repo Nothing
+      _ -> fail $ "expected owner/repo or owner/repo/subdir, but encountered " ++ show input
+
 data DefaultsConfig = DefaultsConfig {
   defaultsConfigDefaults :: Maybe (List Defaults)
 } deriving (Generic, FromValue)
@@ -1149,13 +1163,10 @@ toPackage_ dir (Product g PackageConfig{..}) = do
     sourceRepository = github <|> (`SourceRepository` Nothing) <$> packageConfigGit
 
     github :: Maybe SourceRepository
-    github = parseGithub <$> packageConfigGithub
+    github = toSourceRepository <$> packageConfigGithub
       where
-        parseGithub :: Text -> SourceRepository
+        toSourceRepository :: GitHub -> SourceRepository
-        parseGithub input = case map T.unpack $ T.splitOn "/" input of
+        toSourceRepository (GitHub repo owner subdir) = SourceRepository (githubBaseUrl ++ owner ++ "/" ++ repo) subdir
-          [owner, repo, subdir] ->
-            SourceRepository (githubBaseUrl ++ owner ++ "/" ++ repo) (Just subdir)
-          _ -> SourceRepository (githubBaseUrl ++ T.unpack input) Nothing
 
     homepage :: Maybe String
     homepage = case packageConfigHomepage of

test/EndToEndSpec.hs

@@ -132,6 +132,11 @@ spec = around_ (inTempDirectoryNamed "foo") $ do
           subdir: hspec-core
         |]
 
+      it "rejects URLs" $ do
+        [i|
+        github: https://github.com/sol/hpack/issues/365
+        |] `shouldFailWith` "package.yaml: Error while parsing $.github - expected owner/repo or owner/repo/subdir, but encountered \"https://github.com/sol/hpack/issues/365\""
+
     describe "homepage" $ do
       it "accepts homepage URL" $ do
         [i|