{-# 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 :: File
defaultFilesDBDir = File
"/" File -> File -> File
</> File
"var" File -> File -> File
</> File
"lib" File -> File -> File
</> File
"pacman" File -> File -> File
</> File
"sync"

loadFilesDBC ::
  (MonadResource m, PrimMonad m, MonadThrow m) =>
  DBKind ->
  FilePath ->
  ConduitT i Result m ()
loadFilesDBC :: forall (m :: * -> *) i.
(MonadResource m, PrimMonad m, MonadThrow m) =>
DBKind -> File -> ConduitT i Result m ()
loadFilesDBC DBKind
db File
dir = do
  forall (m :: * -> *) i.
MonadResource m =>
File -> ConduitT i ByteString m ()
sourceFileBS (File
dir File -> File -> File
</> forall a. Show a => a -> File
show DBKind
db forall a. Semigroup a => a -> a -> a
<> File
".files") 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 Result m ()
action
  where
    action :: Header -> ConduitT ByteString Result m ()
action Header
header
      | FileType
Tar.FTNormal <- Header -> FileType
Tar.headerFileType Header
header,
        [File
fp, File
t] <- forall a. Eq a => [a] -> [a] -> [[a]]
splitOn File
"/" forall a b. (a -> b) -> a -> b
$ Header -> File
Tar.headerFilePath Header
header =
        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 :: Text
txt = ByteString -> Text
decodeUtf8 ByteString
x
          case File
t of
            File
"files" -> forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield forall b c a. (b -> c) -> (a -> b) -> a -> c
. File -> [File] -> Result
Files File
fp forall a b. (a -> b) -> a -> b
$ [Text -> File
T.unpack Text
fname | (Text -> Maybe Text
extract -> Just Text
fname) <- forall a. [a] -> [a]
tail forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.lines Text
txt]
            File
"desc" -> case File
-> File -> Either (ParseErrorBundle File Void) (Map File [File])
runDescFieldsParser File
fp (Text -> File
T.unpack Text
txt) of
              Right Map File [File]
r | [File
name] <- Map File [File]
r forall k a. Ord k => Map k a -> k -> a
Map.! File
"NAME" -> forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield forall b c a. (b -> c) -> (a -> b) -> a -> c
. File -> ArchLinuxName -> Result
Desc File
fp forall a b. (a -> b) -> a -> b
$ File -> ArchLinuxName
ArchLinuxName File
name
              Either (ParseErrorBundle File Void) (Map File [File])
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            File
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
      | Bool
otherwise = 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 =
        forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.takeWhileEnd (forall a. Eq a => a -> a -> Bool
/= Char
'/') Text
x
      | Bool
otherwise = forall a. Maybe a
Nothing

mergeResult :: Monad m => ConduitT Result (ArchLinuxName, [File]) m ()
mergeResult :: forall (m :: * -> *).
Monad m =>
ConduitT Result (ArchLinuxName, [File]) m ()
mergeResult = do
  Maybe Result
rName <- forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await
  Maybe Result
rFiles <- forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await
  case () of
    ()
      | Just (Desc File
fpd ArchLinuxName
name) <- Maybe Result
rName,
        Just (Files File
fpf [File]
files) <- Maybe Result
rFiles,
        File
fpd forall a. Eq a => a -> a -> Bool
== File
fpf ->
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([File]
files forall a. Eq a => a -> a -> Bool
/= []) (forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (ArchLinuxName
name, [File]
files)) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *).
Monad m =>
ConduitT Result (ArchLinuxName, [File]) m ()
mergeResult
    ()
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Load a @db@ from @dir@
loadFilesDB :: DBKind -> FilePath -> IO FilesDB
loadFilesDB :: DBKind -> File -> IO FilesDB
loadFilesDB DBKind
db File
dir = 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) =>
DBKind -> File -> ConduitT i Result m ()
loadFilesDBC DBKind
db File
dir 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 =>
ConduitT Result (ArchLinuxName, [File]) m ()
mergeResult 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)

-- | 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 :: File -> FilesDB -> [ArchLinuxName]
lookupPkg File
file = forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey (\ArchLinuxName
k [File]
v [ArchLinuxName]
acc -> if File
file forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [File]
v then ArchLinuxName
k forall a. a -> [a] -> [a]
: [ArchLinuxName]
acc else [ArchLinuxName]
acc) []

data Result = Files FilePath [File] | Desc FilePath ArchLinuxName
  deriving stock (Int -> Result -> File -> File
[Result] -> File -> File
Result -> File
forall a.
(Int -> a -> File -> File)
-> (a -> File) -> ([a] -> File -> File) -> Show a
showList :: [Result] -> File -> File
$cshowList :: [Result] -> File -> File
show :: Result -> File
$cshow :: Result -> File
showsPrec :: Int -> Result -> File -> File
$cshowsPrec :: Int -> Result -> File -> File
Show)

-- | Two files repos: @core@ and @extra@
data DBKind = Core | Extra

instance Show DBKind where
  show :: DBKind -> File
show DBKind
Core = File
"core"
  show DBKind
Extra = File
"extra"

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

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