{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}

module GH
  ( releaseUrl,
    GH.untagName,
    authFromToken,
    checkExistingUpdatePR,
    closedAutoUpdateRefs,
    compareUrl,
    latestVersion,
    openAutoUpdatePR,
    openPullRequests,
    pr,
  )
where

import Control.Applicative (some)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Vector as V
import qualified GitHub as GH
import GitHub.Data.Name (Name (..))
import OurPrelude
import Text.Regex.Applicative.Text ((=~))
import qualified Text.Regex.Applicative.Text as RE
import Utils (UpdateEnv (..), Version)
import qualified Utils as U

default (T.Text)

gReleaseUrl :: MonadIO m => GH.Auth -> URLParts -> ExceptT Text m Text
gReleaseUrl :: Auth -> URLParts -> ExceptT Text m Text
gReleaseUrl Auth
auth (URLParts Name Owner
o Name Repo
r Text
t) =
  m (Either Text Text) -> ExceptT Text m Text
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either Text Text) -> ExceptT Text m Text)
-> m (Either Text Text) -> ExceptT Text m Text
forall a b. (a -> b) -> a -> b
$
    (Error -> Text)
-> (Release -> Text) -> Either Error Release -> Either Text Text
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (String -> Text
T.pack (String -> Text) -> (Error -> String) -> Error -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> String
forall a. Show a => a -> String
show) (URL -> Text
GH.getUrl (URL -> Text) -> (Release -> URL) -> Release -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Release -> URL
GH.releaseHtmlUrl)
      (Either Error Release -> Either Text Text)
-> m (Either Error Release) -> m (Either Text Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Either Error Release) -> m (Either Error Release)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Auth -> Request Any Release -> IO (Either Error Release)
forall am req res.
(AuthMethod am, GitHubRW req res) =>
am -> req -> res
GH.github Auth
auth (Name Owner -> Name Repo -> Text -> Request Any Release
forall (k :: RW).
Name Owner -> Name Repo -> Text -> Request k Release
GH.releaseByTagNameR Name Owner
o Name Repo
r Text
t))

releaseUrl :: MonadIO m => UpdateEnv -> Text -> ExceptT Text m Text
releaseUrl :: UpdateEnv -> Text -> ExceptT Text m Text
releaseUrl UpdateEnv
env Text
url = do
  URLParts
urlParts <- Text -> ExceptT Text m URLParts
forall (m :: * -> *). MonadIO m => Text -> ExceptT Text m URLParts
parseURL Text
url
  Auth -> URLParts -> ExceptT Text m Text
forall (m :: * -> *).
MonadIO m =>
Auth -> URLParts -> ExceptT Text m Text
gReleaseUrl (UpdateEnv -> Auth
authFrom UpdateEnv
env) URLParts
urlParts

pr :: MonadIO m => UpdateEnv -> Text -> Text -> Text -> Text -> ExceptT Text m Text
pr :: UpdateEnv -> Text -> Text -> Text -> Text -> ExceptT Text m Text
pr UpdateEnv
env Text
title Text
body Text
prHead Text
base = do
  m (Either Text Text) -> ExceptT Text m Text
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either Text Text) -> ExceptT Text m Text)
-> m (Either Text Text) -> ExceptT Text m Text
forall a b. (a -> b) -> a -> b
$
    (Error -> Text)
-> (PullRequest -> Text)
-> Either Error PullRequest
-> Either Text Text
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (String -> Text
T.pack (String -> Text) -> (Error -> String) -> Error -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> String
forall a. Show a => a -> String
show) (URL -> Text
GH.getUrl (URL -> Text) -> (PullRequest -> URL) -> PullRequest -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PullRequest -> URL
GH.pullRequestUrl)
      (Either Error PullRequest -> Either Text Text)
