{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
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 Aura.Utils
import Control.Monad.Trans.Maybe
import Control.Scheduler (Comp(..), traverseConcurrently)
import Data.Versions (versioning)
import Lens.Micro (each, non, (^..))
import Linux.Arch.Aur
import Network.HTTP.Client (Manager)
import RIO
import RIO.Directory
import RIO.FilePath
import qualified RIO.List as L
import qualified RIO.Map as M
import qualified RIO.NonEmpty as NEL
import qualified RIO.Set as S
import qualified RIO.Text as T
import System.Process.Typed
aurLookup :: Manager -> NonEmpty PkgName -> IO (Maybe (Set PkgName, 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 . to bName
pure (S.fromList bads <> S.fromList (NEL.toList names) S.\\ goodNames, S.fromList goods)
aurRepo :: IO Repository
aurRepo = do
tv <- newTVarIO mempty
let f :: Settings -> NonEmpty PkgName -> IO (Maybe (Set PkgName, 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) uncached'
let !pkgs = map FromAUR $ S.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
{ bName = PkgName $ aurNameOf ai
, bVersion = ver
, bBase = bse
, bProvides = providesOf ai ^. to listToMaybe . non (aurNameOf ai) . to (Provides . PkgName)
, bDeps = mapMaybe parseDep $ dependsOf ai ++ makeDepsOf ai
, bPkgbuild = pb
, bIsExplicit = False }
aurLink :: FilePath
aurLink = "https://aur.archlinux.org"
pkgUrl :: PkgName -> Text
pkgUrl (PkgName pkg) = T.pack $ aurLink </> "packages" </> T.unpack pkg
clone :: Buildable -> IO (Maybe FilePath)
clone b = do
ec <- runProcess . setStderr closed . setStdout closed
$ proc "git" [ "clone", "--depth", "1", url ]
case ec of
ExitFailure _ -> pure Nothing
ExitSuccess -> do
pwd <- getCurrentDirectory
pure . Just $ pwd </> pathy
where
pathy :: FilePath
pathy = T.unpack . pnName $ bBase b
url :: FilePath
url = aurLink </> pathy <.> "git"
sortAurInfo :: Maybe BuildSwitch -> [AurInfo] -> [AurInfo]
sortAurInfo bs ai = L.sortBy compare' ai
where compare' = case bs of
Just SortAlphabetically -> compare `on` aurNameOf
_ -> \x y -> compare (aurVotesOf y) (aurVotesOf x)
aurSearch :: Text -> RIO Env [AurInfo]
aurSearch regex = do
ss <- asks settings
res <- liftMaybeM (Failure connectFailure_1) . fmap hush . liftIO $ search (managerOf ss) regex
pure $ sortAurInfo (bool Nothing (Just SortAlphabetically) $ switch ss SortAlphabetically) res
aurInfo :: NonEmpty PkgName -> RIO Env [AurInfo]
aurInfo pkgs = do
logDebug $ "AUR: Looking up " <> display (length pkgs) <> " packages..."
m <- asks (managerOf . settings)
sortAurInfo (Just SortAlphabetically) . fold
<$> traverseConcurrently Par' (work m) (groupsOf 50 $ NEL.toList pkgs)
where
work :: Manager -> [PkgName] -> RIO Env [AurInfo]
work m ps = liftIO (info m $ map pnName ps) >>= \case
Left (NotFound _) -> throwM (Failure connectFailure_1)
Left BadJSON -> throwM (Failure miscAURFailure_3)
Left (OtherAurError e) -> do
let !resp = display $ decodeUtf8Lenient e
logDebug $ "Failed! Server said: " <> resp
throwM (Failure miscAURFailure_1)
Right res -> pure res