{-# LANGUAGE OverloadedStrings, TupleSections, ScopedTypeVariables, ViewPatterns, RecordWildCards, NoImplicitPrelude, LambdaCase, NamedFieldPuns, GeneralizedNewtypeDeriving, DeriveFunctor #-}
-- TODO: remove exts
{-|
Description: IO-based resolving of missing hashes

Resolving a 'YLT.Lockfile' and generating all necessary data (e.g. hashes), so that it can be converted to a nix expression. Might need IO & network access to succeed.
-}
module Distribution.Nixpkgs.Nodejs.ResolveLockfile
( resolveLockfileStatus
, ResolverConfig(..)
, Resolved(..), ResolvedLockfile
) where

import Protolude hiding (toS)
import Protolude.Conv (toS)
import qualified Control.Monad.Trans.Except as E
import Data.ByteString.Lazy ()
import qualified Data.List.NonEmpty as NE
import qualified Data.MultiKeyedMap as MKM
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Types as AesonT
import qualified System.Process as Process

import qualified Control.Concurrent.Async.Pool as Async
import qualified Control.Monad.STM as STM

import qualified Yarn.Lock.Types as YLT

nixPrefetchGitPath :: FilePath
nixPrefetchGitPath :: FilePath
nixPrefetchGitPath = FilePath
"nix-prefetch-git"

maxFetchers :: Int
maxFetchers :: Int
maxFetchers = Int
5

data ResolverConfig
  = ResolverConfig
  { ResolverConfig -> Bool
resolveOffline :: Bool -- ^ If @True@, 'resolveLockfileStatus' will throw an
                           --   error in case resolving a hash requires network
                           --   access (for when it started in a nix build)
  }

-- | A thing whose hash is already known (“resolved”).
--
-- Only packages with known hashes are truly “locked”.
data Resolved a = Resolved
  { Resolved a -> Text
hashSum :: Text
  , Resolved a -> a
resolved :: a
  } deriving (Int -> Resolved a -> ShowS
[Resolved a] -> ShowS
Resolved a -> FilePath
(Int -> Resolved a -> ShowS)
-> (Resolved a -> FilePath)
-> ([Resolved a] -> ShowS)
-> Show (Resolved a)
forall a. Show a => Int -> Resolved a -> ShowS
forall a. Show a => [Resolved a] -> ShowS
forall a. Show a => Resolved a -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Resolved a] -> ShowS
$cshowList :: forall a. Show a => [Resolved a] -> ShowS
show :: Resolved a -> FilePath
$cshow :: forall a. Show a => Resolved a -> FilePath
showsPrec :: Int -> Resolved a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Resolved a -> ShowS
Show, Resolved a -> Resolved a -> Bool
(Resolved a -> Resolved a -> Bool)
-> (Resolved a -> Resolved a -> Bool) -> Eq (Resolved a)
forall a. Eq a => Resolved a -> Resolved a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Resolved a -> Resolved a -> Bool
$c/= :: forall a. Eq a => Resolved a -> Resolved a -> Bool
== :: Resolved a -> Resolved a -> Bool
$c== :: forall a. Eq a => Resolved a -> Resolved a -> Bool
Eq, a -> Resolved b -> Resolved a
(a -> b) -> Resolved a -> Resolved b
(forall a b. (a -> b) -> Resolved a -> Resolved b)
-> (forall a b. a -> Resolved b -> Resolved a) -> Functor Resolved
forall a b. a -> Resolved b -> Resolved a
forall a b. (a -> b) -> Resolved a -> Resolved b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Resolved b -> Resolved a
$c<$ :: forall a b. a -> Resolved b -> Resolved a
fmap :: (a -> b) -> Resolved a -> Resolved b
$cfmap :: forall a b. (a -> b) -> Resolved a -> Resolved b
Functor)

-- | In order to write a nix file, all packages need to know their shasums first.
type ResolvedLockfile = MKM.MKMap YLT.PackageKey (Resolved YLT.Package)

-- | Resolve all packages by downloading their sources if necessary.
--
--   Respects 'runOffline' from 'RunConfig': If it is 'True', it throws
--   an error as soon as it would need to download something which is the
--   case for 'YLT.GitRemote'.
resolveLockfileStatus :: ResolverConfig -> (Chan YLT.Remote) -> YLT.Lockfile
                      -> IO (Either (NE.NonEmpty Text) ResolvedLockfile)