-> m (Either Error PullRequest) -> m (Either Text Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( IO (Either Error PullRequest) -> m (Either Error PullRequest)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Error PullRequest) -> m (Either Error PullRequest))
-> IO (Either Error PullRequest) -> m (Either Error PullRequest)
forall a b. (a -> b) -> a -> b
$
              ( Auth -> Request 'RW PullRequest -> IO (Either Error PullRequest)
forall am req res.
(AuthMethod am, GitHubRW req res) =>
am -> req -> res
GH.github
                  (UpdateEnv -> Auth
authFrom UpdateEnv
env)
                  ( Name Owner
-> Name Repo -> CreatePullRequest -> Request 'RW PullRequest
GH.createPullRequestR
                      (Text -> Name Owner
forall entity. Text -> Name entity
N Text
"nixos")
                      (Text -> Name Repo
forall entity. Text -> Name entity
N Text
"nixpkgs")
                      (Text -> Text -> Text -> Text -> CreatePullRequest
GH.CreatePullRequest Text
title Text
body Text
prHead Text
base)
                  )
              )
          )

data URLParts = URLParts
  { URLParts -> Name Owner
owner :: GH.Name GH.Owner,
    URLParts -> Name Repo
repo :: GH.Name GH.Repo,
    URLParts -> Text
tag :: Text
  }
  deriving (Int -> URLParts -> ShowS
[URLParts] -> ShowS
URLParts -> String
(Int -> URLParts -> ShowS)
-> (URLParts -> String) -> ([URLParts] -> ShowS) -> Show URLParts
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [URLParts] -> ShowS
$cshowList :: [URLParts] -> ShowS
show :: URLParts -> String
$cshow :: URLParts -> String
showsPrec :: Int -> URLParts -> ShowS
$cshowsPrec :: Int -> URLParts -> ShowS
Show)

-- | Parse owner-repo-branch triplet out of URL
-- We accept URLs pointing to uploaded release assets
-- that are usually obtained with fetchurl, as well
-- as the generated archives that fetchFromGitHub downloads.
--
-- Examples:
--
-- >>> parseURLMaybe "https://github.com/blueman-project/blueman/releases/download/2.0.7/blueman-2.0.7.tar.xz"
-- Just (URLParts {owner = N "blueman-project", repo = N "blueman", tag = "2.0.7"})
--
-- >>> parseURLMaybe "https://github.com/arvidn/libtorrent/archive/libtorrent_1_1_11.tar.gz"
-- Just (URLParts {owner = N "arvidn", repo = N "libtorrent", tag = "libtorrent_1_1_11"})
--
-- >>> parseURLMaybe "https://gitlab.com/inkscape/lib2geom/-/archive/1.0/lib2geom-1.0.tar.gz"
-- Nothing
parseURLMaybe :: Text -> Maybe URLParts
parseURLMaybe :: Text -> Maybe URLParts
parseURLMaybe Text
url =
  let domain :: RE' Text
domain = Text -> RE' Text
RE.string Text
"https://github.com/"
      slash :: RE' Char
slash = Char -> RE' Char
RE.sym Char
'/'
      pathSegment :: RE' Text
