{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts, TypeApplications, MonoLocalBinds, DataKinds #-}
module Aura.Build
( installPkgFiles
, buildPackages
) where
import Aura.Core
import Aura.Languages
import Aura.MakePkg
import Aura.Packages.AUR (clone)
import Aura.Pacman (pacman)
import Aura.Settings
import Aura.Types
import Aura.Utils
import BasePrelude
import Control.Monad.Freer
import Control.Monad.Freer.Error
import Control.Monad.Freer.Reader
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except
import qualified Data.ByteString.Lazy.Char8 as BL
import Data.Generics.Product (field)
import qualified Data.List.NonEmpty as NEL
import Data.Semigroup.Foldable (fold1)
import qualified Data.Set as S
import Data.Set.NonEmpty (NonEmptySet)
import qualified Data.Set.NonEmpty as NES
import qualified Data.Text as T
import Data.Witherable (wither)
import Lens.Micro ((^.))
import System.Directory (setCurrentDirectory)
import System.IO (hFlush, stdout)
import System.Path
import System.Path.IO
import System.Process.Typed
import System.Random.MWC (GenIO, uniform, createSystemRandom)
srcPkgStore :: Path Absolute
srcPkgStore = fromAbsoluteFilePath "/var/cache/aura/src"
installPkgFiles :: (Member (Reader Settings) r, Member (Error Failure) r, Member IO r) =>
NonEmptySet PackagePath -> Eff r ()
installPkgFiles files = do
ss <- ask
send $ checkDBLock ss
liftEitherM . pacman $ ["-U"] <> map (toFilePath . path) (toList files) <> asFlag (commonConfigOf ss)
buildPackages :: (Member (Reader Settings) r, Member (Error Failure) r, Member IO r) =>
NonEmptySet Buildable -> Eff r (NonEmptySet PackagePath)
buildPackages bs = do
g <- send createSystemRandom
wither (build g) (toList bs) >>= maybe bad (pure . fold1) . NEL.nonEmpty
where bad = throwError $ Failure buildFail_10
build :: (Member (Reader Settings) r, Member (Error Failure) r, Member IO r) =>
GenIO -> Buildable -> Eff r (Maybe (NonEmptySet PackagePath))
build g p = do
ss <- ask
send $ notify ss (buildPackages_1 (p ^. field @"name") (langOf ss)) *> hFlush stdout
result <- send $ build' ss g p
either buildFail (pure . Just) result
build' :: Settings -> GenIO -> Buildable -> IO (Either Failure (NonEmptySet PackagePath))
build' ss g b = do
let pth = buildPathOf $ buildConfigOf ss
createDirectoryIfMissing True pth
setCurrentDirectory $ toFilePath pth
buildDir <- randomDirName g b
createDirectoryIfMissing True buildDir
setCurrentDirectory $ toFilePath buildDir
runExceptT $ do
bs <- ExceptT $ cloneRepo b usr
lift . setCurrentDirectory $ toFilePath bs
lift $ overwritePkgbuild ss b
pNames <- ExceptT $ makepkg ss usr
paths <- lift . fmap NES.fromNonEmpty . traverse (moveToCachePath ss) $ NES.toNonEmpty pNames
lift . when (S.member AllSource . makepkgFlagsOf $ buildConfigOf ss) $
makepkgSource usr >>= traverse_ moveToSourcePath
pure paths
where usr = fromMaybe (User "桜木花道") . buildUserOf $ buildConfigOf ss
randomDirName :: GenIO -> Buildable -> IO (Path Absolute)
randomDirName g b = do
pwd <- getCurrentDirectory
v <- uniform g :: IO Word
let dir = T.unpack (b ^. field @"name" . field @"name") <> "-" <> show v
pure $ pwd </> fromUnrootedFilePath dir
cloneRepo :: Buildable -> User -> IO (Either Failure (Path Absolute))
cloneRepo pkg usr = do
currDir <- getCurrentDirectory
scriptsDir <- chown usr currDir [] *> clone pkg
case scriptsDir of
Nothing -> pure . Left . Failure . buildFail_7 $ pkg ^. field @"name"
Just sd -> chown usr sd ["-R"] $> Right sd
overwritePkgbuild :: Settings -> Buildable -> IO ()
overwritePkgbuild ss p = when (switch ss HotEdit || switch ss UseCustomizepkg) $
BL.writeFile "PKGBUILD" $ p ^. field @"pkgbuild" . field @"pkgbuild"
buildFail :: (Member (Reader Settings) r, Member (Error Failure) r, Member IO r) => Failure -> Eff r (Maybe a)
buildFail (Failure err) = do
ss <- ask
send . scold ss . err $ langOf ss
response <- send $ optionalPrompt ss buildFail_6
bool (throwError $ Failure buildFail_5) (pure Nothing) response
moveToCachePath :: Settings -> Path Absolute -> IO PackagePath
moveToCachePath ss p = copy $> PackagePath newName
where newName = pth </> takeFileName p
pth = either id id . cachePathOf $ commonConfigOf ss
copy = runProcess . setStderr closed . setStdout closed
$ proc "cp" ["--reflink=auto", toFilePath p, toFilePath newName ]
moveToSourcePath :: Path Absolute -> IO (Path Absolute)
moveToSourcePath p = renameFile p newName $> newName
where newName = srcPkgStore </> takeFileName p