resolveLockfileStatus :: ResolverConfig
-> Chan Remote
-> Lockfile
-> IO (Either (NonEmpty Text) ResolvedLockfile)
resolveLockfileStatus ResolverConfig
cfg Chan Remote
msgChan Lockfile
lf = Int
-> (TaskGroup -> IO (Either (NonEmpty Text) ResolvedLockfile))
-> IO (Either (NonEmpty Text) ResolvedLockfile)
forall b. Int -> (TaskGroup -> IO b) -> IO b
Async.withTaskGroup Int
maxFetchers ((TaskGroup -> IO (Either (NonEmpty Text) ResolvedLockfile))
 -> IO (Either (NonEmpty Text) ResolvedLockfile))
-> (TaskGroup -> IO (Either (NonEmpty Text) ResolvedLockfile))
-> IO (Either (NonEmpty Text) ResolvedLockfile)
forall a b. (a -> b) -> a -> b
$ \TaskGroup
taskGroup -> do
  Async [Either Text (NonEmpty PackageKey, Resolved Package)]
job <- STM (Async [Either Text (NonEmpty PackageKey, Resolved Package)])
-> IO (Async [Either Text (NonEmpty PackageKey, Resolved Package)])
forall a. STM a -> IO a
STM.atomically (STM (Async [Either Text (NonEmpty PackageKey, Resolved Package)])
 -> IO
      (Async [Either Text (NonEmpty PackageKey, Resolved Package)]))
-> STM
     (Async [Either Text (NonEmpty PackageKey, Resolved Package)])
-> IO (Async [Either Text (NonEmpty PackageKey, Resolved Package)])
forall a b. (a -> b) -> a -> b
$ TaskGroup
-> [IO [Either Text (NonEmpty PackageKey, Resolved Package)]]
-> STM
     (Async [Either Text (NonEmpty PackageKey, Resolved Package)])
forall (t :: * -> *) a.
(Foldable t, Monoid a) =>
TaskGroup -> t (IO a) -> STM (Async a)
Async.mapReduce TaskGroup
taskGroup
           ([IO [Either Text (NonEmpty PackageKey, Resolved Package)]]
 -> STM
      (Async [Either Text (NonEmpty PackageKey, Resolved Package)]))
-> [IO [Either Text (NonEmpty PackageKey, Resolved Package)]]
-> STM
     (Async [Either Text (NonEmpty PackageKey, Resolved Package)])
forall a b. (a -> b) -> a -> b
$ ((NonEmpty PackageKey, Package)
 -> IO [Either Text (NonEmpty PackageKey, Resolved Package)])
-> [(NonEmpty PackageKey, Package)]
-> [IO [Either Text (NonEmpty PackageKey, Resolved Package)]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(NonEmpty PackageKey
ks, Package
pkg) -> (Either Text (NonEmpty PackageKey, Resolved Package)
-> [Either Text (NonEmpty PackageKey, Resolved Package)]
-> [Either Text (NonEmpty PackageKey, Resolved Package)]
forall a. a -> [a] -> [a]
:[]) (Either Text (NonEmpty PackageKey, Resolved Package)
 -> [Either Text (NonEmpty PackageKey, Resolved Package)])
-> IO (Either Text (NonEmpty PackageKey, Resolved Package))
-> IO [Either Text (NonEmpty PackageKey, Resolved Package)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExceptT Text IO (NonEmpty PackageKey, Resolved Package)
-> IO (Either Text (NonEmpty PackageKey, Resolved Package))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
E.runExceptT (ExceptT Text IO (NonEmpty PackageKey, Resolved Package)
 -> IO (Either Text (NonEmpty PackageKey, Resolved Package)))
-> ExceptT Text IO (NonEmpty PackageKey, Resolved Package)
-> IO (Either Text (NonEmpty PackageKey, Resolved Package))
forall a b. (a -> b) -> a -> b
$ do
                        IO () -> ExceptT Text IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT Text IO ()) -> IO () -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ Chan Remote -> Remote -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan Remote
msgChan (Package -> Remote
YLT.remote Package
pkg)
                        Resolved Package
res <- Package -> ExceptT Text IO (Resolved Package)
resolve Package
pkg
                        (NonEmpty PackageKey, Resolved Package)
-> ExceptT Text IO (NonEmpty PackageKey, Resolved Package)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty PackageKey
ks, Resolved Package
res)))
               ([(NonEmpty PackageKey, Package)]
 -> [IO [Either Text (NonEmpty PackageKey, Resolved Package)]])
-> [(NonEmpty PackageKey, Package)]
-> [IO [Either Text (NonEmpty PackageKey, Resolved Package)]]
forall a b. (a -> b) -> a -> b
$ Lockfile -> [(NonEmpty PackageKey, Package)]
forall k v. MKMap k v -> [(NonEmpty k, v)]
MKM.toList Lockfile
lf
  [Either Text (NonEmpty PackageKey, Resolved Package)]