pathSegment = String -> Text
T.pack (String -> Text) -> RE Char String -> RE' Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RE' Char -> RE Char String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ((Char -> Bool) -> RE' Char
RE.psym (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/'))
      extension :: RE' Text
extension = Text -> RE' Text
RE.string Text
".zip" RE' Text -> RE' Text -> RE' Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> RE' Text
RE.string Text
".tar.gz"
      toParts :: Text -> Text -> Text -> URLParts
toParts Text
n Text
o = Name Owner -> Name Repo -> Text -> URLParts
URLParts (Text -> Name Owner
forall entity. Text -> Name entity
N Text
n) (Text -> Name Repo
forall entity. Text -> Name entity
N Text
o)
      regex :: RE Char URLParts
regex =
        ( Text -> Text -> Text -> URLParts
toParts (Text -> Text -> Text -> URLParts)
-> RE' Text -> RE Char (Text -> Text -> URLParts)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RE' Text
domain RE' Text -> RE' Text -> RE' Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> RE' Text
pathSegment) RE Char (Text -> Text -> URLParts)
-> RE' Char -> RE Char (Text -> Text -> URLParts)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* RE' Char
slash RE Char (Text -> Text -> URLParts)
-> RE' Text -> RE Char (Text -> URLParts)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RE' Text
pathSegment
            RE Char (Text -> URLParts) -> RE' Text -> RE Char URLParts
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> RE' Text
RE.string Text
"/releases/download/" RE' Text -> RE' Text -> RE' Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> RE' Text
pathSegment)
            RE Char URLParts -> RE' Char -> RE Char URLParts
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* RE' Char
slash
            RE Char URLParts -> RE' Text -> RE Char URLParts
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* RE' Text
pathSegment
        )
          RE Char URLParts -> RE Char URLParts -> RE Char URLParts
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ( Text -> Text -> Text -> URLParts
toParts (Text -> Text -> Text -> URLParts)
-> RE' Text -> RE Char (Text -> Text -> URLParts)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RE' Text
domain RE' Text -> RE' Text -> RE' Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> RE' Text
pathSegment) RE Char (Text -> Text -> URLParts)
-> RE' Char -> RE Char (Text -> Text -> URLParts)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* RE' Char
slash RE Char (Text -> Text -> URLParts)
-> RE' Text -> RE Char (Text -> URLParts)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RE' Text
pathSegment
                  RE Char (Text -> URLParts) -> RE' Text -> RE Char URLParts
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> RE' Text
RE.string Text
"/archive/" RE' Text -> RE' Text -> RE' Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> RE' Text
pathSegment)
                  RE Char URLParts -> RE' Text -> RE Char URLParts
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* RE' Text
extension
              )
   in Text
url Text -> RE Char URLParts -> Maybe URLParts
forall a. Text -> RE' a -> Maybe a
=~ RE Char URLParts
regex

parseURL :: MonadIO m => Text -> ExceptT Text m URLParts
parseURL :: Text -> ExceptT Text m URLParts
parseURL Text
url =
  Text -> Maybe URLParts -> ExceptT Text m URLParts
forall (m :: * -> *) e a. Monad m => e -> Maybe a -> ExceptT e m a
tryJust (Text
"GitHub: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
url Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is not a GitHub URL.") (Text -> Maybe URLParts
parseURLMaybe Text
url)

compareUrl :: MonadIO m => Text -> Text -> ExceptT Text m Text
compareUrl :: Text -> Text -> ExceptT Text m Text
compareUrl Text
urlOld Text
urlNew = do
  URLParts
oldParts <- Text -> ExceptT Text m URLParts
forall (m :: * -> *). MonadIO m => Text -> ExceptT Text m URLParts
parseURL Text
urlOld
  URLParts
newParts <- Text -> ExceptT Text m URLParts
forall (m :: * -> *). MonadIO m => Text -> ExceptT Text m URLParts
parseURL Text
urlNew
  Text -> ExceptT Text m Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> ExceptT Text m Text) -> Text -> ExceptT Text m Text
forall a b. (a -> b) -> a -> b
$
    Text
"https://github.com/"
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name Owner -> Text
forall entity. Name entity -> Text
GH.untagName (URLParts -> Name Owner
owner URLParts
newParts)
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/"
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name Repo -> Text
forall entity. Name entity -> Text
GH.untagName (URLParts -> Name Repo
repo URLParts
newParts)
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/compare/"
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> URLParts -> Text
tag URLParts
oldParts
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"..."
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> URLParts -> Text
tag URLParts
newParts

autoUpdateRefs :: GH.Auth -> GH.Name GH.Owner -> IO (Either Text (Vector Text))
autoUpdateRefs :: Auth -> Name Owner -> IO (Either Text (Vector Text))
autoUpdateRefs Auth
auth Name Owner
ghUser =
  Auth
