diff options
Diffstat (limited to 'Biz/Devalloc.hs')
| -rw-r--r-- | Biz/Devalloc.hs | 186 |
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 |