resolved <- Async [Either Text (NonEmpty PackageKey, Resolved Package)]
-> IO [Either Text (NonEmpty PackageKey, Resolved Package)]
forall a. Async a -> IO a
Async.wait Async [Either Text (NonEmpty PackageKey, Resolved Package)]
job
  case [Either Text (NonEmpty PackageKey, Resolved Package)]
-> ([Text], [(NonEmpty PackageKey, Resolved Package)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either Text (NonEmpty PackageKey, Resolved Package)]
resolved of
    (Text
x:[Text]
xs, [(NonEmpty PackageKey, Resolved Package)]
_ ) -> Either (NonEmpty Text) ResolvedLockfile
-> IO (Either (NonEmpty Text) ResolvedLockfile)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (NonEmpty Text) ResolvedLockfile
 -> IO (Either (NonEmpty Text) ResolvedLockfile))
-> Either (NonEmpty Text) ResolvedLockfile
-> IO (Either (NonEmpty Text) ResolvedLockfile)
forall a b. (a -> b) -> a -> b
$ NonEmpty Text -> Either (NonEmpty Text) ResolvedLockfile
forall a b. a -> Either a b
Left (NonEmpty Text -> Either (NonEmpty Text) ResolvedLockfile)
-> NonEmpty Text -> Either (NonEmpty Text) ResolvedLockfile
forall a b. (a -> b) -> a -> b
$ Text
x Text -> [Text] -> NonEmpty Text
forall a. a -> [a] -> NonEmpty a
NE.:| [Text]
xs
    ([Text]
_   , [(NonEmpty PackageKey, Resolved Package)]
ys) -> Either (NonEmpty Text) ResolvedLockfile
-> IO (Either (NonEmpty Text) ResolvedLockfile)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (NonEmpty Text) ResolvedLockfile
 -> IO (Either (NonEmpty Text) ResolvedLockfile))
-> Either (NonEmpty Text) ResolvedLockfile
-> IO (Either (NonEmpty Text) ResolvedLockfile)
forall a b. (a -> b) -> a -> b
$ ResolvedLockfile -> Either (NonEmpty Text) ResolvedLockfile
forall a b. b -> Either a b
Right (ResolvedLockfile -> Either (NonEmpty Text) ResolvedLockfile)
-> ResolvedLockfile -> Either (NonEmpty Text) ResolvedLockfile
forall a b. (a -> b) -> a -> b
$ Proxy Int
-> [(NonEmpty PackageKey, Resolved Package)] -> ResolvedLockfile
forall ik k v.
(Ord k, Ord ik, Enum ik, Bounded ik) =>
Proxy ik -> [(NonEmpty k, v)] -> MKMap k v
MKM.fromList Proxy Int
YLT.lockfileIkProxy [(NonEmpty PackageKey, Resolved Package)]
ys

  where
    resolve :: YLT.Package -> E.ExceptT Text IO (Resolved YLT.Package)
    resolve :: Package -> ExceptT Text IO (Resolved Package)
resolve Package
pkg = case Package -> Remote
YLT.remote Package
pkg of
      YLT.FileRemote{Text
fileUrl :: Remote -> Text
fileSha1 :: Remote -> Text
fileSha1 :: Text
fileUrl :: Text
..} -> Resolved Package -> ExceptT Text IO (Resolved Package)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Resolved Package -> ExceptT Text IO (Resolved Package))
-> Resolved Package -> ExceptT Text IO (Resolved Package)
forall a b. (a -> b) -> a -> b
$ Text -> Resolved Package
r Text
fileSha1
      YLT.FileLocal{Text
fileLocalPath :: Remote -> Text
fileLocalSha1 :: Remote -> Text
fileLocalSha1 :: Text
fileLocalPath :: Text
..}  -> Resolved Package -> ExceptT Text IO (Resolved Package)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Resolved Package -> ExceptT Text IO (Resolved Package))
-> Resolved Package -> ExceptT Text IO (Resolved Package)
forall a b. (a -> b) -> a -> b
$ Text -> Resolved Package
r Text
fileLocalSha1
      YLT.GitRemote{Text
gitRepoUrl :: Remote -> Text
gitRev :: Remote -> Text
gitRev :: Text
gitRepoUrl :: Text
..}  -> if ResolverConfig
cfg ResolverConfig -> (ResolverConfig -> Bool) -> Bool
forall a b. a -> (a -> b) -> b
& ResolverConfig -> Bool
resolveOffline
                              then Text -> ExceptT Text IO (Resolved Package)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
E.throwE (Text -> ExceptT Text IO (Resolved Package))
-> Text -> ExceptT Text IO (Resolved Package)
forall a b. (a -> b) -> a -> b
$ Text
"Refusing to resolve \"git+"
                              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