-> Request Any (Vector GitReference)
-> IO (Either Error (Vector GitReference))
forall am req res.
(AuthMethod am, GitHubRW req res) =>
am -> req -> res
GH.github Auth
auth (Name Owner
-> Name Repo -> FetchCount -> Request Any (Vector GitReference)
forall (k :: RW).
Name Owner
-> Name Repo -> FetchCount -> Request k (Vector GitReference)
GH.referencesR Name Owner
ghUser Name Repo
"nixpkgs" FetchCount
GH.FetchAll)
    IO (Either Error (Vector GitReference))
-> (IO (Either Error (Vector GitReference))
    -> IO (Either Text (Vector GitReference)))
-> IO (Either Text (Vector GitReference))
forall a b. a -> (a -> b) -> b
& (((Either Error (Vector GitReference)
 -> Either Text (Vector GitReference))
-> IO (Either Error (Vector GitReference))
-> IO (Either Text (Vector GitReference))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Either Error (Vector GitReference)
  -> Either Text (Vector GitReference))
 -> IO (Either Error (Vector GitReference))
 -> IO (Either Text (Vector GitReference)))
-> ((Error -> Text)
    -> Either Error (Vector GitReference)
    -> Either Text (Vector GitReference))
-> (Error -> Text)
-> IO (Either Error (Vector GitReference))
-> IO (Either Text (Vector GitReference))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Error -> Text)
-> Either Error (Vector GitReference)
-> Either Text (Vector GitReference)
forall a b r. (a -> b) -> Either a r -> Either b r
fmapL) Error -> Text
forall a. Show a => a -> Text
tshow)
    IO (Either Text (Vector GitReference))
-> (IO (Either Text (Vector GitReference))
    -> IO (Either Text (Vector Text)))
-> IO (Either Text (Vector Text))
forall a b. a -> (a -> b) -> b
& (((Either Text (Vector GitReference) -> Either Text (Vector Text))
-> IO (Either Text (Vector GitReference))
-> IO (Either Text (Vector Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Either Text (Vector GitReference) -> Either Text (Vector Text))
 -> IO (Either Text (Vector GitReference))
 -> IO (Either Text (Vector Text)))
-> ((Vector GitReference -> Vector Text)
    -> Either Text (Vector GitReference) -> Either Text (Vector Text))
-> (Vector GitReference -> Vector Text)
-> IO (Either Text (Vector GitReference))
-> IO (Either Text (Vector Text))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vector GitReference -> Vector Text)
-> Either Text (Vector GitReference) -> Either Text (Vector Text)
forall a b l. (a -> b) -> Either l a -> Either l b
fmapR) ((GitReference -> Text) -> Vector GitReference -> Vector Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (GitReference -> Name GitReference
GH.gitReferenceRef (GitReference -> Name GitReference)
-> (Name GitReference -> Text) -> GitReference -> Text
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Name GitReference -> Text
forall entity. Name entity -> Text
GH.untagName) (Vector GitReference -> Vector Text)
-> (Vector Text -> Vector Text)
-> Vector GitReference
-> Vector Text
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Text -> Maybe Text) -> Vector Text -> Vector Text
forall a b. (a -> Maybe b) -> Vector a -> Vector b
V.mapMaybe (Text -> Text -> Maybe Text
T.stripPrefix Text
prefix)))
  where
    prefix :: Text
prefix = Text
"refs/heads/auto-update/"

openPRWithAutoUpdateRefFrom :: GH.Auth -> GH.Name GH.Owner -> Text -> IO (Either Text Bool)
openPRWithAutoUpdateRefFrom :: Auth -> Name Owner -> Text -> IO (Either Text Bool)
openPRWithAutoUpdateRefFrom Auth
auth Name Owner
ghUser Text
ref =
  Auth
-> GenRequest 'MtJSON Any (Vector SimplePullRequest)
-> IO (Either Error (Vector SimplePullRequest))
forall am (mt :: MediaType *) a (rw :: RW).
(AuthMethod am, ParseResponse mt a) =>
am -> GenRequest mt rw a -> IO (Either Error a)
GH.executeRequest
    Auth
