{-# LANGUAGE CPP #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
-- | Copyright: (c) 2020-2021 berberman
-- SPDX-License-Identifier: MIT
-- Maintainer: berberman <berberman@yandex.com>
-- Stability: experimental
-- Portability: portable
-- This module provides functions operating with 'FilesDB' of pacman.
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'))

-- | The same purpose as 'loadFilesDB' but use alpm to query files db instead.
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

-- | Default directory containing files dbs (@/var/lib/pacman/sync@).
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 ()

-- | Load a @db@ from @dir@
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)

-- | Lookup which Arch Linux package contains this @file@ from given files db.
-- This query is bad in performance, since it traverses the entire db. 
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)

-- | Three files repos: @core@, @community@, and @extra@
data DBKind = Core | Community | Extra

instance Show DBKind where
  show :: DBKind -> FilePath
show DBKind
Core = FilePath
"core"
  show DBKind
Community = FilePath
"community"
  show DBKind
Extra = FilePath
"extra"

-- | A file's name
type File = String

-- | Representation of @repo.db@.
type FilesDB = Map.Map ArchLinuxName [File]