1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
|
module Github.EnumRepos where
import qualified GitHub.Data.Repos as Github
import qualified GitHub.Data.Definitions as Github
import qualified GitHub.Data.Name as Github
import Data.List
import Data.List.Utils
import Data.Maybe
import qualified Data.Text as T
import Utility.PartialPrelude
import qualified Git
import qualified Git.Types
-- A github user and repo.
data GithubUserRepo = GithubUserRepo String String
deriving (Eq, Show, Read, Ord)
class ToGithubUserRepo a where
toGithubUserRepo :: a -> GithubUserRepo
instance ToGithubUserRepo Github.Repo where
toGithubUserRepo r = GithubUserRepo
(T.unpack $ Github.untagName $ Github.simpleOwnerLogin $ Github.repoOwner r)
(T.unpack $ Github.untagName $ Github.repoName r)
instance ToGithubUserRepo Github.RepoRef where
toGithubUserRepo (Github.RepoRef owner name) = GithubUserRepo
(T.unpack $ Github.untagName $ Github.simpleOwnerLogin owner)
(T.unpack $ Github.untagName name)
gitHubRepos :: Git.Repo -> [Git.Repo]
gitHubRepos = fst . unzip . gitHubPairs
gitHubRemotes :: Git.Repo -> [GithubUserRepo]
gitHubRemotes = snd . unzip . gitHubPairs
gitHubPairs :: Git.Repo -> [(Git.Repo, GithubUserRepo)]
gitHubPairs = filter (not . wiki ) . mapMaybe check . Git.Types.remotes
where
check r@Git.Repo { Git.Types.location = Git.Types.Url u } =
headMaybe $ mapMaybe (checkurl r $ show u) gitHubUrlPrefixes
check _ = Nothing
checkurl r u prefix
| prefix `isPrefixOf` u && length bits == 2 =
Just (r,
GithubUserRepo (bits !! 0)
(dropdotgit $ bits !! 1))
| otherwise = Nothing
where
rest = drop (length prefix) u
bits = filter (not . null) $ split "/" rest
dropdotgit s
| ".git" `isSuffixOf` s = take (length s - length ".git") s
| otherwise = s
wiki (_, GithubUserRepo _ u) = ".wiki" `isSuffixOf` u
{- All known prefixes for urls to github repos. -}
gitHubUrlPrefixes :: [String]
gitHubUrlPrefixes =
[ "git@github.com:"
, "git://github.com/"
, "https://github.com/"
, "http://github.com/"
, "ssh://git@github.com/~/"
]
|