auth
    ( Name Owner
-> Name Repo
-> PullRequestMod
-> FetchCount
-> GenRequest 'MtJSON Any (Vector SimplePullRequest)
forall (k :: RW).
Name Owner
-> Name Repo
-> PullRequestMod
-> FetchCount
-> Request k (Vector SimplePullRequest)
GH.pullRequestsForR
        Name Owner
"nixos"
        Name Repo
"nixpkgs"
        (Text -> PullRequestMod
GH.optionsHead (Name Owner -> Text
forall entity. Name entity -> Text
GH.untagName Name Owner
ghUser Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
U.branchPrefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ref) PullRequestMod -> PullRequestMod -> PullRequestMod
forall a. Semigroup a => a -> a -> a
<> PullRequestMod
forall mod. HasState mod => mod
GH.stateOpen)
        FetchCount
GH.FetchAll
    )
    IO (Either Error (Vector SimplePullRequest))
-> (IO (Either Error (Vector SimplePullRequest))
    -> IO (Either Text Bool))
-> IO (Either Text Bool)
forall a b. a -> (a -> b) -> b
& (Either Error (Vector SimplePullRequest) -> Either Text Bool)
-> IO (Either Error (Vector SimplePullRequest))
-> IO (Either Text Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Error -> Text)
-> Either Error (Vector SimplePullRequest)
-> Either Text (Vector SimplePullRequest)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String -> Text
T.pack (String -> Text) -> (Error -> String) -> Error -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> String
forall a. Show a => a -> String
show) (Either Error (Vector SimplePullRequest)
 -> Either Text (Vector SimplePullRequest))
-> (Either Text (Vector SimplePullRequest) -> Either Text Bool)
-> Either Error (Vector SimplePullRequest)
-> Either Text Bool
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Vector SimplePullRequest -> Bool)
-> Either Text (Vector SimplePullRequest) -> Either Text Bool
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Bool -> Bool
not (Bool -> Bool)
-> (Vector SimplePullRequest -> Bool)
-> Vector SimplePullRequest
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector SimplePullRequest -> Bool
forall a. Vector a -> Bool
V.null))

refShouldBeDeleted :: GH.Auth -> GH.Name GH.Owner -> Text -> IO Bool
refShouldBeDeleted :: Auth -> Name Owner -> Text -> IO Bool
refShouldBeDeleted Auth
auth Name Owner
ghUser Text
ref =
  Bool -> Bool
not (Bool -> Bool)
-> (Either Text Bool -> Bool) -> Either Text Bool -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Bool) -> (Bool -> Bool) -> Either Text Bool -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> Text -> Bool
forall a b. a -> b -> a
const Bool
True) Bool -> Bool
forall a. a -> a
id
    (Either Text Bool -> Bool) -> IO (Either Text Bool) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Auth -> Name Owner -> Text -> IO (Either Text Bool)
openPRWithAutoUpdateRefFrom Auth
auth Name Owner
ghUser Text
ref

closedAutoUpdateRefs :: GH.Auth -> GH.Name GH.Owner -> IO (Either Text (Vector Text))
closedAutoUpdateRefs :: Auth -> Name Owner -> IO (Either Text (Vector Text))
closedAutoUpdateRefs Auth
auth Name Owner
ghUser =
  ExceptT Text IO (Vector Text) -> IO (Either Text (Vector Text))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text IO (Vector Text) -> IO (Either Text (Vector Text)))
-> ExceptT Text IO (Vector Text) -> IO (Either Text (Vector Text))
forall a b. (a -> b) -> a -> b
$ do
    Vector Text
