{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}

-- | Copyright: (c) 2020-2021 berberman
-- SPDX-License-Identifier: MIT
-- Maintainer: berberman <berberman@yandex.com>
-- Stability: experimental
-- Portability: portable
-- This module provides functions operating with @community.db@ of pacman.
module Distribution.ArchHs.CommunityDB
  ( defaultCommunityDBPath,
    loadCommunityDB,
    isInCommunity,
    versionInCommunity,
#ifdef ALPM
    loadCommunityDBFFI,
#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 Distribution.ArchHs.Utils

-----------------------------------------------------------------------------

#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 (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_community"
  query_community :: FunPtr (CString -> CString -> IO ()) -> IO ()

callback :: IORef (Seq.Seq (ArchLinuxName, ArchLinuxVersion)) -> CString -> CString -> IO ()
callback ref x y = do
  x' <- peekCString x
  y' <- peekCString y
  modifyIORef' ref (Seq.|> (ArchLinuxName x', extractFromEVR y'))

-- | The same purpose as 'loadCommunity' but use alpm to query community db instead.
loadCommunityDBFFI :: IO CommunityDB
loadCommunityDBFFI = do
  ref <- newIORef Seq.empty
  callbackW <- wrap $ callback ref
  query_community callbackW
  freeHaskellFunPtr callbackW
  Map.fromList . toList <$> readIORef ref
#endif

-----------------------------------------------------------------------------

-- | Default path to @community.db@.
defaultCommunityDBPath :: FilePath
defaultCommunityDBPath :: FilePath
defaultCommunityDBPath = 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
"community.db"

loadCommunityDBC ::
  (MonadResource m, PrimMonad m, MonadThrow m) =>
  FilePath ->
  ConduitT i (ArchLinuxName, ArchLinuxVersion) m ()
loadCommunityDBC :: FilePath -> ConduitT i (ArchLinuxName, FilePath) m ()
loadCommunityDBC FilePath
path = do
  FilePath -> ConduitT i ByteString m ()
forall (m :: * -> *) i.
MonadResource m =>
FilePath -> ConduitT i ByteString m ()
sourceFileBS FilePath
path ConduitT i ByteString m ()
-> ConduitM ByteString (ArchLinuxName, FilePath) m ()
-> ConduitT i (ArchLinuxName, FilePath) 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 (ArchLinuxName, FilePath) m ()
-> ConduitM ByteString (ArchLinuxName, FilePath) 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 (ArchLinuxName, FilePath) m ()
-> ConduitM ByteString (ArchLinuxName, FilePath) 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 (ArchLinuxName, FilePath) m ())
-> ConduitM TarChunk (ArchLinuxName, FilePath) m ()
forall (m :: * -> *) o.
MonadThrow m =>
(Header -> ConduitM ByteString o m ()) -> ConduitM TarChunk o m ()
Tar.withEntries Header -> ConduitM ByteString (ArchLinuxName, FilePath) m ()
forall (m :: * -> *).
Monad m =>
Header -> ConduitT ByteString (ArchLinuxName, FilePath) m ()
action
  where
    action :: Header -> ConduitT ByteString (ArchLinuxName, FilePath) m ()
action Header
header =
      Bool
-> ConduitT ByteString (ArchLinuxName, FilePath) m ()
-> ConduitT ByteString (ArchLinuxName, FilePath) m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Header -> FileType
Tar.headerFileType Header
header FileType -> FileType -> Bool
forall a. Eq a => a -> a -> Bool
== FileType
Tar.FTNormal) (ConduitT ByteString (ArchLinuxName, FilePath) m ()
 -> ConduitT ByteString (ArchLinuxName, FilePath) m ())
-> ConduitT ByteString (ArchLinuxName, FilePath) m ()
-> ConduitT ByteString (ArchLinuxName, FilePath) m ()
forall a b. (a -> b) -> a -> b
$ do
        ByteString
