content: {-# 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 = "nix-prefetch-git"
  
  maxFetchers :: Int
  maxFetchers = 5
  
  data ResolverConfig
    = ResolverConfig
    { 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
    { hashSum :: Text
    , resolved :: a
    } deriving (Show, Eq, 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 cfg msgChan lf = Async.withTaskGroup maxFetchers $ \taskGroup -> do
    job <- STM.atomically $ Async.mapReduce taskGroup
             $ fmap (\(ks, pkg) -> (:[]) <$> (E.runExceptT $ do
                          liftIO $ writeChan msgChan (YLT.remote pkg)
                          res <- resolve pkg
                          pure (ks, res)))
                 $ MKM.toList lf
    resolved <- Async.wait job
    case partitionEithers resolved of
      (x:xs, _ ) -> pure $ Left $ x NE.:| xs
      (_   , ys) -> pure $ Right $ MKM.fromList YLT.lockfileIkProxy ys
  
    where
      resolve :: YLT.Package -> E.ExceptT Text IO (Resolved YLT.Package)
      resolve pkg = case YLT.remote pkg of
        YLT.FileRemote{..} -> pure $ r fileSha1
        YLT.FileLocal{..}  -> pure $ r fileLocalSha1
        YLT.GitRemote{..}  -> if cfg & resolveOffline
                                then E.throwE $ "Refusing to resolve \"git+"
                                <> gitRepoUrl <> "#" <> gitRev
                                <> "\" because --offline is set"
                                else r <$> fetchFromGit gitRepoUrl gitRev
        YLT.FileRemoteNoIntegrity{..} -> E.throwE
          $ "The remote "
          <> fileNoIntegrityUrl
          <> " does not specify a sha1 hash in the yarn.lock file, which we don’t support (yet)"
        YLT.FileLocalNoIntegrity{..} -> E.throwE
          $ "The local file "
          <> fileLocalNoIntegrityPath
          <> " does not specify a sha1 hash in the yarn.lock file, which we don’t support (yet)"
        where
          r sha = Resolved { hashSum = sha, resolved = pkg }
  
      fetchFromGit :: Text -> Text -> E.ExceptT Text IO Text
      fetchFromGit repo rev = do
        res <- liftIO $ Process.readProcessWithExitCode nixPrefetchGitPath
                 ["--url", toS repo, "--rev", toS rev, "--hash", "sha256"] ""
        case res of
          ((ExitFailure _), _, err) -> E.throwE $ toS err
          (ExitSuccess, out, _) -> E.ExceptT . pure
            $ first (\decErr -> "parsing json output failed:\n"
                      <> toS decErr <> "\nThe output was:\n" <> toS out)
              $ do val <- Aeson.eitherDecode' (toS out)
                   AesonT.parseEither
                     (Aeson.withObject "PrefetchOutput" (Aeson..: "sha256")) val
  