aur :: Vector Text <- IO (Either Text (Vector Text)) -> ExceptT Text IO (Vector Text)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either Text (Vector Text)) -> ExceptT Text IO (Vector Text))
-> IO (Either Text (Vector Text)) -> ExceptT Text IO (Vector Text)
forall a b. (a -> b) -> a -> b
$ Auth -> Name Owner -> IO (Either Text (Vector Text))
GH.autoUpdateRefs Auth
auth Name Owner
ghUser
    IO (Either Text (Vector Text)) -> ExceptT Text IO (Vector Text)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (Vector Text -> Either Text (Vector Text)
forall a b. b -> Either a b
Right (Vector Text -> Either Text (Vector Text))
-> IO (Vector Text) -> IO (Either Text (Vector Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> IO Bool) -> Vector Text -> IO (Vector Text)
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> Vector a -> m (Vector a)
V.filterM (Auth -> Name Owner -> Text -> IO Bool
refShouldBeDeleted Auth
auth Name Owner
ghUser) Vector Text
aur)

-- This is too slow
openPullRequests :: Text -> IO (Either Text (Vector GH.SimplePullRequest))
openPullRequests :: Text -> IO (Either Text (Vector SimplePullRequest))
openPullRequests Text
githubToken =
  Auth
-> GenRequest 'MtJSON Any (Vector SimplePullRequest)
-> IO (Either Error (Vector SimplePullRequest))
forall am (mt :: MediaType *) a (rw :: RW).
(AuthMethod am, ParseResponse mt a) =>
am -> GenRequest mt rw a -> IO (Either Error a)
GH.executeRequest
    (Token -> Auth
GH.OAuth (Text -> Token
T.encodeUtf8 Text
githubToken))
    (Name Owner
-> Name Repo
-> PullRequestMod
-> FetchCount
-> GenRequest 'MtJSON Any (Vector SimplePullRequest)
forall (k :: RW).
Name Owner
-> Name Repo
-> PullRequestMod
-> FetchCount
-> Request k (Vector SimplePullRequest)
GH.pullRequestsForR Name Owner
"nixos" Name Repo
"nixpkgs" PullRequestMod
forall mod. HasState mod => mod
GH.stateOpen FetchCount
GH.FetchAll)
    IO (Either Error (Vector SimplePullRequest))
-> (IO (Either Error (Vector SimplePullRequest))
    -> IO (Either Text (Vector SimplePullRequest)))
-> IO (Either Text (Vector SimplePullRequest))
forall a b. a -> (a -> b) -> b
& (Either Error (Vector SimplePullRequest)
 -> Either Text (Vector SimplePullRequest))
-> IO (Either Error (Vector SimplePullRequest))
-> IO (Either Text (Vector SimplePullRequest))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Error -> Text)
-> Either Error (Vector SimplePullRequest)
-> Either Text (Vector SimplePullRequest)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String -> Text
T.pack (String -> Text) -> (Error -> String) -> Error -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> String
forall a. Show a => a -> String
show))

openAutoUpdatePR :: UpdateEnv -> Vector GH.SimplePullRequest -> Bool
openAutoUpdatePR :: UpdateEnv -> Vector SimplePullRequest -> Bool
openAutoUpdatePR UpdateEnv
updateEnv Vector SimplePullRequest
oprs = Vector SimplePullRequest
oprs Vector SimplePullRequest
-> (Vector SimplePullRequest -> Bool) -> Bool
forall a b. a -> (a -> b) -> b
& ((SimplePullRequest -> Bool)
-> Vector SimplePullRequest -> Maybe SimplePullRequest
forall a. (a -> Bool) -> Vector a -> Maybe a
V.find SimplePullRequest -> Bool
isThisPkg (Vector SimplePullRequest -> Maybe SimplePullRequest)
-> (Maybe SimplePullRequest -> Bool)
-> Vector SimplePullRequest
-> Bool
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Maybe SimplePullRequest -> Bool
forall a. Maybe a -> Bool
isJust)
  where
    isThisPkg :: SimplePullRequest -> Bool
isThisPkg SimplePullRequest
simplePullRequest =
      let title :: Text
title = SimplePullRequest -> Text
GH.simplePullRequestTitle SimplePullRequest
simplePullRequest
          titleHasName :: Bool
titleHasName = (UpdateEnv -> Text
packageName UpdateEnv
updateEnv Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":") Text -> Text -> Bool
`T.isPrefixOf` Text
title
          titleHasNewVersion :: Bool
