{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
module Distribution.ArchHs.ExtraDB
( defaultExtraDBPath,
loadExtraDB,
isInExtra,
versionInExtra,
getPkgDesc,
#ifdef ALPM
loadExtraDBFFI,
#endif
)
where
import Conduit
import qualified Data.Conduit.Tar as Tar
import qualified Data.Conduit.Zlib as Zlib
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
import Distribution.ArchHs.Exception
import Distribution.ArchHs.Internal.Prelude
import Distribution.ArchHs.Name
import Distribution.ArchHs.PkgDesc
import Distribution.ArchHs.Types
import Data.Maybe (mapMaybe)
#ifdef ALPM
{-# LANGUAGE ForeignFunctionInterface #-}
import Data.IORef (IORef, modifyIORef', newIORef, readIORef)
import Distribution.ArchHs.Utils (extractFromEVR)
import Foreign.C.String (CString, peekCString)
import Foreign.Ptr (FunPtr, freeHaskellFunPtr)
foreign import ccall "wrapper"
wrap :: (CString -> CString -> CString -> CString -> IO ()) -> IO (FunPtr (CString -> CString -> CString -> CString -> IO ()))
foreign import ccall "clib.h query_extra"
query_extra :: FunPtr (CString -> CString -> CString -> CString -> IO ()) -> FunPtr (CString -> CString -> CString -> CString -> IO ()) -> IO ()
type RawPkgSet = IORef (Map.Map ArchLinuxName ((ArchLinuxVersion, String, String), IORef (Map.Map String [(ArchLinuxName, Maybe ArchLinuxVersion)])))
pkgCallback :: RawPkgSet -> CString -> CString -> CString -> CString -> IO ()
pkgCallback ref name version desc url = do
name' <- peekCString name
version' <- peekCString version
desc' <- peekCString desc
url' <- peekCString url
m <- newIORef Map.empty
modifyIORef' ref (Map.insert (ArchLinuxName name') ((extractFromEVR version', desc', url'), m))
listCallback :: RawPkgSet -> CString -> CString -> CString -> CString -> IO ()
listCallback ref name key dm dv = do
name' <- peekCString name
key' <- peekCString key
dm' <- peekCString dm
dv' <- peekCString dv
s <- snd . (\r -> r Map.! ArchLinuxName name') <$> readIORef ref
modifyIORef' s (Map.insertWith (++) key' [(ArchLinuxName dm', if null dv' then Nothing else Just (extractFromEVR dv'))])
loadExtraDBFFI :: IO ExtraDB
loadExtraDBFFI = do
ref <- newIORef Map.empty
pkgCallbackW <- wrap $ pkgCallback ref
listCallbackW <- wrap $ listCallback ref
query_extra pkgCallbackW listCallbackW
freeHaskellFunPtr pkgCallbackW
freeHaskellFunPtr listCallbackW
s <- readIORef ref
re <-
mapM
( \(name, ((ver, desc, url), r)) -> do
l <- readIORef r
let f (Just xs) = uncurry PkgDependent <$> xs
f Nothing = []
pure
( name,
PkgDesc
{ _name = name,
_version = ver,
_desc = desc,
_url = if null url then Nothing else Just url,
_depends = f $ l Map.!? "depends",
_provides = f $ l Map.!? "provides",
_conflicts = f $ l Map.!? "conflicts",
_optDepends = f $ l Map.!? "optdepends",
_makeDepends = f $ l Map.!? "makedepends",
_checkDepends = f $ l Map.!? "checkdepends",
_replaces = f $ l Map.!? "replaces"
}
)
)
$ Map.toList s
pure $ Map.fromList re
#endif
defaultExtraDBPath :: FilePath
= FilePath
"/" FilePath -> FilePath -> FilePath
</> FilePath
"var" FilePath -> FilePath -> FilePath
</> FilePath
"lib" FilePath -> FilePath -> FilePath
</> FilePath
"pacman" FilePath -> FilePath -> FilePath
</> FilePath
"sync" FilePath -> FilePath -> FilePath
</> FilePath
"extra.db"
loadExtraDBC ::
(MonadResource m, PrimMonad m, MonadThrow m) =>
FilePath ->
ConduitT i (ArchLinuxName, PkgDesc) m ()
FilePath
path = do
forall (m :: * -> *) i.
MonadResource m =>
FilePath -> ConduitT i ByteString m ()
sourceFileBS FilePath
path forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *).
(PrimMonad m, MonadThrow m) =>
ConduitT ByteString ByteString m ()
Zlib.ungzip forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *). Monad m => ConduitM ByteString TarChunk m ()
Tar.untarChunks forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) o.
MonadThrow m =>
(Header -> ConduitM ByteString o m ()) -> ConduitM TarChunk o m ()
Tar.withEntries forall {m :: * -> *}.
Monad m =>
Header -> ConduitT ByteString (ArchLinuxName, PkgDesc) m ()
action
where
action :: Header -> ConduitT ByteString (ArchLinuxName, PkgDesc) m ()
action Header
header =
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Header -> FileType
Tar.headerFileType Header
header forall a. Eq a => a -> a -> Bool
== FileType
Tar.FTNormal) forall a b. (a -> b) -> a -> b
$ do
ByteString
x <- forall a. Monoid a => [a] -> a
mconcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
sinkList
let txt :: FilePath
txt = Text -> FilePath
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 forall a b. (a -> b) -> a -> b
$ ByteString
x
parsed :: Either (ParseErrorBundle FilePath Void) PkgDesc
parsed = FilePath
-> FilePath -> Either (ParseErrorBundle FilePath Void) PkgDesc
runDescParser (Header -> FilePath
Tar.headerFilePath Header
header) FilePath
txt
result :: [PkgDesc]
result = case Either (ParseErrorBundle FilePath Void) PkgDesc
parsed of
Right PkgDesc
desc ->
PkgDesc
desc
forall a. a -> [a] -> [a]
: ( if PkgDesc -> ArchLinuxName
_name PkgDesc
desc forall a. Eq a => a -> a -> Bool
== FilePath -> ArchLinuxName
ArchLinuxName FilePath
"ghc"
Bool -> Bool -> Bool
|| PkgDesc -> ArchLinuxName
_name PkgDesc
desc forall a. Eq a => a -> a -> Bool
== FilePath -> ArchLinuxName
ArchLinuxName FilePath
"ghc-libs"
then forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe PkgDependent -> Maybe PkgDesc
promoteDependent (PkgDesc -> PkgDependentList
_provides PkgDesc
desc)
else []
)
Left ParseErrorBundle FilePath Void
_ -> []
forall (m :: * -> *) mono i.
(Monad m, MonoFoldable mono) =>
mono -> ConduitT i (Element mono) m ()
yieldMany forall a b. (a -> b) -> a -> b
$ (\PkgDesc
desc -> (PkgDesc -> ArchLinuxName
_name PkgDesc
desc, PkgDesc
desc)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PkgDesc]
result
loadExtraDB :: FilePath -> IO ExtraDB
FilePath
path = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes (forall (m :: * -> *) i.
(MonadResource m, PrimMonad m, MonadThrow m) =>
FilePath -> ConduitT i (ArchLinuxName, PkgDesc) m ()
loadExtraDBC FilePath
path forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
sinkList)
isInExtra :: (HasMyName n, Member ExtraEnv r) => n -> Sem r Bool
n
name = forall i (r :: EffectRow). Member (Reader i) r => Sem r i
ask @ExtraDB forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ExtraDB
db -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall n. HasMyName n => n -> ArchLinuxName
toArchLinuxName n
name forall k a. Ord k => k -> Map k a -> Bool
`Map.member` ExtraDB
db
versionInExtra :: (HasMyName n, Members [ExtraEnv, WithMyErr] r) => n -> Sem r ArchLinuxVersion
n
name = PkgDesc -> FilePath
_version forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall n (r :: EffectRow).
(HasMyName n, Members '[ExtraEnv, WithMyErr] r) =>
n -> Sem r PkgDesc
getPkgDesc n
name
getPkgDesc :: (HasMyName n, Members [ExtraEnv, WithMyErr] r) => n -> Sem r PkgDesc
getPkgDesc :: forall n (r :: EffectRow).
(HasMyName n, Members '[ExtraEnv, WithMyErr] r) =>
n -> Sem r PkgDesc
getPkgDesc n
name =
forall i (r :: EffectRow). Member (Reader i) r => Sem r i
ask @ExtraDB forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ExtraDB
db -> case ExtraDB
db forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? forall n. HasMyName n => n -> ArchLinuxName
toArchLinuxName n
name of
Just PkgDesc
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure PkgDesc
x
Maybe PkgDesc
_ -> forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw forall a b. (a -> b) -> a -> b
$ forall n. HasMyName n => n -> MyException
PkgNotFound n
name