Add ability to clone private repos

The strategy is to clone over https with the OAuth token:

  git clone https://<user>:<oauth-token>@github.com/<user>/<repo>

1 files changed, 133 insertions, 53 deletions

diff --git a/Biz/Devalloc.hs b/Biz/Devalloc.hs
index 28bf50e..cafe9fa 100644
--- a/Biz/Devalloc.hs
+++ b/Biz/Devalloc.hs
@@ -83,7 +83,7 @@ import Data.Data (Data, Typeable)
 import Data.IxSet (Indexable (..), IxSet, ixFun, ixSet, (&&&), (@=))
 import qualified Data.IxSet as IxSet
 import qualified Data.List as List
-import Data.SafeCopy (base, deriveSafeCopy)
+import Data.SafeCopy (base, deriveSafeCopy, extension)
 import qualified Data.SafeCopy as SafeCopy
 import qualified Data.Set as Set
 import qualified Data.String as String
@@ -123,7 +123,9 @@ import qualified Web.FormUrlEncoded as Web
 -- the `SafeCopy.Migrate T` class compile, then make changes to `T`. If you
 -- don't, there will be a runtime exception when you try to start the new
 -- service. I'm not sure how to guard against this, except maybe run a test
--- deployment by copying a database backup locally, or something.
+-- deployment by copying a database backup locally, or something:
+--     rm -rf _/var/devalloc
+--     rsync -avz /var/devalloc/ _/var
 
 newtype UserEmail = UserEmail {unUserEmail :: Maybe Text}
   deriving (Eq, Ord, Data, Typeable, Generic, Show)