x <- [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat ([ByteString] -> ByteString)
-> ConduitT ByteString (ArchLinuxName, FilePath) m [ByteString]
-> ConduitT ByteString (ArchLinuxName, FilePath) m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConduitT ByteString (ArchLinuxName, FilePath) m [ByteString]
forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
sinkList
        let txt :: FilePath
txt = Text -> FilePath
T.unpack (Text -> FilePath)
-> (ByteString -> Text) -> ByteString -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 (ByteString -> FilePath) -> ByteString -> FilePath
forall a b. (a -> b) -> a -> b
$ ByteString
x
            provided :: Map k a -> a
provided Map k a
r = Map k a
r Map k a -> k -> a
forall k a. Ord k => Map k a -> k -> a
Map.! k
"PROVIDES"
            parseProvidedTerm :: FilePath -> (FilePath, FilePath)
parseProvidedTerm FilePath
t = let s :: [FilePath]
s = FilePath -> FilePath -> [FilePath]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn FilePath
"=" FilePath
t in ([FilePath]
s [FilePath] -> Getting FilePath [FilePath] FilePath -> FilePath
forall s a. s -> Getting a s a -> a
^. Index [FilePath] -> Traversal' [FilePath] (IxValue [FilePath])
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index [FilePath]
0, [FilePath]
s [FilePath] -> Getting FilePath [FilePath] FilePath -> FilePath
forall s a. s -> Getting a s a -> a
^. Index [FilePath] -> Traversal' [FilePath] (IxValue [FilePath])
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index [FilePath]
1)
            result :: [(FilePath, FilePath)]
result = case FilePath
-> FilePath
-> Either
     (ParseErrorBundle FilePath Void) (Map FilePath [FilePath])
runDescFieldsParser (Header -> FilePath
Tar.headerFilePath Header
header) FilePath
txt of
                    Right Map FilePath [FilePath]
r -> case [FilePath] -> FilePath
forall a. [a] -> a
head ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ Map FilePath [FilePath]
r Map FilePath [FilePath] -> FilePath -> [FilePath]
forall k a. Ord k => Map k a -> k -> a
Map.! FilePath
"NAME" of
                      FilePath
"ghc" -> FilePath -> (FilePath, FilePath)
parseProvidedTerm (FilePath -> (FilePath, FilePath))
-> [FilePath] -> [(FilePath, FilePath)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map FilePath [FilePath] -> [FilePath]
forall k a. (Ord k, IsString k) => Map k a -> a
provided Map FilePath [FilePath]
r
                      FilePath
"ghc-libs" -> FilePath -> (FilePath, FilePath)
parseProvidedTerm (FilePath -> (FilePath, FilePath))
-> [FilePath] -> [(FilePath, FilePath)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map FilePath [FilePath] -> [FilePath]
forall k a. (Ord k, IsString k) => Map k a -> a
provided Map FilePath [FilePath]
r
                      FilePath
_ -> [([FilePath] -> FilePath
forall a. [a] -> a
head ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ Map FilePath [FilePath]
r Map FilePath [FilePath] -> FilePath -> [FilePath]
forall k a. Ord k => Map k a -> k -> a
Map.! FilePath
"NAME", FilePath -> FilePath
extractFromEVR (FilePath -> FilePath)
-> ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> FilePath
forall a. [a] -> a
head ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ Map FilePath [FilePath]
r Map FilePath [FilePath] -> FilePath -> [FilePath]
forall k a. Ord k => Map k a -> k -> a
Map.! FilePath
"VERSION")]
                    -- Drop it if failed to parse
                    Left ParseErrorBundle FilePath Void
_ -> []

        [(ArchLinuxName, FilePath)]
-> ConduitT ByteString (Element [(ArchLinuxName, FilePath)]) m ()
forall (m :: * -> *) mono i.
(Monad m, MonoFoldable mono) =>
mono -> ConduitT i (Element mono) m ()
yieldMany ([(ArchLinuxName, FilePath)]
 -> ConduitT ByteString (Element [(ArchLinuxName, FilePath)]) m ())
-> [(ArchLinuxName, FilePath)]
-> ConduitT ByteString (Element [(ArchLinuxName, FilePath)]) m ()
forall a b. (a -> b) -> a -> b
$ [(FilePath, FilePath)]
result [(FilePath, FilePath)]
-> ([(FilePath, FilePath)] -> [(ArchLinuxName, FilePath)])
-> [(ArchLinuxName, FilePath)]
forall a b. a -> (a -> b) -> b
& ((FilePath, FilePath) -> Identity (ArchLinuxName, FilePath))
-> [(FilePath, FilePath)] -> Identity [(ArchLinuxName, FilePath)]
forall s t a b. Each s t a b => Traversal s t a b
each (((FilePath, FilePath) -> Identity (ArchLinuxName, FilePath))
 -> [(FilePath, FilePath)] -> Identity [(ArchLinuxName, FilePath)])
-> ((FilePath -> Identity ArchLinuxName)
    -> (FilePath, FilePath) -> Identity (ArchLinuxName, FilePath))
-> (FilePath -> Identity ArchLinuxName)
-> [(FilePath, FilePath)]
-> Identity [(ArchLinuxName, FilePath)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> Identity ArchLinuxName)
-> (FilePath, FilePath) -> Identity (ArchLinuxName, FilePath)
forall s t a b. Field1 s t a b => Lens s t a b
_1 ((FilePath -> Identity ArchLinuxName)
 -> [(FilePath, FilePath)] -> Identity [(ArchLinuxName, FilePath)])
-> (FilePath -> ArchLinuxName)
-> [(FilePath, FilePath)]
-> [(ArchLinuxName, FilePath)]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ FilePath -> ArchLinuxName
ArchLinuxName

-- | Load @community.db@ from @path@.
-- @desc@ files in the db will be parsed by @descParser@.
loadCommunityDB :: FilePath -> IO CommunityDB
loadCommunityDB :: FilePath -> IO CommunityDB
loadCommunityDB FilePath
path = [(ArchLinuxName, FilePath)] -> CommunityDB
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ArchLinuxName, FilePath)] -> CommunityDB)
-> IO [(ArchLinuxName, FilePath)] -> IO CommunityDB
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 (FilePath -> ConduitT () (ArchLinuxName, FilePath) (ResourceT IO) ()
forall (m :: * -> *) i.
(MonadResource m, PrimMonad m, MonadThrow m) =>
FilePath -> ConduitT i (ArchLinuxName, FilePath) m ()
loadCommunityDBC FilePath
path ConduitT () (ArchLinuxName, FilePath) (ResourceT IO) ()
-> ConduitM
     (ArchLinuxName, FilePath)
     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
.| ConduitM
  (ArchLinuxName, FilePath)
  Void
  (ResourceT IO)
  [(ArchLinuxName, FilePath)]
forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
sinkList)

