{-# LANGUAGE CPP #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module Distribution.ArchHs.FilesDB
( defaultFilesDBDir,
loadFilesDB,
#ifdef ALPM
loadFilesDBFFI,
#endif
lookupPkg,
DBKind (..),
File,
FilesDB,
)
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.Internal.Prelude
import Distribution.ArchHs.PkgDesc (runDescFieldsParser)
import Distribution.ArchHs.Types
#ifdef ALPM
{-# LANGUAGE ForeignFunctionInterface #-}
import qualified Data.Sequence as Seq
import Data.Foldable (toList)
import Data.IORef (IORef, modifyIORef', newIORef, readIORef)
import Foreign.C.String (newCString, CString, peekCString)
import Foreign.Ptr (FunPtr, freeHaskellFunPtr)
foreign import ccall "wrapper"
wrap :: (CString -> CString -> IO ()) -> IO (FunPtr (CString -> CString -> IO ()))
foreign import ccall "clib.h query_files"
query_files :: CString -> FunPtr (CString -> CString -> IO ()) -> IO ()
callback :: IORef (Seq.Seq (ArchLinuxName, FilePath)) -> CString -> CString -> IO ()
callback ref x y = do
x' <- peekCString x
y' <- peekCString y
modifyIORef' ref (Seq.|> (ArchLinuxName x', y'))
loadFilesDBFFI :: DBKind -> IO FilesDB
loadFilesDBFFI (show -> db) = do
ref <- newIORef Seq.empty
db' <- newCString db
callbackW <- wrap $ callback ref
query_files db' callbackW
freeHaskellFunPtr callbackW
list <- toList <$> readIORef ref
return $ foldr (\(k,v)-> Map.insertWith (<>) k [v]) Map.empty list
#endif
defaultFilesDBDir :: FilePath
defaultFilesDBDir :: FilePath
defaultFilesDBDir = FilePath
"/" FilePath -> FilePath -> FilePath
</> FilePath
"var" FilePath -> FilePath -> FilePath
</> FilePath
"lib" FilePath -> FilePath -> FilePath
</> FilePath
"pacman" FilePath -> FilePath -> FilePath
</> FilePath
"sync"
loadFilesDBC ::
(MonadResource m, PrimMonad m, MonadThrow m) =>
DBKind ->
FilePath ->
ConduitT i Result m ()
loadFilesDBC :: DBKind -> FilePath -> ConduitT i Result m ()
loadFilesDBC DBKind
db FilePath
dir = do
FilePath -> ConduitT i ByteString m ()
forall (m :: * -> *) i.
MonadResource m =>
FilePath -> ConduitT i ByteString m ()
sourceFileBS (FilePath
dir FilePath -> FilePath -> FilePath
</> DBKind -> FilePath
forall a. Show a => a -> FilePath
show DBKind
db FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
".files") ConduitT i ByteString m ()
-> ConduitM ByteString Result m () -> ConduitT i Result m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitT ByteString ByteString m ()
forall (m :: * -> *).
(PrimMonad m, MonadThrow m) =>
ConduitT ByteString ByteString m ()
Zlib.ungzip ConduitT ByteString ByteString m ()
-> ConduitM ByteString Result m ()
-> ConduitM ByteString Result m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM ByteString TarChunk m ()
forall (m :: * -> *). Monad m => ConduitM ByteString TarChunk m ()
Tar.untarChunks ConduitM ByteString TarChunk m ()
-> ConduitM TarChunk Result m () -> ConduitM ByteString Result m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| (Header -> ConduitM ByteString Result m ())
-> ConduitM TarChunk Result m ()
forall (m :: * -> *) o.
MonadThrow m =>
(Header -> ConduitM ByteString o m ()) -> ConduitM TarChunk o m ()
Tar.withEntries Header -> ConduitM ByteString Result m ()
forall (m :: * -> *).
Monad m =>
Header -> ConduitT ByteString Result m ()
action
where
action :: Header -> ConduitT ByteString Result m ()
action Header
header
| FileType
Tar.FTNormal <- Header -> FileType
Tar.headerFileType Header
header,
[FilePath
fp, FilePath
t] <- FilePath -> FilePath -> [FilePath]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn FilePath
"/" (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall a b. (a -> b) -> a -> b
$ Header -> FilePath
Tar.headerFilePath Header
header =
do
ByteString
x <- [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat ([ByteString] -> ByteString)
-> ConduitT ByteString Result m [ByteString]
-> ConduitT ByteString Result m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConduitT ByteString Result m [ByteString]
forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
sinkList
let txt :: Text
txt = ByteString -> Text
decodeUtf8 ByteString
x
case FilePath
t of
FilePath
"files" -> Result -> ConduitT ByteString Result m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (Result -> ConduitT ByteString Result m ())
-> ([FilePath] -> Result)
-> [FilePath]
-> ConduitT ByteString Result m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath] -> Result
Files FilePath
fp ([FilePath] -> ConduitT ByteString Result m ())
-> [FilePath] -> ConduitT ByteString Result m ()
forall a b. (a -> b) -> a -> b
$ [Text -> FilePath
T.unpack Text
fname | (Text -> Maybe Text
extract -> Just Text
fname) <- [Text] -> [Text]
forall a. [a] -> [a]
tail ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.lines Text
txt]
FilePath
"desc" -> case FilePath
-> FilePath
-> Either
(ParseErrorBundle FilePath Void) (Map FilePath [FilePath])
runDescFieldsParser FilePath
fp (Text -> FilePath
T.unpack Text
txt) of
Right Map FilePath [FilePath]
r | [FilePath
name] <- Map FilePath [FilePath]
r Map FilePath [FilePath] -> FilePath -> [FilePath]
forall k a. Ord k => Map k a -> k -> a
Map.! FilePath
"NAME" -> Result -> ConduitT ByteString Result m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (Result -> ConduitT ByteString Result m ())
-> (ArchLinuxName -> Result)
-> ArchLinuxName
-> ConduitT ByteString Result m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ArchLinuxName -> Result
Desc FilePath
fp (ArchLinuxName -> ConduitT ByteString Result m ())
-> ArchLinuxName -> ConduitT ByteString Result m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ArchLinuxName
ArchLinuxName FilePath
name
Either (ParseErrorBundle FilePath Void) (Map FilePath [FilePath])
_ -> () -> ConduitT ByteString Result m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
FilePath
_ -> () -> ConduitT ByteString Result m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = () -> ConduitT ByteString Result m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
extract :: T.Text -> Maybe T.Text
extract :: Text -> Maybe Text
extract Text
s
| Just Text
x <- Text -> Text -> Maybe Text
T.stripPrefix Text
"usr/lib/" Text
s,
Text -> Text -> Bool
T.isSuffixOf Text
".so" Text
x Bool -> Bool -> Bool
|| Text -> Text -> Bool
T.isSuffixOf Text
".pc" Text
x =
Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.takeWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/') Text
x
| Bool
otherwise = Maybe Text
forall a. Maybe a
Nothing
mergeResult :: Monad m => ConduitT Result (ArchLinuxName, [File]) m ()
mergeResult :: ConduitT Result (ArchLinuxName, [FilePath]) m ()
mergeResult = do
Maybe Result
rName <- ConduitT Result (ArchLinuxName, [FilePath]) m (Maybe Result)
forall (m :: * -> *) i. Monad m => Consumer i m (Maybe i)
await
Maybe Result
rFiles <- ConduitT Result (ArchLinuxName, [FilePath]) m (Maybe Result)
forall (m :: * -> *) i. Monad m => Consumer i m (Maybe i)
await
case () of
()
| Just (Desc FilePath
fpd ArchLinuxName
name) <- Maybe Result
rName,
Just (Files FilePath
fpf [FilePath]
files) <- Maybe Result
rFiles,
FilePath
fpd FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
fpf ->
Bool
-> ConduitT Result (ArchLinuxName, [FilePath]) m ()
-> ConduitT Result (ArchLinuxName, [FilePath]) m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([FilePath]
files [FilePath] -> [FilePath] -> Bool
forall a. Eq a => a -> a -> Bool
/= []) ((ArchLinuxName, [FilePath])
-> ConduitT Result (ArchLinuxName, [FilePath]) m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (ArchLinuxName
name, [FilePath]
files)) ConduitT Result (ArchLinuxName, [FilePath]) m ()
-> ConduitT Result (ArchLinuxName, [FilePath]) m ()
-> ConduitT Result (ArchLinuxName, [FilePath]) m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ConduitT Result (ArchLinuxName, [FilePath]) m ()
forall (m :: * -> *).
Monad m =>
ConduitT Result (ArchLinuxName, [FilePath]) m ()
mergeResult
()
_ -> () -> ConduitT Result (ArchLinuxName, [FilePath]) m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
loadFilesDB :: DBKind -> FilePath -> IO FilesDB
loadFilesDB :: DBKind -> FilePath -> IO FilesDB
loadFilesDB DBKind
db FilePath
dir = [(ArchLinuxName, [FilePath])] -> FilesDB
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ArchLinuxName, [FilePath])] -> FilesDB)
-> IO [(ArchLinuxName, [FilePath])] -> IO FilesDB
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConduitT () Void (ResourceT IO) [(ArchLinuxName, [FilePath])]
-> IO [(ArchLinuxName, [FilePath])]
forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes (DBKind -> FilePath -> ConduitT () Result (ResourceT IO) ()
forall (m :: * -> *) i.
(MonadResource m, PrimMonad m, MonadThrow m) =>
DBKind -> FilePath -> ConduitT i Result m ()
loadFilesDBC DBKind
db FilePath
dir ConduitT () Result (ResourceT IO) ()
-> ConduitM
Result Void (ResourceT IO) [(ArchLinuxName, [FilePath])]
-> ConduitT () Void (ResourceT IO) [(ArchLinuxName, [FilePath])]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitT Result (ArchLinuxName, [FilePath]) (ResourceT IO) ()
forall (m :: * -> *).
Monad m =>
ConduitT Result (ArchLinuxName, [FilePath]) m ()
mergeResult ConduitT Result (ArchLinuxName, [FilePath]) (ResourceT IO) ()
-> ConduitM
(ArchLinuxName, [FilePath])
Void
(ResourceT IO)
[(ArchLinuxName, [FilePath])]
-> ConduitM
Result Void (ResourceT IO) [(ArchLinuxName, [FilePath])]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM
(ArchLinuxName, [FilePath])
Void
(ResourceT IO)
[(ArchLinuxName, [FilePath])]
forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
sinkList)
lookupPkg :: File -> FilesDB -> [ArchLinuxName]
lookupPkg :: FilePath -> FilesDB -> [ArchLinuxName]
lookupPkg FilePath
file = (ArchLinuxName -> [FilePath] -> [ArchLinuxName] -> [ArchLinuxName])
-> [ArchLinuxName] -> FilesDB -> [ArchLinuxName]
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey (\ArchLinuxName
k [FilePath]
v [ArchLinuxName]
acc -> if FilePath
file FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath]
v then ArchLinuxName
k ArchLinuxName -> [ArchLinuxName] -> [ArchLinuxName]
forall a. a -> [a] -> [a]
: [ArchLinuxName]
acc else [ArchLinuxName]
acc) []
data Result = Files FilePath [File] | Desc FilePath ArchLinuxName
deriving stock (Int -> Result -> FilePath -> FilePath
[Result] -> FilePath -> FilePath
Result -> FilePath
(Int -> Result -> FilePath -> FilePath)
-> (Result -> FilePath)
-> ([Result] -> FilePath -> FilePath)
-> Show Result
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [Result] -> FilePath -> FilePath
$cshowList :: [Result] -> FilePath -> FilePath
show :: Result -> FilePath
$cshow :: Result -> FilePath
showsPrec :: Int -> Result -> FilePath -> FilePath
$cshowsPrec :: Int -> Result -> FilePath -> FilePath
Show)
data DBKind = Core | |
instance Show DBKind where
show :: DBKind -> FilePath
show DBKind
Core = FilePath
"core"
show DBKind
Community = FilePath
"community"
show DBKind
Extra = FilePath
"extra"
type File = String
type FilesDB = Map.Map ArchLinuxName [File]