@@ -158,6 +160,15 @@ instance Auth.FromJWT GitHubId
 
 $(deriveSafeCopy 0 'base ''GitHubId)
 
+newtype GitHubHandle = GitHubHandle {unGitHubHandle :: Text}
+  deriving (Eq, Ord, Data, Typeable, Generic, Show)
+
+instance Aeson.ToJSON GitHubHandle
+
+instance Aeson.FromJSON GitHubHandle
+
+$(deriveSafeCopy 0 'base ''GitHubHandle)
+
 data Subscription = Free | Invoice
   deriving (Eq, Data, Typeable, Ord, Generic, Show)
 
@@ -178,10 +189,23 @@ instance Auth.FromJWT Subscription
 
 $(deriveSafeCopy 0 'base ''Subscription)
 
+data User0 = User0
+  { userEmail :: UserEmail,
+    userGitHubId :: GitHubId,
+    -- | So we can make GitHub API calls on their behalf.
+    userGitHubToken :: Text,
+    userSubscription :: Subscription,
+    userId :: Id.Id User0
+  }
+  deriving (Eq, Data, Typeable, Ord, Generic, Show)
+
+$(deriveSafeCopy 0 'base ''User0)
+
 -- | The main representation of a user.
 data User = User
   { userEmail :: UserEmail,
     userGitHubId :: GitHubId,
+    userGitHubHandle :: GitHubHandle,
     -- | So we can make GitHub API calls on their behalf.
     userGitHubToken :: Text,
     userSubscription :: Subscription,
@@ -197,7 +221,16 @@ instance Auth.ToJWT User
 
 instance Auth.FromJWT User
 
-$(deriveSafeCopy 0 'base ''User)
+instance SafeCopy.Migrate User where
+  type MigrateFrom User = User0
+  migrate User0 {..} =
+    User
+      { userId = Id.mk (Proxy :: Proxy User) <| Id.untag userId,
+        userGitHubHandle = GitHubHandle "unknown",
+        ..
+      }
+
+$(deriveSafeCopy 1 'extension ''User)
 
 instance Indexable User where
   empty =
@@ -317,7 +350,7 @@ $(deriveSafeCopy 0 'base ''Keep)
 createUser :: User -> Acid.Update Keep User
 createUser u = do
   keep <- get
-  let newUser = u {userId = nextUserId keep}
+  let newUser = u {userId = nextUserId keep} :: User
   put
     <| keep
       { users = IxSet.insert newUser (users keep),
@@ -368,9 +401,9 @@ getAllAnalyses = do
   pure <| IxSet.toList analyses
 
 getAnalysesByAsker :: User -> Acid.Query Keep [Analysis]
-getAnalysesByAsker user = do
+getAnalysesByAsker User {..} = do
   Keep {..} <- ask
-  pure <| IxSet.toList <| analyses @= userId user
+  pure <| IxSet.toList <| analyses @= userId
 
 getAnalysesByUrl :: URL -> Acid.Query Keep [Analysis]
 getAnalysesByUrl url = do
@@ -420,6 +453,8 @@ upsertGitHubUser keep tok ghUser =
           User
             { userEmail = UserEmail <| GitHub.userEmail ghUser,
               userGitHubId = GitHubId <. GitHub.untagId <| GitHub.userId ghUser,
+              userGitHubHandle =
+                GitHubHandle <| GitHub.untagName <| GitHub.userLogin ghUser,
               userGitHubToken = Encoding.decodeUtf8 tok,
               userSubscription = Free,
               userId = mempty
@@ -433,36 +468,37 @@ test_upsertGitHubUser load =
     "upsertUser"
     [ Test.unit "userId is not mempty" <| do
         (_, _, k) <- load
-        Right User {..} <- upsertGitHubUser k "token" ghUser
+        Right User {..} <- upsertGitHubUser k "token" mock_ghUser
         userId @?!= mempty,
       Test.unit "creates user when email is empty" <| do
         (_, _, k) <- load
-        Right User {..} <- upsertGitHubUser k "token" ghUser {GitHub.userEmail = Nothing}
+        Right User {..} <- upsertGitHubUser k "token" mock_ghUser {GitHub.userEmail = Nothing}
         userEmail @?!= UserEmail Nothing
     ]
-  where
-    ghUser =
-      GitHub.User
-        { GitHub.userId = GitHub.mkId (Proxy :: Proxy GitHub.User) 123,
-          GitHub.userEmail = Just "user@example.com",
-          GitHub.userLogin = "example",
-          GitHub.userName = Nothing,
-          GitHub.userType = GitHub.OwnerUser,
-          GitHub.userCreatedAt =
-            Time.UTCTime (Time.ModifiedJulianDay 1) (Time.secondsToDiffTime 100),
-          GitHub.userPublicGists = 123,
-          GitHub.userAvatarUrl = GitHub.URL "http://example.com",
-          GitHub.userFollowers = 0,
-          GitHub.userFollowing = 0,
-          GitHub.userHireable = Nothing,
-          GitHub.userBlog = Nothing,
-          GitHub.userBio = Nothing,
-          GitHub.userPublicRepos = 0,
-          GitHub.userLocation = Nothing,
-          GitHub.userCompany = Nothing,
-          GitHub.userUrl = GitHub.URL "http://example.com",
-          GitHub.userHtmlUrl = GitHub.URL "http://example.com"
-        }
+
+mock_ghUser :: GitHub.User
+mock_ghUser =
+  GitHub.User
+    { GitHub.userId = GitHub.mkId (Proxy :: Proxy GitHub.User) 123,
+      GitHub.userEmail = Just "user@example.com",
+      GitHub.userLogin = "user",
+      GitHub.userName = Nothing,
+      GitHub.userType = GitHub.OwnerUser,
+      GitHub.userCreatedAt =
+        Time.UTCTime (Time.ModifiedJulianDay 1) (Time.secondsToDiffTime 100),
+      GitHub.userPublicGists = 123,
+      GitHub.userAvatarUrl = GitHub.URL "http://example.com",
+      GitHub.userFollowers = 0,
+      GitHub.userFollowing = 0,
+      GitHub.userHireable = Nothing,
+      GitHub.userBlog = Nothing,
+      GitHub.userBio = Nothing,
+      GitHub.userPublicRepos = 0,
+      GitHub.userLocation = Nothing,
+      GitHub.userCompany = Nothing,
+      GitHub.userUrl = GitHub.URL "http://example.com",
+      GitHub.userHtmlUrl = GitHub.URL "http://example.com"
+    }
 
 init :: Keep
 init =
@@ -558,6 +594,7 @@ test =
   Test.group
     "Biz.Devalloc"
     [ test_calculateScore,
+      test_spliceCreds,
       Test.with
         (startup True)
         (\t@(c, _, _) -> shutdown t >> tidy c)
@@ -839,7 +876,7 @@ htmlApp cooks kp cfg jwk oAuthArgs =
             -- we just assume github for now
             analyzeGitHub
               kp
-              userId
+              user
               (userGitHubAuth userGitHubToken)
               (depo cfg)
               owner
@@ -1524,12 +1561,37 @@ authorsFor gitDir path =
           )
       )
 
+spliceCreds :: User -> Text -> Text
+spliceCreds User {..} url =
+  scheme <> "//" <> unGitHubHandle userGitHubHandle <> ":" <> userGitHubToken <> "@" <> Text.drop 2 rest
+  where
+    (scheme, rest) = Text.breakOn "//" url
+
+test_spliceCreds :: Test.Tree
+test_spliceCreds =
+  Test.group
+    "spliceCreds"
+    [ Test.unit "simple happy path"
+        <| "https://user:token@github.com/owner/repo"
+        @=? spliceCreds mock_user "https://github.com/owner/repo"
+    ]
+  where
+    mock_user =
+      User
+        { userEmail = UserEmail <| Just "user@example.com",
+          userGitHubHandle = GitHubHandle "user",
+          userGitHubId = GitHubId 0,
+          userGitHubToken = "token",
+          userSubscription = Free,
+          userId = mempty
+        }
+
 -- | Clones a repo from GitHub and does the analysis.
 analyzeGitHub ::
   GitHub.AuthMethod ghAuth =>
   Acid.AcidState Keep ->
   -- | The User asking for the analysis, we auth as them
-  Id.Id User ->
+  User ->
   -- | How to auth with GitHub API
   ghAuth ->
   -- | The repo depo
@@ -1539,7 +1601,7 @@ analyzeGitHub ::
   -- | GitHub repo
   Text ->
   IO Analysis
-analyzeGitHub keep userId ghAuth depo o r = do
+analyzeGitHub keep user@User {userId} ghAuth depo o r = do
   activeAuthors <-
     getPeople
       /> Vector.map (GitHub.simpleUserLogin .> GitHub.userInfoForR)
@@ -1550,9 +1612,11 @@ analyzeGitHub keep userId ghAuth depo o r = do
   GitHub.github ghAuth (GitHub.repositoryR ghOwner ghRepo) +> \case
     Left err -> throwIO <| toException err
     Right repo -> do
-      let GitHub.URL url = GitHub.repoHtmlUrl repo
-      bareRepo <- fetchBareRepo depo <. GitHub.getUrl <| GitHub.repoHtmlUrl repo
-      analyze keep userId activeAuthors (URL url) bareRepo (GitHub.repoPrivate repo)
+      let canonicalUrl = GitHub.getUrl <| GitHub.repoHtmlUrl repo
+      let cloningUrl = if GitHub.repoPrivate repo then spliceCreds user canonicalUrl else canonicalUrl
+      let worktree = depo </> removeScheme canonicalUrl <.> "git"
+      bareRepo <- fetchBareRepo cloningUrl worktree
+      analyze keep userId activeAuthors (URL canonicalUrl) bareRepo (GitHub.repoPrivate repo)
   where
     ghOwner = GitHub.mkName (Proxy :: Proxy GitHub.Owner) o
     ghRepo = GitHub.mkName (Proxy :: Proxy GitHub.Repo) r
@@ -1590,19 +1654,12 @@ test_analyzeGitHub load =
     "analyzeGitHub"
     [ Test.unit "can analyze a public repo (octocat/hello-world)" <| do
         (c, _, k) <- load
-        let user =
-              User
-                { userEmail = UserEmail <| Just "user@example.com",
-                  userGitHubId = GitHubId 0,
-                  userGitHubToken = tokn c,
-                  userSubscription = Free,
-                  userId = mempty
-                }
+        let user@User {userGitHubToken} = mock_user c
         Analysis {..} <-
           analyzeGitHub
             k
-            (userId user)
-            (userGitHubAuth <| userGitHubToken user)
+            user
+            (userGitHubAuth userGitHubToken)
             (depo c)
             "octocat"
             "hello-world"
@@ -1615,13 +1672,36 @@ test_analyzeGitHub load =
         fst </ headMay stale @?= Just "README"
         score @?= 20
         totalFiles @?= 1
-        commit @?= Sha "7fd1a60b01f91b314f59955a4e4d4e80d8edf11d"
+        commit @?= Sha "7fd1a60b01f91b314f59955a4e4d4e80d8edf11d",
+      Test.unit "can analyze a private repo (bsima/biz)" <| do
+        (c, _, k) <- load
+        let user@User {userGitHubToken} = mock_user c
+        Analysis {..} <-
+          analyzeGitHub
+            k
+            user
+            (userGitHubAuth userGitHubToken)
+            (depo c)
+            "bsima"
+            "biz"
+        url @?= URL "https://github.com/bsima/biz"
+        bareRepo @?= depo c <> "/github.com/bsima/biz.git"
     ]
+  where
+    mock_user c =
+      User
+        { userEmail = UserEmail <| Just "ben@bsima.me",
+          userGitHubHandle = GitHubHandle "bsima",
+          userGitHubId = GitHubId 0,
+          userGitHubToken = tokn c,
+          userSubscription = Free,
+          userId = mempty
+        }
 
 -- | Clone the repo to @<Config.depo>/<url>@. If repo already exists, just do a
 -- @git fetch@. pures the full path to the local repo.
-fetchBareRepo :: FilePath -> Text -> IO FilePath
-fetchBareRepo depo url =
+fetchBareRepo :: Text -> String -> IO FilePath
+fetchBareRepo url worktree =
   Directory.doesPathExist worktree
     +> fetchOrClone
     >> pure worktree
@@ -1634,6 +1714,6 @@ fetchBareRepo depo url =
       Log.info ["git", "clone", url]
         >> Log.br
         >> Process.callProcess "git" ["clone", "--bare", "--quiet", "--", Text.unpack url, worktree]
-    removeScheme :: Text -> FilePath
-    removeScheme u = Text.unpack <. Text.dropWhile (== '/') <. snd <| Text.breakOn "//" u
-    worktree = depo </> removeScheme url <.> "git"
+
+removeScheme :: Text -> FilePath
+removeScheme u = Text.unpack <. Text.dropWhile (== '/') <. snd <| Text.breakOn "//" u