gitRepoUrl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
gitRev
                              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" because --offline is set"
                              else Text -> Resolved Package
r (Text -> Resolved Package)
-> ExceptT Text IO Text -> ExceptT Text IO (Resolved Package)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> ExceptT Text IO Text
fetchFromGit Text
gitRepoUrl Text
gitRev
      YLT.FileRemoteNoIntegrity{Text
fileNoIntegrityUrl :: Remote -> Text
fileNoIntegrityUrl :: Text
..} -> Text -> ExceptT Text IO (Resolved Package)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
E.throwE
        (Text -> ExceptT Text IO (Resolved Package))
-> Text -> ExceptT Text IO (Resolved Package)
forall a b. (a -> b) -> a -> b
$ Text
"The remote "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fileNoIntegrityUrl
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" does not specify a sha1 hash in the yarn.lock file, which we don’t support (yet)"
      YLT.FileLocalNoIntegrity{Text
fileLocalNoIntegrityPath :: Remote -> Text
fileLocalNoIntegrityPath :: Text
..} -> Text -> ExceptT Text IO (Resolved Package)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
E.throwE
        (Text -> ExceptT Text IO (Resolved Package))
-> Text -> ExceptT Text IO (Resolved Package)
forall a b. (a -> b) -> a -> b
$ Text
"The local file "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fileLocalNoIntegrityPath
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" does not specify a sha1 hash in the yarn.lock file, which we don’t support (yet)"
      where
        r :: Text -> Resolved Package
r Text
sha = Resolved :: forall a. Text -> a -> Resolved a
Resolved { hashSum :: Text
hashSum = Text
sha, resolved :: Package
resolved = Package
pkg }

    fetchFromGit :: Text -> Text -> E.ExceptT Text IO Text
    fetchFromGit :: Text -> Text -> ExceptT Text IO Text
fetchFromGit Text
repo Text
rev = do
      (ExitCode, FilePath, FilePath)
res <- IO (ExitCode, FilePath, FilePath)
-> ExceptT Text IO (ExitCode, FilePath, FilePath)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ExitCode, FilePath, FilePath)
 -> ExceptT Text IO (ExitCode, FilePath, FilePath))
-> IO (ExitCode, FilePath, FilePath)
-> ExceptT Text IO (ExitCode, FilePath, FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath
-> [FilePath] -> FilePath -> IO (ExitCode, FilePath, FilePath)
Process.readProcessWithExitCode FilePath
nixPrefetchGitPath
               [FilePath
"--url", Text -> FilePath
forall a b. StringConv a b => a -> b
toS Text
repo, FilePath
"--rev", Text -> FilePath
forall a b. StringConv a b => a -> b
toS Text
rev, FilePath
"--hash", FilePath
"sha256"] FilePath
""
      case (ExitCode, FilePath, FilePath)
res of
        ((ExitFailure Int
_), FilePath
_, FilePath
err) -> Text -> ExceptT Text IO Text
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
E.throwE (Text -> ExceptT Text IO Text) -> Text -> ExceptT Text IO Text
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
forall a b. StringConv a b => a -> b
toS FilePath
err
        (ExitCode
ExitSuccess, FilePath
out, FilePath
_) -> IO (Either Text Text) -> ExceptT Text IO Text
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
E.ExceptT (IO (Either Text Text) -> ExceptT Text IO Text)
-> (Either Text Text -> IO (Either Text Text))
-> Either Text Text
-> ExceptT Text IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Text Text -> IO (Either Text Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          (Either Text Text -> ExceptT Text IO Text)
-> Either Text Text -> ExceptT Text IO Text
forall a b. (a -> b) -> a -> b
$ (FilePath -> Text) -> Either FilePath Text -> Either Text Text
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (\FilePath
decErr -> Text
"parsing json output failed:\n"
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
forall a b. StringConv a b => a -> b
toS FilePath
decErr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\nThe output was:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
forall a b. StringConv a b => a -> b
toS FilePath
out)
            (Either FilePath Text -> Either Text Text)
-> Either FilePath Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$ do Value
val <- ByteString -> Either FilePath Value
forall a. FromJSON a => ByteString -> Either FilePath a
Aeson.eitherDecode' (FilePath -> ByteString
forall a b. StringConv a b => a -> b
toS FilePath
out)
                 (Value -> Parser Text) -> Value -> Either FilePath Text
forall a b. (a -> Parser b) -> a -> Either FilePath b
AesonT.parseEither
                   (FilePath -> (Object -> Parser Text) -> Value -> Parser Text
forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject FilePath
"PrefetchOutput" (Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"sha256")) Value
val