{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
module Aura.Packages.AUR
(
aurLookup
, aurRepo
, aurInfo
, aurSearch
, clone
, pkgUrl
) where
import Aura.Core
import Aura.Languages
import Aura.Pkgbuild.Fetch
import Aura.Settings
import Aura.Types
import BasePrelude hiding (head)
import Control.Compactable (fmapEither)
import Control.Concurrent.STM.TVar (modifyTVar')
import Control.Error.Util (hush, note)
import Control.Effect (Carrier, Member)
import Control.Effect.Error (Error)
import Control.Effect.Lift (Lift, sendM)
import Control.Effect.Reader (Reader, asks)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe
import Control.Scheduler (Comp(..), traverseConcurrently)
import Data.Generics.Product (field)
import qualified Data.List.NonEmpty as NEL
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import Data.Set.NonEmpty (NESet)
import qualified Data.Set.NonEmpty as NES
import qualified Data.Text as T
import Data.Versions (versioning)
import Lens.Micro (each, non, to, (^.), (^..))
import Linux.Arch.Aur
import Network.HTTP.Client (Manager)
import System.Path
import System.Path.IO (getCurrentDirectory)
import System.Process.Typed
aurLookup :: Manager -> NESet PkgName -> IO (Maybe (S.Set PkgName, S.Set Buildable))
aurLookup m names = runMaybeT $ do
infos <- MaybeT . fmap hush . info m $ foldr (\(PkgName pn) acc -> pn : acc) [] names
badsgoods <- lift $ traverseConcurrently Par' (buildable m) infos
let (bads, goods) = partitionEithers badsgoods
goodNames = S.fromList $ goods ^.. each . field @"name"
pure (S.fromList bads <> NES.toSet names S.\\ goodNames, S.fromList goods)
aurRepo :: IO Repository
aurRepo = do
tv <- newTVarIO mempty
let f :: Settings -> NESet PkgName -> IO (Maybe (S.Set PkgName, S.Set Package))
f ss ps = do
cache <- readTVarIO tv
let (uncached, cached) = fmapEither (\p -> note p $ M.lookup p cache) $ toList ps
case NEL.nonEmpty uncached of
Nothing -> pure $ Just (S.empty, S.fromList cached)
Just uncached' -> runMaybeT $ do
(bads, goods) <- MaybeT . aurLookup (managerOf ss) $ NES.fromList uncached'
pkgs <- lift . traverse (packageBuildable ss) $ toList goods
let m = M.fromList $ map (pname &&& id) pkgs
liftIO . atomically $ modifyTVar' tv (<> m)
pure (bads, S.fromList $ cached <> pkgs)
pure $ Repository tv f
buildable :: Manager -> AurInfo -> IO (Either PkgName Buildable)
buildable m ai = do
let !bse = PkgName $ pkgBaseOf ai
mver = hush . versioning $ aurVersionOf ai
mpb <- getPkgbuild m bse
case (,) <$> mpb <*> mver of
Nothing -> pure . Left . PkgName $ aurNameOf ai
Just (pb, ver) -> pure $ Right Buildable
{ name = PkgName $ aurNameOf ai
, version = ver
, base = bse
, provides = providesOf ai ^. to listToMaybe . non (aurNameOf ai) . to (Provides . PkgName)
, deps = mapMaybe parseDep $ dependsOf ai ++ makeDepsOf ai
, pkgbuild = pb
, isExplicit = False }
aurLink :: Path Unrooted
aurLink = fromUnrootedFilePath "https://aur.archlinux.org"
pkgUrl :: PkgName -> T.Text
pkgUrl (PkgName pkg) = T.pack . toUnrootedFilePath $ aurLink </> fromUnrootedFilePath "packages" </> fromUnrootedFilePath (T.unpack pkg)
clone :: Buildable -> IO (Maybe (Path Absolute))
clone b = do
ec <- runProcess . setStderr closed . setStdout closed $ proc "git" [ "clone", "--depth", "1", toUnrootedFilePath url ]
case ec of
(ExitFailure _) -> pure Nothing
ExitSuccess -> do
pwd <- getCurrentDirectory
pure . Just $ pwd </> (b ^. field @"base" . field @"name" . to (fromUnrootedFilePath . T.unpack))
where url = aurLink </> (b ^. field @"base" . field @"name" . to (fromUnrootedFilePath . T.unpack)) <.> FileExt "git"
sortAurInfo :: Maybe BuildSwitch -> [AurInfo] -> [AurInfo]
sortAurInfo bs ai = sortBy compare' ai
where compare' = case bs of
Just SortAlphabetically -> compare `on` aurNameOf
_ -> \x y -> compare (aurVotesOf y) (aurVotesOf x)
aurSearch :: (Carrier sig m, Member (Reader Env) sig, Member (Error Failure) sig, Member (Lift IO) sig) =>
T.Text -> m [AurInfo]
aurSearch regex = do
ss <- asks settings
res <- liftMaybeM (Failure connectionFailure_1) . fmap hush . sendM $ search (managerOf ss) regex
pure $ sortAurInfo (bool Nothing (Just SortAlphabetically) $ switch ss SortAlphabetically) res
aurInfo :: (Carrier sig m, Member (Reader Env) sig, Member (Error Failure) sig, Member (Lift IO) sig) =>
NonEmpty PkgName -> m [AurInfo]
aurInfo pkgs = do
m <- asks (managerOf . settings)
res <- liftMaybeM (Failure connectionFailure_1) . fmap hush . sendM . info m . map (^. field @"name") $ toList pkgs
pure $ sortAurInfo (Just SortAlphabetically) res