{-# LANGUAGE QuasiQuotes #-}
module Update.Nix.Updater
( fetchers
) where
import Data.Maybe
import Data.Text ( Text
, splitOn
)
import Nix ( NExprLoc )
import Nix.Comments
import Nix.Match.Typed
import qualified Update.Nix.FetchGit.Prefetch as P
import Update.Nix.FetchGit.Prefetch ( Revision(..)
, getGitFullName
, getGitHubRevisionDate
, getGitRevision
, nixPrefetchGit
, nixPrefetchUrl
)
import Update.Nix.FetchGit.Types
import Update.Nix.FetchGit.Utils
import Update.Span
type Fetcher
= Bool -> (NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater)
fetchers
:: Bool -> (NExprLoc -> Maybe Comment) -> [NExprLoc -> Maybe (M Updater)]
fetchers :: Bool
-> (NExprLoc -> Maybe Comment) -> [NExprLoc -> Maybe (M Updater)]
fetchers Bool
onlyCommented NExprLoc -> Maybe Comment
getComment =
(((NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater))
-> (NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater)
forall a b. (a -> b) -> a -> b
$ NExprLoc -> Maybe Comment
getComment)
(((NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater))
-> NExprLoc -> Maybe (M Updater))
-> ((Bool
-> (NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater))
-> (NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater))
-> (Bool
-> (NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater))
-> NExprLoc
-> Maybe (M Updater)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Bool
-> (NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater))
-> Bool
-> (NExprLoc -> Maybe Comment)
-> NExprLoc
-> Maybe (M Updater)
forall a b. (a -> b) -> a -> b
$ Bool
onlyCommented)
((Bool
-> (NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater))
-> NExprLoc -> Maybe (M Updater))
-> [Bool
-> (NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater)]
-> [NExprLoc -> Maybe (M Updater)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ Bool
-> (NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater)
fetchgitUpdater
, Bool
-> (NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater)
builtinsFetchGitUpdater
, Bool
-> (NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater)
fetchTarballGithubUpdater
, Bool
-> (NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater)
builtinsFetchTarballUpdater
, Bool
-> (NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater)
fetchurlUpdater
, Bool
-> (NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater)
fetchGitHubUpdater
, Bool
-> (NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater)
hackageDirectUpdater
]
fetchgitUpdater :: Fetcher
fetchgitUpdater :: Bool
-> (NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater)
fetchgitUpdater Bool
onlyCommented NExprLoc -> Maybe Comment
getComment = \case
NExprLoc
[matchNixLoc|
^fetcher {
url = ^url;
rev = ^rev; # rev
sha256 = ^sha256;
_deepClone = ^deepClone;
_leaveDotGit = ^leaveDotGit;
_fetchSubmodules = ^fetchSubmodules;
}|] | NExprLoc -> Maybe Comment
extractFuncName NExprLoc
fetcher Maybe Comment -> [Maybe Comment] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Comment -> Maybe Comment
forall a. a -> Maybe a
Just Comment
"fetchgit", Comment -> Maybe Comment
forall a. a -> Maybe a
Just Comment
"fetchgitPrivate"]
, Maybe RevisionRequest
desiredRev <- Maybe Comment -> Maybe RevisionRequest
commentToRequest (NExprLoc -> Maybe Comment
getComment NExprLoc
rev)
, Bool
onlyCommented Bool -> Bool -> Bool
~> Maybe RevisionRequest -> Bool
forall a. Maybe a -> Bool
isJust Maybe RevisionRequest
desiredRev
-> M Updater -> Maybe (M Updater)
forall a. a -> Maybe a
Just (M Updater -> Maybe (M Updater)) -> M Updater -> Maybe (M Updater)
forall a b. (a -> b) -> a -> b
$ do
RepoLocation
url' <- Either Warning RepoLocation -> M RepoLocation
forall a. Either Warning a -> M a
fromEither (Either Warning RepoLocation -> M RepoLocation)
-> Either Warning RepoLocation -> M RepoLocation
forall a b. (a -> b) -> a -> b
$ Comment -> RepoLocation
URL (Comment -> RepoLocation)
-> Either Warning Comment -> Either Warning RepoLocation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NExprLoc -> Either Warning Comment
exprText NExprLoc
url
Bool
deepClone' <- (Maybe Bool -> Bool)
-> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool)
-> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False) (ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool)
-> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool)
-> (Maybe NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool))
-> Maybe NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Warning (Maybe Bool)
-> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool)
forall a. Either Warning a -> M a
fromEither (Either Warning (Maybe Bool)
-> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool))
-> (Maybe NExprLoc -> Either Warning (Maybe Bool))
-> Maybe NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NExprLoc -> Either Warning Bool)
-> Maybe NExprLoc -> Either Warning (Maybe Bool)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse NExprLoc -> Either Warning Bool
exprBool (Maybe NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool)
-> Maybe NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool
forall a b. (a -> b) -> a -> b
$ Maybe NExprLoc
deepClone
Bool
leaveDotGit' <- (Maybe Bool -> Bool)
-> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool)
-> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
deepClone') (ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool)
-> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool)
-> (Maybe NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool))
-> Maybe NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Warning (Maybe Bool)
-> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool)
forall a. Either Warning a -> M a
fromEither (Either Warning (Maybe Bool)
-> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool))
-> (Maybe NExprLoc -> Either Warning (Maybe Bool))
-> Maybe NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NExprLoc -> Either Warning Bool)
-> Maybe NExprLoc -> Either Warning (Maybe Bool)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse NExprLoc -> Either Warning Bool
exprBool (Maybe NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool)
-> Maybe NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool
forall a b. (a -> b) -> a -> b
$ Maybe NExprLoc
leaveDotGit
Bool
fetchSubmodules' <- (Maybe Bool -> Bool)
-> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool)
-> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
True) (ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool)
-> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool)
-> (Maybe NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool))
-> Maybe NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Warning (Maybe Bool)
-> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool)
forall a. Either Warning a -> M a
fromEither (Either Warning (Maybe Bool)
-> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool))
-> (Maybe NExprLoc -> Either Warning (Maybe Bool))
-> Maybe NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NExprLoc -> Either Warning Bool)
-> Maybe NExprLoc -> Either Warning (Maybe Bool)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse NExprLoc -> Either Warning Bool
exprBool (Maybe NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool)
-> Maybe NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool
forall a b. (a -> b) -> a -> b
$ Maybe NExprLoc
fetchSubmodules
Updater -> M Updater
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Updater -> M Updater) -> Updater -> M Updater
forall a b. (a -> b) -> a -> b
$ RepoLocation
-> Maybe RevisionRequest
-> Bool
-> Bool
-> Bool
-> NExprLoc
-> Maybe NExprLoc
-> Updater
gitUpdater RepoLocation
url' Maybe RevisionRequest
desiredRev Bool
deepClone' Bool
leaveDotGit' Bool
fetchSubmodules' NExprLoc
rev (NExprLoc -> Maybe NExprLoc
forall a. a -> Maybe a
Just NExprLoc
sha256)
NExprLoc
_ -> Maybe (M Updater)
forall a. Maybe a
Nothing
builtinsFetchGitUpdater :: Fetcher
builtinsFetchGitUpdater :: Bool
-> (NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater)
builtinsFetchGitUpdater Bool
onlyCommented NExprLoc -> Maybe Comment
getComment = \case
NExprLoc
[matchNixLoc|
^fetcher {
url = ^url;
rev = ^rev; # rev
_submodules = ^submodules;
}|] | Just Comment
"fetchGit" <- NExprLoc -> Maybe Comment
extractFuncName NExprLoc
fetcher
, Maybe RevisionRequest
desiredRev <- Maybe Comment -> Maybe RevisionRequest
commentToRequest (NExprLoc -> Maybe Comment
getComment NExprLoc
rev)
, Bool
onlyCommented Bool -> Bool -> Bool
~> Maybe RevisionRequest -> Bool
forall a. Maybe a -> Bool
isJust Maybe RevisionRequest
desiredRev
-> M Updater -> Maybe (M Updater)
forall a. a -> Maybe a
Just (M Updater -> Maybe (M Updater)) -> M Updater -> Maybe (M Updater)
forall a b. (a -> b) -> a -> b
$ do
RepoLocation
url' <- Either Warning RepoLocation -> M RepoLocation
forall a. Either Warning a -> M a
fromEither (Either Warning RepoLocation -> M RepoLocation)
-> Either Warning RepoLocation -> M RepoLocation
forall a b. (a -> b) -> a -> b
$ Comment -> RepoLocation
URL (Comment -> RepoLocation)
-> Either Warning Comment -> Either Warning RepoLocation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NExprLoc -> Either Warning Comment
exprText NExprLoc
url
Bool
submodules' <- (Maybe Bool -> Bool)
-> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool)
-> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False) (ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool)
-> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool)
-> (Maybe NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool))
-> Maybe NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Warning (Maybe Bool)
-> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool)
forall a. Either Warning a -> M a
fromEither (Either Warning (Maybe Bool)
-> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool))
-> (Maybe NExprLoc -> Either Warning (Maybe Bool))
-> Maybe NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NExprLoc -> Either Warning Bool)
-> Maybe NExprLoc -> Either Warning (Maybe Bool)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse NExprLoc -> Either Warning Bool
exprBool (Maybe NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool)
-> Maybe NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool
forall a b. (a -> b) -> a -> b
$ Maybe NExprLoc
submodules
Updater -> M Updater
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Updater -> M Updater) -> Updater -> M Updater
forall a b. (a -> b) -> a -> b
$ RepoLocation
-> Maybe RevisionRequest
-> Bool
-> Bool
-> Bool
-> NExprLoc
-> Maybe NExprLoc
-> Updater
gitUpdater RepoLocation
url' Maybe RevisionRequest
desiredRev Bool
False Bool
False Bool
submodules' NExprLoc
rev Maybe NExprLoc
forall a. Maybe a
Nothing
NExprLoc
_ -> Maybe (M Updater)
forall a. Maybe a
Nothing
fetchTarballGithubUpdater :: Fetcher
fetchTarballGithubUpdater :: Bool
-> (NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater)
fetchTarballGithubUpdater Bool
onlyCommented NExprLoc -> Maybe Comment
getComment = \case
NExprLoc
[matchNixLoc|
^fetcher {
url = ^url; # rev
sha256 = ^sha256;
}|]
| Just Comment
"fetchTarball" <- NExprLoc -> Maybe Comment
extractFuncName NExprLoc
fetcher
, Right Comment
url' <- NExprLoc -> Either Warning Comment
exprText NExprLoc
url
, Comment
"https:" : Comment
"" : Comment
"github.com" : Comment
owner : Comment
repo : Comment
"archive" : [Comment]
_ <- Comment -> Comment -> [Comment]
splitOn
Comment
"/"
Comment
url'
, Maybe Comment
comment <- NExprLoc -> Maybe Comment
getComment NExprLoc
url
, Bool
onlyCommented Bool -> Bool -> Bool
~> Maybe Comment -> Bool
forall a. Maybe a -> Bool
isJust Maybe Comment
comment
, Maybe Comment
comment Maybe Comment -> Maybe Comment -> Bool
forall a. Eq a => a -> a -> Bool
/= Comment -> Maybe Comment
forall a. a -> Maybe a
Just Comment
"pin"
-> M Updater -> Maybe (M Updater)
forall a. a -> Maybe a
Just (M Updater -> Maybe (M Updater)) -> M Updater -> Maybe (M Updater)
forall a b. (a -> b) -> a -> b
$ do
let rev :: Revision
rev = Comment -> Revision
Revision (Comment -> Revision) -> Comment -> Revision
forall a b. (a -> b) -> a -> b
$ Comment -> Maybe Comment -> Comment
forall a. a -> Maybe a -> a
fromMaybe Comment
"HEAD" Maybe Comment
comment
repoUrl :: Comment
repoUrl = Comment
"https://github.com/" Comment -> Comment -> Comment
forall a. Semigroup a => a -> a -> a
<> Comment
owner Comment -> Comment -> Comment
forall a. Semigroup a => a -> a -> a
<> Comment
"/" Comment -> Comment -> Comment
forall a. Semigroup a => a -> a -> a
<> Comment
repo
Updater -> M Updater
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Updater -> M Updater)
-> (M (Maybe Day, [SpanUpdate]) -> Updater)
-> M (Maybe Day, [SpanUpdate])
-> M Updater
forall b c a. (b -> c) -> (a -> b) -> a -> c
. M (Maybe Day, [SpanUpdate]) -> Updater
Updater (M (Maybe Day, [SpanUpdate]) -> M Updater)
-> M (Maybe Day, [SpanUpdate]) -> M Updater
forall a b. (a -> b) -> a -> b
$ do
Comment
revision <- Comment -> Revision -> M Comment
getGitRevision Comment
repoUrl Revision
rev
let newUrl :: Comment
newUrl = Comment
repoUrl Comment -> Comment -> Comment
forall a. Semigroup a => a -> a -> a
<> Comment
"/archive/" Comment -> Comment -> Comment
forall a. Semigroup a => a -> a -> a
<> Comment
revision Comment -> Comment -> Comment
forall a. Semigroup a => a -> a -> a
<> Comment
".tar.gz"
let Updater M (Maybe Day, [SpanUpdate])
u = Comment -> NExprLoc -> Updater
tarballUpdater Comment
newUrl NExprLoc
sha256
Day
date <- Comment -> Comment -> Revision -> M Day
getGitHubRevisionDate Comment
owner Comment
repo (Comment -> Revision
Revision Comment
revision)
(Maybe Day
_, [SpanUpdate]
urlUpdate) <- M (Maybe Day, [SpanUpdate])
u
(Maybe Day, [SpanUpdate]) -> M (Maybe Day, [SpanUpdate])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Day -> Maybe Day
forall a. a -> Maybe a
Just Day
date, SrcSpan -> Comment -> SpanUpdate
SpanUpdate (NExprLoc -> SrcSpan
exprSpan NExprLoc
url) (Comment -> Comment
quoteString Comment
newUrl) SpanUpdate -> [SpanUpdate] -> [SpanUpdate]
forall a. a -> [a] -> [a]
: [SpanUpdate]
urlUpdate)
NExprLoc
_ -> Maybe (M Updater)
forall a. Maybe a
Nothing
builtinsFetchTarballUpdater :: Fetcher
builtinsFetchTarballUpdater :: Bool
-> (NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater)
builtinsFetchTarballUpdater Bool
onlyCommented NExprLoc -> Maybe Comment
getComment = \case
NExprLoc
[matchNixLoc|
^fetcher {
url = ^url; # [pin]
sha256 = ^sha256;
}|] | Just Comment
"fetchTarball" <- NExprLoc -> Maybe Comment
extractFuncName NExprLoc
fetcher
, Maybe Comment
comment <- NExprLoc -> Maybe Comment
getComment NExprLoc
url
, Bool
onlyCommented Bool -> Bool -> Bool
~> Maybe Comment -> Bool
forall a. Maybe a -> Bool
isJust Maybe Comment
comment
-> M Updater -> Maybe (M Updater)
forall a. a -> Maybe a
Just (M Updater -> Maybe (M Updater)) -> M Updater -> Maybe (M Updater)
forall a b. (a -> b) -> a -> b
$ do
Comment
url' <- Either Warning Comment -> M Comment
forall a. Either Warning a -> M a
fromEither (Either Warning Comment -> M Comment)
-> Either Warning Comment -> M Comment
forall a b. (a -> b) -> a -> b
$ NExprLoc -> Either Warning Comment
exprText NExprLoc
url
Updater -> M Updater
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Updater -> M Updater) -> Updater -> M Updater
forall a b. (a -> b) -> a -> b
$ Comment -> NExprLoc -> Updater
tarballUpdater Comment
url' NExprLoc
sha256
NExprLoc
_ -> Maybe (M Updater)
forall a. Maybe a
Nothing
fetchurlUpdater :: Fetcher
fetchurlUpdater :: Bool
-> (NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater)
fetchurlUpdater Bool
onlyCommented NExprLoc -> Maybe Comment
getComment = \case
NExprLoc
[matchNixLoc|
^fetcher {
url = ^url; # [pin]
sha256 = ^sha256;
}|] | Just Comment
"fetchurl" <- NExprLoc -> Maybe Comment
extractFuncName NExprLoc
fetcher
, Maybe Comment
comment <- NExprLoc -> Maybe Comment
getComment NExprLoc
url
, Bool
onlyCommented Bool -> Bool -> Bool
~> Maybe Comment -> Bool
forall a. Maybe a -> Bool
isJust Maybe Comment
comment
-> M Updater -> Maybe (M Updater)
forall a. a -> Maybe a
Just (M Updater -> Maybe (M Updater)) -> M Updater -> Maybe (M Updater)
forall a b. (a -> b) -> a -> b
$ do
Comment
url' <- Either Warning Comment -> M Comment
forall a. Either Warning a -> M a
fromEither (Either Warning Comment -> M Comment)
-> Either Warning Comment -> M Comment
forall a b. (a -> b) -> a -> b
$ NExprLoc -> Either Warning Comment
exprText NExprLoc
url
Updater -> M Updater
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Updater -> M Updater) -> Updater -> M Updater
forall a b. (a -> b) -> a -> b
$ Comment -> NExprLoc -> Updater
urlUpdater Comment
url' NExprLoc
sha256
NExprLoc
_ -> Maybe (M Updater)
forall a. Maybe a
Nothing
fetchGitHubUpdater :: Fetcher
fetchGitHubUpdater :: Bool
-> (NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater)
fetchGitHubUpdater Bool
onlyCommented NExprLoc -> Maybe Comment
getComment = \case
NExprLoc
[matchNixLoc|
^fetcher {
owner = ^owner;
repo = ^repo;
rev = ^rev;
sha256 = ^sha256;
_fetchSubmodules = ^fetchSubmodules;
}|] | Just Comment -> Comment -> RepoLocation
fun <- NExprLoc -> Maybe Comment
extractFuncName NExprLoc
fetcher Maybe Comment
-> (Comment -> Maybe (Comment -> Comment -> RepoLocation))
-> Maybe (Comment -> Comment -> RepoLocation)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Comment
"fetchFromGitHub" -> (Comment -> Comment -> RepoLocation)
-> Maybe (Comment -> Comment -> RepoLocation)
forall a. a -> Maybe a
Just Comment -> Comment -> RepoLocation
GitHub
Comment
"fetchFromGitLab" -> (Comment -> Comment -> RepoLocation)
-> Maybe (Comment -> Comment -> RepoLocation)
forall a. a -> Maybe a
Just Comment -> Comment -> RepoLocation
GitLab
Comment
_ -> Maybe (Comment -> Comment -> RepoLocation)
forall a. Maybe a
Nothing
, Maybe RevisionRequest
desiredRev <- Maybe Comment -> Maybe RevisionRequest
commentToRequest (NExprLoc -> Maybe Comment
getComment NExprLoc
rev)
, Bool
onlyCommented Bool -> Bool -> Bool
~> Maybe RevisionRequest -> Bool
forall a. Maybe a -> Bool
isJust Maybe RevisionRequest
desiredRev
-> M Updater -> Maybe (M Updater)
forall a. a -> Maybe a
Just (M Updater -> Maybe (M Updater)) -> M Updater -> Maybe (M Updater)
forall a b. (a -> b) -> a -> b
$ do
Comment
owner' <- Either Warning Comment -> M Comment
forall a. Either Warning a -> M a
fromEither (Either Warning Comment -> M Comment)
-> Either Warning Comment -> M Comment
forall a b. (a -> b) -> a -> b
$ NExprLoc -> Either Warning Comment
exprText NExprLoc
owner
Comment
repo' <- Either Warning Comment -> M Comment
forall a. Either Warning a -> M a
fromEither (Either Warning Comment -> M Comment)
-> Either Warning Comment -> M Comment
forall a b. (a -> b) -> a -> b
$ NExprLoc -> Either Warning Comment
exprText NExprLoc
repo
Bool
fetchSubmodules' <- (Maybe Bool -> Bool)
-> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool)
-> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False) (ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool)
-> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool)
-> (Maybe NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool))
-> Maybe NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Warning (Maybe Bool)
-> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool)
forall a. Either Warning a -> M a
fromEither (Either Warning (Maybe Bool)
-> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool))
-> (Maybe NExprLoc -> Either Warning (Maybe Bool))
-> Maybe NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) (Maybe Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NExprLoc -> Either Warning Bool)
-> Maybe NExprLoc -> Either Warning (Maybe Bool)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse NExprLoc -> Either Warning Bool
exprBool (Maybe NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool)
-> Maybe NExprLoc
-> ReaderT Env (ValidateT (Dual [Warning]) IO) Bool
forall a b. (a -> b) -> a -> b
$ Maybe NExprLoc
fetchSubmodules
Updater -> M Updater
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Updater -> M Updater) -> Updater -> M Updater
forall a b. (a -> b) -> a -> b
$ RepoLocation
-> Maybe RevisionRequest
-> Bool
-> Bool
-> Bool
-> NExprLoc
-> Maybe NExprLoc
-> Updater
gitUpdater (Comment -> Comment -> RepoLocation
fun Comment
owner' Comment
repo') Maybe RevisionRequest
desiredRev Bool
False Bool
False Bool
fetchSubmodules' NExprLoc
rev (NExprLoc -> Maybe NExprLoc
forall a. a -> Maybe a
Just NExprLoc
sha256)
NExprLoc
_ -> Maybe (M Updater)
forall a. Maybe a
Nothing
hackageDirectUpdater :: Fetcher
hackageDirectUpdater :: Bool
-> (NExprLoc -> Maybe Comment) -> NExprLoc -> Maybe (M Updater)
hackageDirectUpdater Bool
onlyCommented NExprLoc -> Maybe Comment
_ = \case
NExprLoc
[matchNixLoc|
^fetcher {
pkg = ^pkg;
ver = ^ver;
sha256 = ^sha256;
}
|] | Just Comment
"callHackageDirect" <- NExprLoc -> Maybe Comment
extractFuncName NExprLoc
fetcher
, Bool -> Bool
not Bool
onlyCommented
-> M Updater -> Maybe (M Updater)
forall a. a -> Maybe a
Just (M Updater -> Maybe (M Updater)) -> M Updater -> Maybe (M Updater)
forall a b. (a -> b) -> a -> b
$ do
Comment
pkg' <- Either Warning Comment -> M Comment
forall a. Either Warning a -> M a
fromEither (Either Warning Comment -> M Comment)
-> Either Warning Comment -> M Comment
forall a b. (a -> b) -> a -> b
$ NExprLoc -> Either Warning Comment
exprText NExprLoc
pkg
Comment
ver' <- Either Warning Comment -> M Comment
forall a. Either Warning a -> M a
fromEither (Either Warning Comment -> M Comment)
-> Either Warning Comment -> M Comment
forall a b. (a -> b) -> a -> b
$ NExprLoc -> Either Warning Comment
exprText NExprLoc
ver
let pkgver :: Comment
pkgver = Comment
pkg' Comment -> Comment -> Comment
forall a. Semigroup a => a -> a -> a
<> Comment
"-" Comment -> Comment -> Comment
forall a. Semigroup a => a -> a -> a
<> Comment
ver'
url :: Comment
url = Comment
"mirror://hackage/" Comment -> Comment -> Comment
forall a. Semigroup a => a -> a -> a
<> Comment
pkgver Comment -> Comment -> Comment
forall a. Semigroup a => a -> a -> a
<> Comment
"/" Comment -> Comment -> Comment
forall a. Semigroup a => a -> a -> a
<> Comment
pkgver Comment -> Comment -> Comment
forall a. Semigroup a => a -> a -> a
<> Comment
".tar.gz"
Updater -> M Updater
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Updater -> M Updater) -> Updater -> M Updater
forall a b. (a -> b) -> a -> b
$ Comment -> NExprLoc -> Updater
tarballUpdater Comment
url NExprLoc
sha256
NExprLoc
_ -> Maybe (M Updater)
forall a. Maybe a
Nothing
data RevisionRequest
= Pin
| DoNotPin Revision
commentToRequest :: Maybe Text -> Maybe RevisionRequest
= \case
Maybe Comment
Nothing -> Maybe RevisionRequest
forall a. Maybe a
Nothing
Just Comment
"pin" -> RevisionRequest -> Maybe RevisionRequest
forall a. a -> Maybe a
Just RevisionRequest
Pin
Just Comment
r -> RevisionRequest -> Maybe RevisionRequest
forall a. a -> Maybe a
Just (Revision -> RevisionRequest
DoNotPin (Comment -> Revision
Revision Comment
r))
gitUpdater
:: RepoLocation
-> Maybe RevisionRequest
-> Bool
-> Bool
-> Bool
-> NExprLoc
-> Maybe NExprLoc
-> Updater
gitUpdater :: RepoLocation
-> Maybe RevisionRequest
-> Bool
-> Bool
-> Bool
-> NExprLoc
-> Maybe NExprLoc
-> Updater
gitUpdater RepoLocation
repoLocation Maybe RevisionRequest
revisionRequest Bool
deepClone Bool
leaveDotGit Bool
fetchSubmodules NExprLoc
revExpr Maybe NExprLoc
sha256Expr
= M (Maybe Day, [SpanUpdate]) -> Updater
Updater (M (Maybe Day, [SpanUpdate]) -> Updater)
-> M (Maybe Day, [SpanUpdate]) -> Updater
forall a b. (a -> b) -> a -> b
$ do
let repoUrl :: Comment
repoUrl = RepoLocation -> Comment
extractUrlString RepoLocation
repoLocation
Comment -> M ()
logVerbose (Comment -> M ()) -> Comment -> M ()
forall a b. (a -> b) -> a -> b
$ Comment
"Updating " Comment -> Comment -> Comment
forall a. Semigroup a => a -> a -> a
<> RepoLocation -> Comment
prettyRepoLocation RepoLocation
repoLocation
[Comment]
revArgs <- case Maybe RevisionRequest
revisionRequest of
Maybe RevisionRequest
Nothing -> [Comment] -> ReaderT Env (ValidateT (Dual [Warning]) IO) [Comment]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
Just RevisionRequest
req -> do
Comment
rev <- case RevisionRequest
req of
RevisionRequest
Pin -> Either Warning Comment -> M Comment
forall a. Either Warning a -> M a
fromEither (NExprLoc -> Either Warning Comment
exprText NExprLoc
revExpr)
DoNotPin Revision
r -> Comment -> Revision -> M Comment
getGitFullName Comment
repoUrl Revision
r
[Comment] -> ReaderT Env (ValidateT (Dual [Warning]) IO) [Comment]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Comment
"--rev", Comment
rev]
let args :: [Comment]
args =
[Comment]
revArgs
[Comment] -> [Comment] -> [Comment]
forall a. Semigroup a => a -> a -> a
<> [ Comment
"--deepClone" | Bool
deepClone ]
[Comment] -> [Comment] -> [Comment]
forall a. Semigroup a => a -> a -> a
<> [ Comment
"--leave-dotGit" | Bool
leaveDotGit ]
[Comment] -> [Comment] -> [Comment]
forall a. Semigroup a => a -> a -> a
<> [ Comment
"--fetch-submodules" | Bool
fetchSubmodules ]
NixPrefetchGitOutput
o <- [Comment] -> Comment -> M NixPrefetchGitOutput
nixPrefetchGit [Comment]
args Comment
repoUrl
Day
d <- Either Warning Day -> M Day
forall a. Either Warning a -> M a
fromEither (Either Warning Day -> M Day) -> Either Warning Day -> M Day
forall a b. (a -> b) -> a -> b
$ Comment -> Either Warning Day
parseISO8601DateToDay (NixPrefetchGitOutput -> Comment
P.date NixPrefetchGitOutput
o)
(Maybe Day, [SpanUpdate]) -> M (Maybe Day, [SpanUpdate])
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( Day -> Maybe Day
forall a. a -> Maybe a
Just Day
d
, [ SrcSpan -> Comment -> SpanUpdate
SpanUpdate (NExprLoc -> SrcSpan
exprSpan NExprLoc
e) (Comment -> Comment
quoteString (NixPrefetchGitOutput -> Comment
P.sha256 NixPrefetchGitOutput
o))
| Just NExprLoc
e <- Maybe NExprLoc -> [Maybe NExprLoc]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe NExprLoc
sha256Expr
]
[SpanUpdate] -> [SpanUpdate] -> [SpanUpdate]
forall a. Semigroup a => a -> a -> a
<> [SrcSpan -> Comment -> SpanUpdate
SpanUpdate (NExprLoc -> SrcSpan
exprSpan NExprLoc
revExpr) (Comment -> Comment
quoteString (Comment -> Comment) -> Comment -> Comment
forall a b. (a -> b) -> a -> b
$ NixPrefetchGitOutput -> Comment
P.rev NixPrefetchGitOutput
o)]
)
tarballUpdater
:: Text
-> NExprLoc
-> Updater
tarballUpdater :: Comment -> NExprLoc -> Updater
tarballUpdater Comment
url NExprLoc
sha256Expr = M (Maybe Day, [SpanUpdate]) -> Updater
Updater (M (Maybe Day, [SpanUpdate]) -> Updater)
-> M (Maybe Day, [SpanUpdate]) -> Updater
forall a b. (a -> b) -> a -> b
$ do
Comment -> M ()
logVerbose (Comment -> M ()) -> Comment -> M ()
forall a b. (a -> b) -> a -> b
$ Comment
"Updating " Comment -> Comment -> Comment
forall a. Semigroup a => a -> a -> a
<> Comment
url
Comment
sha256 <- [Comment] -> Comment -> M Comment
nixPrefetchUrl [Comment
"--unpack"] Comment
url
(Maybe Day, [SpanUpdate]) -> M (Maybe Day, [SpanUpdate])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Day
forall a. Maybe a
Nothing, [SrcSpan -> Comment -> SpanUpdate
SpanUpdate (NExprLoc -> SrcSpan
exprSpan NExprLoc
sha256Expr) (Comment -> Comment
quoteString Comment
sha256)])
urlUpdater
:: Text
-> NExprLoc
-> Updater
urlUpdater :: Comment -> NExprLoc -> Updater
urlUpdater Comment
url NExprLoc
sha256Expr = M (Maybe Day, [SpanUpdate]) -> Updater
Updater (M (Maybe Day, [SpanUpdate]) -> Updater)
-> M (Maybe Day, [SpanUpdate]) -> Updater
forall a b. (a -> b) -> a -> b
$ do
Comment -> M ()
logVerbose (Comment -> M ()) -> Comment -> M ()
forall a b. (a -> b) -> a -> b
$ Comment
"Updating " Comment -> Comment -> Comment
forall a. Semigroup a => a -> a -> a
<> Comment
url
Comment
sha256 <- [Comment] -> Comment -> M Comment
nixPrefetchUrl [] Comment
url
(Maybe Day, [SpanUpdate]) -> M (Maybe Day, [SpanUpdate])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Day
forall a. Maybe a
Nothing, [SrcSpan -> Comment -> SpanUpdate
SpanUpdate (NExprLoc -> SrcSpan
exprSpan NExprLoc
sha256Expr) (Comment -> Comment
quoteString Comment
sha256)])
(~>) :: Bool -> Bool -> Bool
Bool
x ~> :: Bool -> Bool -> Bool
~> Bool
y = Bool -> Bool
not Bool
x Bool -> Bool -> Bool
|| Bool
y