-----------------------------------------------------------------------------

-- | Check if a package exists in archlinux community repo.
-- See 'HasMyName'.
isInCommunity :: (HasMyName n, Member CommunityEnv r) => n -> Sem r Bool
isInCommunity :: n -> Sem r Bool
isInCommunity n
name = forall (r :: EffectRow).
Member (Reader CommunityDB) r =>
Sem r CommunityDB
forall i (r :: EffectRow). Member (Reader i) r => Sem r i
ask @CommunityDB Sem r CommunityDB -> (CommunityDB -> Sem r Bool) -> Sem r Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \CommunityDB
db -> Bool -> Sem r Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Sem r Bool) -> Bool -> Sem r Bool
forall a b. (a -> b) -> a -> b
$ n -> ArchLinuxName
forall n. HasMyName n => n -> ArchLinuxName
toArchLinuxName n
name ArchLinuxName -> CommunityDB -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` CommunityDB
db

-- | Get the version of a package in archlinux community repo.
-- If the package does not exist, 'PkgNotFound' will be thrown.
versionInCommunity :: (HasMyName n, Members [CommunityEnv, WithMyErr] r) => n -> Sem r ArchLinuxVersion
versionInCommunity :: n -> Sem r FilePath
versionInCommunity n
name =
  forall (r :: EffectRow).
Member (Reader CommunityDB) r =>
Sem r CommunityDB
forall i (r :: EffectRow). Member (Reader i) r => Sem r i
ask @CommunityDB Sem r CommunityDB
-> (CommunityDB -> Sem r FilePath) -> Sem r FilePath
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \CommunityDB
db -> case CommunityDB
db CommunityDB -> ArchLinuxName -> Maybe FilePath
forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? n -> ArchLinuxName
forall n. HasMyName n => n -> ArchLinuxName
toArchLinuxName n
name of
    Just FilePath
x -> FilePath -> Sem r FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
x
    Maybe FilePath
_ -> MyException -> Sem r FilePath
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (MyException -> Sem r FilePath) -> MyException -> Sem r FilePath
forall a b. (a -> b) -> a -> b
$ n -> MyException
forall n. HasMyName n => n -> MyException
PkgNotFound n
name