titleHasNewVersion = UpdateEnv -> Text
newVersion UpdateEnv
updateEnv Text -> Text -> Bool
`T.isSuffixOf` Text
title
       in Bool
titleHasName Bool -> Bool -> Bool
&& Bool
titleHasNewVersion

authFromToken :: Text -> GH.Auth
authFromToken :: Text -> Auth
authFromToken = Token -> Auth
GH.OAuth (Token -> Auth) -> (Text -> Token) -> Text -> Auth
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Token
T.encodeUtf8

authFrom :: UpdateEnv -> GH.Auth
authFrom :: UpdateEnv -> Auth
authFrom = Text -> Auth
authFromToken (Text -> Auth) -> (UpdateEnv -> Text) -> UpdateEnv -> Auth
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> Text
U.githubToken (Options -> Text) -> (UpdateEnv -> Options) -> UpdateEnv -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UpdateEnv -> Options
options

checkExistingUpdatePR :: MonadIO m => UpdateEnv -> Text -> ExceptT Text m ()
checkExistingUpdatePR :: UpdateEnv -> Text -> ExceptT Text m ()
checkExistingUpdatePR UpdateEnv
env Text
attrPath = do
  SearchResult Issue
searchResult <-
    m (Either Text (SearchResult Issue))
-> ExceptT Text m (SearchResult Issue)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either Text (SearchResult Issue))
 -> ExceptT Text m (SearchResult Issue))
-> m (Either Text (SearchResult Issue))
-> ExceptT Text m (SearchResult Issue)
forall a b. (a -> b) -> a -> b
$
      IO (Either Text (SearchResult Issue))
-> m (Either Text (SearchResult Issue))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Text (SearchResult Issue))
 -> m (Either Text (SearchResult Issue)))
-> IO (Either Text (SearchResult Issue))
-> m (Either Text (SearchResult Issue))
forall a b. (a -> b) -> a -> b
$
        Auth
-> Request Any (SearchResult Issue)
-> IO (Either Error (SearchResult Issue))
forall am req res.
(AuthMethod am, GitHubRW req res) =>
am -> req -> res
GH.github (UpdateEnv -> Auth
authFrom UpdateEnv
env) (Text -> Request Any (SearchResult Issue)
forall (k :: RW). Text -> Request k (SearchResult Issue)
GH.searchIssuesR Text
search)
          IO (Either Error (SearchResult Issue))
-> (IO (Either Error (SearchResult Issue))
    -> IO (Either Text (SearchResult Issue)))
-> IO (Either Text (SearchResult Issue))
forall a b. a -> (a -> b) -> b
& (Either Error (SearchResult Issue)
 -> Either Text (SearchResult Issue))
-> IO (Either Error (SearchResult Issue))
-> IO (Either Text (SearchResult Issue))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Error -> Text)
-> Either Error (SearchResult Issue)
-> Either Text (SearchResult Issue)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String -> Text
T.pack (String -> Text) -> (Error -> String) -> Error -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> String
forall a. Show a => a -> String
show))
  if Text -> Int
T.length (SearchResult Issue -> Text
openPRReport SearchResult Issue
searchResult) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
    then () -> ExceptT Text m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    else
      Text -> ExceptT Text m ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE
        ( Text
"There might already be an open PR for this update:\n"
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SearchResult Issue -> Text
openPRReport SearchResult Issue
searchResult
        )
  where
    title :: Text
title = UpdateEnv -> Text -> Text
U.prTitle UpdateEnv
env Text
attrPath
    search :: Text
search = [interpolate|repo:nixos/nixpkgs $title |]
    openPRReport :: SearchResult Issue -> Text
openPRReport SearchResult Issue
searchResult =
      SearchResult Issue -> Vector Issue
forall entity. SearchResult entity -> Vector entity
GH.searchResultResults SearchResult Issue
searchResult
        Vector Issue -> (Vector Issue -> Vector Issue) -> Vector Issue
