<commit_before>{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
module Tinc.Install (
  Path (..)
, Sandbox
, PackageDB
, PackageConfig
, Cache
, installDependencies

-- exported for testing
, findPackageDB
, extractPackages
, isPackageDB
) where

import           Prelude ()
import           Prelude.Compat

import           Control.Exception
import           Control.Monad.Compat
import           Data.Function
import           Data.Graph.Wrapper
import           Data.List.Compat
import           Data.Maybe
import           System.Directory
import           System.Exit.Compat
import           System.FilePath
import           System.IO.Temp
import           System.Process

import           Tinc.Setup
import           Package
import           PackageGraph
import           Util

data Sandbox
data PackageDB
data PackageConfig

currentDirectory :: Path Sandbox
currentDirectory = "."

initSandbox :: IO (Path PackageDB)
initSandbox = do
  callCommand "cabal sandbox init"
  findPackageDB currentDirectory

deleteSandbox :: IO ()
deleteSandbox = callCommand "cabal sandbox delete"

installDependencies :: Path Cache -> IO ()
installDependencies cache = do
  exists <- doesDirectoryExist ".cabal-sandbox"
  when exists deleteSandbox
  installPlan <- parseInstallPlan <$> readProcess "cabal" command ""
  (packages, packageConfigs)  <- unzip <$> findReusablePackages cache installPlan
  if null (installPlan \\ packages)
    then do
      destPackageDB <- initSandbox
      registerPackageConfigs destPackageDB packageConfigs
    else do
      createCacheSandbox cache installPlan packageConfigs
  where
    command :: [String]
    command = words "install --only-dependencies --enable-tests --dry-run --package-db=clear --package-db=global"

createCacheSandbox :: Path Cache -> [Package] -> [Path PackageConfig] -> IO ()
createCacheSandbox cache installPlan packageConfigs = do
  basename <- takeBaseName <$> getCurrentDirectory
  sandbox <- createTempDirectory (path cache) (basename ++ "-")
  create sandbox packageConfigs `onException` removeDirectoryRecursive sandbox
  cloneSandbox (Path sandbox)
  where
    create sandbox cachedPackages = do
      withCurrentDirectory sandbox $ do
        destPackageDB <- initSandbox
        registerPackageConfigs destPackageDB cachedPackages
        callProcess "cabal" ("install" : map showPackage installPlan)

findReusablePackages :: Path Cache -> [Package] -> IO [(Package, Path PackageConfig)]
findReusablePackages cache installPlan = do
  sandboxes <- lookupSandboxes cache
  globalPackages <- listGlobalPackages
  cachedPackages <- fmap concat . forM sandboxes $ \ sandbox -> do
    packageDB <- findPackageDB sandbox
    cacheGraph <- readPackageGraph packageDB
    let packages = nubBy ((==) `on` packageName) (installPlan ++ globalPackages)
        reusable = calculateReusablePackages packages cacheGraph
    lookupPackages packageDB reusable
  return $ nubBy ((==) `on` fst) cachedPackages

lookupSandboxes :: Path Cache -> IO [Path Sandbox]
lookupSandboxes (Path cache) = map Path <$> listDirectories cache

listGlobalPackages :: IO [Package]
listGlobalPackages = do
  packageDB <- findGlobalPackageDB
  vertices <$> readPackageGraph_ [packageDB]

cloneSandbox :: Path Sandbox -> IO ()
cloneSandbox source = do
  sourcePackageDB <- findPackageDB source
  destPackageDB <- initSandbox
  packages <- extractPackages sourcePackageDB
  registerPackageConfigs destPackageDB packages

findPackageDB :: Path Sandbox -> IO (Path PackageDB)
findPackageDB sandbox = do
  xs <- getDirectoryContents sandboxDir
  case listToMaybe (filter isPackageDB xs) of
    Just p -> Path <$> canonicalizePath (sandboxDir </> p)
    Nothing -> die ("package db not found in " ++ sandboxDir)
  where
    sandboxDir = path sandbox </> ".cabal-sandbox"

isPackageDB :: FilePath -> Bool
isPackageDB = ("-packages.conf.d" `isSuffixOf`)

extractPackages :: Path PackageDB -> IO [Path PackageConfig]<commit_msg>Some DRY up and refactoring<commit_after>{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
module Tinc.Install (
  Path (..)
, Sandbox
, PackageDB
, PackageConfig
, Cache
, installDependencies

-- exported for testing
, findPackageDB
, extractPackages
, isPackageDB
) where

import           Prelude ()
import           Prelude.Compat

import           Control.Exception
import           Control.Monad.Compat
import           Data.Function
import           Data.Graph.Wrapper
import           Data.List.Compat
import           Data.Maybe
import           System.Directory
import           System.Exit.Compat
import           System.FilePath
import           System.IO.Temp
import           System.Process

import           Tinc.Setup
import           Package
import           PackageGraph
import           Util

data Sandbox
data PackageDB
data PackageConfig

currentDirectory :: Path Sandbox
currentDirectory = "."

initSandbox :: [Path PackageConfig] -> IO ()
initSandbox packageConfigs = do
  callCommand "cabal sandbox init"
  packageDB <- findPackageDB currentDirectory
  registerPackageConfigs packageDB packageConfigs

deleteSandbox :: IO ()
deleteSandbox = do
  exists <- doesDirectoryExist ".cabal-sandbox"
  when exists (callCommand "cabal sandbox delete")

installDependencies :: Path Cache -> IO ()
installDependencies cache = do
  deleteSandbox
  installPlan <- parseInstallPlan <$> readProcess "cabal" command ""
  (missing, reusable)  <- findReusablePackages cache installPlan
  createProjectSandbox cache installPlan missing reusable
  where
    command :: [String]
    command = words "install --only-dependencies --enable-tests --dry-run --package-db=clear --package-db=global"

createProjectSandbox :: Path Cache -> [Package] -> [Package] -> [Path PackageConfig] -> IO ()
createProjectSandbox cache installPlan missing reusable
  | null missing = initSandbox reusable
  | otherwise = createCacheSandbox cache installPlan reusable

createCacheSandbox :: Path Cache -> [Package] -> [Path PackageConfig] -> IO ()
createCacheSandbox cache installPlan reusable = do
  basename <- takeBaseName <$> getCurrentDirectory
  sandbox <- createTempDirectory (path cache) (basename ++ "-")
  create sandbox reusable `onException` removeDirectoryRecursive sandbox
  cloneSandbox (Path sandbox)
  where
    create sandbox cachedPackages = do
      withCurrentDirectory sandbox $ do
        initSandbox cachedPackages
        callProcess "cabal" ("install" : map showPackage installPlan)

findReusablePackages :: Path Cache -> [Package] -> IO ([Package], [Path PackageConfig])
findReusablePackages cache installPlan = do
  sandboxes <- lookupSandboxes cache
  globalPackages <- listGlobalPackages
  cachedPackages <- fmap concat . forM sandboxes $ \ sandbox -> do
    packageDB <- findPackageDB sandbox
    cacheGraph <- readPackageGraph packageDB
    let packages = nubBy ((==) `on` packageName) (installPlan ++ globalPackages)
        reusable = calculateReusablePackages packages cacheGraph
    lookupPackages packageDB reusable
  let (reusablePackages, reusablePackageConfigs) = unzip $ nubBy ((==) `on` fst) cachedPackages
      missingPackages = installPlan \\ reusablePackages
  return (missingPackages, reusablePackageConfigs)

lookupSandboxes :: Path Cache -> IO [Path Sandbox]
lookupSandboxes (Path cache) = map Path <$> listDirectories cache

listGlobalPackages :: IO [Package]
listGlobalPackages = do
  packageDB <- findGlobalPackageDB
  vertices <$> readPackageGraph_ [packageDB]

cloneSandbox :: Path Sandbox -> IO ()
cloneSandbox source = do
  sourcePackageDB <- findPackageDB source
  packages <- extractPackages sourcePackageDB
  initSandbox packages

findPackageDB :: Path Sandbox -> IO (Path PackageDB)
findPackageDB sandbox = do
  xs <- getDirectoryContents sandboxDir
  case listToMaybe (filter isPackageDB xs) of
    Just p -> Path <$> canonicalizePath (sandboxDir </> p)
    Nothing -> die ("package db not found in " ++ sandboxDir)
  where
    sandboxDir = path sandbox </> ".cabal-sandbox"

isPackageDB :: FilePath -> Bool
isPackageDB = ("-packages.conf.d" `isSuffixOf`)

extractPackages :: Path PackageDB -> IO [Path PackageConfig]
{'fraction_non_alphanumeric': 0.0829961995831801, 'fraction_numerical': 0.0, 'mean_word_length': 3.6993087557603688, 'pattern_counts': {'":': 0, '<': 50, '<?xml version=': 0, '>': 51, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '2535054', 'n_tokens_mistral': 2324, 'n_tokens_neox': 2205, 'n_words': 665}