Allow 'github' shorthand for extra-deps (fixes commercialhaskell#3873)

mitchellwrosen · mitchellwrosen · commit f702547f133c · 2018-02-24T22:25:12.000-05:00
diff --git a/src/Data/Aeson/Extended.hs b/src/Data/Aeson/Extended.hs
@@ -150,7 +150,7 @@ instance IsString WarningParserMonoid where
 
 -- Parsed JSON value with its warnings
 data WithJSONWarnings a = WithJSONWarnings a [JSONWarning]
-    deriving Generic
+    deriving (Eq, Generic, Show)
 instance Functor WithJSONWarnings where
     fmap f (WithJSONWarnings x w) = WithJSONWarnings (f x) w
 instance Monoid a => Monoid (WithJSONWarnings a) where
@@ -160,6 +160,7 @@ instance Monoid a => Monoid (WithJSONWarnings a) where
 -- | Warning output from 'WarningParser'.
 data JSONWarning = JSONUnrecognizedFields String [Text]
                  | JSONGeneralWarning !Text
+    deriving Eq
 instance Show JSONWarning where
     show (JSONUnrecognizedFields obj [field]) =
         "Unrecognized field in " <> obj <> ": " <> T.unpack field
diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs
@@ -237,6 +237,7 @@ instance subdirs ~ Subdirs => FromJSON (WithJSONWarnings (PackageLocation subdir
         = (noJSONWarnings <$> withText "PackageLocation" (\t -> http t <|> file t) v)
         <|> repo v
         <|> archiveObject v
+        <|> github v
       where
         file t = pure $ PLFilePath $ T.unpack t
         http t =
@@ -269,6 +270,26 @@ instance subdirs ~ Subdirs => FromJSON (WithJSONWarnings (PackageLocation subdir
             , archiveHash = msha'
             }
 
+        github = withObjectWarnings "PLArchive" $ \o -> do
+          GitHubRepo ghRepo <- o ..: "github"
+          commit <- o ..: "commit"
+          subdirs <- o ..:? "subdirs" ..!= DefaultSubdirs
+          return $ PLArchive Archive
+            { archiveUrl = "https://github.com/" <> ghRepo <> "/archive/" <> commit <> ".tar.gz"
+            , archiveSubdirs = subdirs
+            , archiveHash = Nothing
+            }
+
+-- An unexported newtype wrapper to hang a 'FromJSON' instance off of. Contains
+-- a GitHub user and repo name separated by a forward slash, e.g. "foo/bar".
+newtype GitHubRepo = GitHubRepo Text
+
+instance FromJSON GitHubRepo where
+    parseJSON = withText "GitHubRepo" $ \s -> do
+        case T.split (== '/') s of
+            [x, y] | not (T.null x || T.null y) -> return (GitHubRepo s)
+            _ -> fail "expecting \"user/repo\""
+
 -- | Name of an executable.
 newtype ExeName = ExeName { unExeName :: Text }
     deriving (Show, Eq, Ord, Hashable, IsString, Generic, Store, NFData, Data, Typeable)
diff --git a/src/test/Stack/Types/BuildPlanSpec.hs b/src/test/Stack/Types/BuildPlanSpec.hs
@@ -0,0 +1,94 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Stack.Types.BuildPlanSpec where
+
+import           Data.Aeson.Extended (WithJSONWarnings(..))
+import           Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as S8
+import           Data.Yaml (decode)
+import           Stack.Types.BuildPlan
+import           Test.Hspec
+
+spec :: Spec
+spec =
+  describe "PackageLocation" $ do
+    describe "Archive" $ do
+      describe "github" $ do
+        let decode' :: ByteString -> Maybe (WithJSONWarnings (PackageLocation Subdirs))
+            decode' = decode
+
+        it "'github' and 'commit' keys" $ do
+          let contents :: ByteString
+              contents =
+                S8.pack
+                  (unlines
+                    [ "github: oink/town"
+                    , "commit: abc123"
+                    ])
+          let expected :: PackageLocation Subdirs
+              expected =
+                PLArchive Archive
+                  { archiveUrl = "https://github.com/oink/town/archive/abc123.tar.gz"
+                  , archiveSubdirs = DefaultSubdirs
+                  , archiveHash = Nothing
+                  }
+          decode' contents `shouldBe` Just (WithJSONWarnings expected [])
+
+        it "'github', 'commit', and 'subdirs' keys" $ do
+          let contents :: ByteString
+              contents =
+                S8.pack
+                  (unlines
+                    [ "github: oink/town"
+                    , "commit: abc123"
+                    , "subdirs:"
+                    , "  - foo"
+                    ])
+          let expected :: PackageLocation Subdirs
+              expected =
+                PLArchive Archive
+                  { archiveUrl = "https://github.com/oink/town/archive/abc123.tar.gz"
+                  , archiveSubdirs = ExplicitSubdirs ["foo"]
+                  , archiveHash = Nothing
+                  }
+          decode' contents `shouldBe` Just (WithJSONWarnings expected [])
+
+        it "does not parse GitHub repo with no slash" $ do
+          let contents :: ByteString
+              contents =
+                S8.pack
+                  (unlines
+                    [ "github: oink"
+                    , "commit: abc123"
+                    ])
+          decode' contents `shouldBe` Nothing
+
+        it "does not parse GitHub repo with leading slash" $ do
+          let contents :: ByteString
+              contents =
+                S8.pack
+                  (unlines
+                    [ "github: /oink"
+                    , "commit: abc123"
+                    ])
+          decode' contents `shouldBe` Nothing
+
+        it "does not parse GitHub repo with trailing slash" $ do
+          let contents :: ByteString
+              contents =
+                S8.pack
+                  (unlines
+                    [ "github: oink/"
+                    , "commit: abc123"
+                    ])
+          decode' contents `shouldBe` Nothing
+
+        it "does not parse GitHub repo with more than one slash" $ do
+          let contents :: ByteString
+              contents =
+                S8.pack
+                  (unlines
+                    [ "github: oink/town/here"
+                    , "commit: abc123"
+                    ])
+          decode' contents `shouldBe` Nothing