forall a b. a -> (a -> b) -> b
& (Issue -> Bool) -> Vector Issue -> Vector Issue
forall a. (a -> Bool) -> Vector a -> Vector a
V.filter (Issue -> Maybe UTCTime
GH.issueClosedAt (Issue -> Maybe UTCTime)
-> (Maybe UTCTime -> Bool) -> Issue -> Bool
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Maybe UTCTime -> Bool
forall a. Maybe a -> Bool
isNothing)
        Vector Issue -> (Vector Issue -> Vector Issue) -> Vector Issue
forall a b. a -> (a -> b) -> b
& (Issue -> Bool) -> Vector Issue -> Vector Issue
forall a. (a -> Bool) -> Vector a -> Vector a
V.filter (Issue -> Maybe PullRequestReference
GH.issuePullRequest (Issue -> Maybe PullRequestReference)
-> (Maybe PullRequestReference -> Bool) -> Issue -> Bool
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Maybe PullRequestReference -> Bool
forall a. Maybe a -> Bool
isJust)
        Vector Issue -> (Vector Issue -> Vector Text) -> Vector Text
forall a b. a -> (a -> b) -> b
& (Issue -> Text) -> Vector Issue -> Vector Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Issue -> Text
report
        Vector Text -> (Vector Text -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
& Vector Text -> [Text]
forall a. Vector a -> [a]
V.toList
        [Text] -> ([Text] -> Text) -> Text
forall a b. a -> (a -> b) -> b
& [Text] -> Text
T.unlines
    report :: Issue -> Text
report Issue
i = Text
"- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Issue -> Text
GH.issueTitle Issue
i Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> URL -> Text
forall a. Show a => a -> Text
tshow (Issue -> URL
GH.issueUrl Issue
i)

latestVersion :: MonadIO m => UpdateEnv -> Text -> ExceptT Text m Version
latestVersion :: UpdateEnv -> Text -> ExceptT Text m Text
latestVersion UpdateEnv
env Text
url = do
  URLParts
urlParts <- Text -> ExceptT Text m URLParts
forall (m :: * -> *). MonadIO m => Text -> ExceptT Text m URLParts
parseURL Text
url
  Release
r <-
    (Error -> Text)
-> ExceptT Error m Release -> ExceptT Text m Release
forall (m :: * -> *) a b r.
Functor m =>
(a -> b) -> ExceptT a m r -> ExceptT b m r
fmapLT Error -> Text
forall a. Show a => a -> Text
tshow (ExceptT Error m Release -> ExceptT Text m Release)
-> ExceptT Error m Release -> ExceptT Text m Release
forall a b. (a -> b) -> a -> b
$
      m (Either Error Release) -> ExceptT Error m Release
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either Error Release) -> ExceptT Error m Release)
-> m (Either Error Release) -> ExceptT Error m Release
forall a b. (a -> b) -> a -> b
$
        IO (Either Error Release) -> m (Either Error Release)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Error Release) -> m (Either Error Release))
-> IO (Either Error Release) -> m (Either Error Release)
forall a b. (a -> b) -> a -> b
$
          Auth -> Request Any Release -> IO (Either Error Release)
forall am (mt :: MediaType *) a (rw :: RW).
(AuthMethod am, ParseResponse mt a) =>
am -> GenRequest mt rw a -> IO (Either Error a)
GH.executeRequest (UpdateEnv -> Auth
authFrom UpdateEnv
env) (Request Any Release -> IO (Either Error Release))
-> Request Any Release -> IO (Either Error Release)
forall a b. (a -> b) -> a -> b
$
            Name Owner -> Name Repo -> Request Any Release
forall (k :: RW). Name Owner -> Name Repo -> Request k Release
GH.latestReleaseR (URLParts -> Name Owner
owner URLParts
urlParts) (URLParts -> Name Repo
repo URLParts
urlParts)
  Text -> ExceptT Text m Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> ExceptT Text m Text) -> Text -> ExceptT Text m Text
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.dropWhile (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'v' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'V') (Release -> Text
GH.releaseTagName Release
r)