From 6805a3f4c6f341812e9b6e4dc28cff6c1e47290b Mon Sep 17 00:00:00 2001
From: IC Rainbow <aenor.realm@gmail.com>
Date: Wed, 16 Jun 2021 21:53:50 +0300
Subject: [PATCH] Support deeper subdirectory for github

---
 CHANGELOG.md        |  3 +++
 hpack.cabal         |  2 +-
 package.yaml        |  2 +-
 src/Hpack/Config.hs | 35 +++++++++++++++++++++++++++++++----
 4 files changed, 36 insertions(+), 6 deletions(-)

diff --git a/CHANGELOG.md b/CHANGELOG.md
index 0f71e774..ce1053a6 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,3 +1,6 @@
+## Changes in 0.34.5
+  - Support deeper subdirectory for github
+
 ## Changes in 0.34.4
   - Render `default-extensions` / `other-extensions` line-separated
   - Compatibility with `Cabal-3.4.0.0`
diff --git a/hpack.cabal b/hpack.cabal
index fbb84654..58b67a1e 100644
--- a/hpack.cabal
+++ b/hpack.cabal
@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           hpack
-version:        0.34.4
+version:        0.34.5
 synopsis:       A modern format for Haskell packages
 description:    See README at <https://github.com/sol/hpack#readme>
 category:       Development
diff --git a/package.yaml b/package.yaml
index 6ac03a37..890abe19 100644
--- a/package.yaml
+++ b/package.yaml
@@ -1,5 +1,5 @@
 name: hpack
-version: 0.34.4
+version: 0.34.5
 synopsis: A modern format for Haskell packages
 description: See README at <https://github.com/sol/hpack#readme>
 maintainer: Simon Hengel <sol@typeful.net>
diff --git a/src/Hpack/Config.hs b/src/Hpack/Config.hs
index aa42fe55..752d8684 100644
--- a/src/Hpack/Config.hs
+++ b/src/Hpack/Config.hs
@@ -583,10 +583,37 @@ data GitHub = GitHub {
 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
+    let parsed = case map T.unpack $ T.splitOn "/" input of
+          -- Bad: empty: ""
+          [] ->
+            Nothing
+
+          -- Bad: starts with a slash: "/..."
+          "" : _rest ->
+            Nothing
+
+          -- Bad: starts with an URL-like protocol: "https:...", "git:..."
+          proto : _rest | last proto == ':' ->
+            Nothing
+
+          -- Bad: single path piece: "sol"
+          [_owner] ->
+            Nothing
+
+          -- Good: "sol/hpack"
+          [owner, repo] ->
+
+            Just $ GitHub owner repo Nothing
+
+          -- Good: "sol/hpack/subdir", "sol/hpack/deep/subdir/..."
+          owner : repo : subdirs ->
+            Just $ GitHub owner repo (Just $ intercalate "/" subdirs)
+
+    case parsed of
+      Nothing ->
+        fail $ "expected \"owner/repo\" or \"owner/repo/subdir\", but encountered " ++ show input
+      Just ok ->
+        return ok
 
 data DefaultsConfig = DefaultsConfig {
   defaultsConfigDefaults :: Maybe (List Defaults)