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

-- | Copyright: (c) 2020 berberman
-- SPDX-License-Identifier: MIT
-- Maintainer: berberman <1793913507@qq.com>
-- Stability: experimental
-- Portability: portable
-- This module provides functions operating with @community.db@ of pacman.
module Distribution.ArchHs.Community
  ( defaultCommunityPath,
    loadProcessedCommunity,
    isInCommunity,
    versionInCommunity,
    compiledWithAlpm,
#ifdef ALPM
    loadCommunityFFI,
#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.C.Types (CInt(..))
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 CInt

foreign import ccall "alpm.h alpm_strerror"
  alpm_strerror :: CInt -> IO CString

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

-- | The same purpose as 'loadCommunity' but use alpm to query community db instead.
loadCommunityFFI :: IO CommunityDB
loadCommunityFFI = do
  ref <- newIORef Seq.empty
  callbackW <- wrap $ callback ref
  errno <- query_community callbackW
  freeHaskellFunPtr callbackW
  when (errno /= 0) $ do
    msg <- peekCString =<< alpm_strerror errno
    -- TODO: why? :(
    putStrLn $ "warn: unexpected return code from libalpm: " <> show errno <> " (" <> msg <> ")"
  Map.fromList . toList <$> readIORef ref
#endif

-- | Whether this program enables alpm support.
compiledWithAlpm :: Bool
compiledWithAlpm :: Bool
compiledWithAlpm =
#ifdef ALPM
  True
#else
  Bool
False
#endif

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

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

loadCommunity ::
  (MonadResource m, PrimMonad m, MonadThrow m) =>
  FilePath ->
  ConduitT i (CommunityName, CommunityVersion) m ()
loadCommunity :: FilePath -> ConduitT i (CommunityName, FilePath) m ()
loadCommunity 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 (CommunityName, FilePath) m ()
-> ConduitT i (CommunityName, 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 (CommunityName, FilePath) m ()
-> ConduitM ByteString (CommunityName, 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 (CommunityName, FilePath) m ()
-> ConduitM ByteString (CommunityName, 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 (CommunityName, FilePath) m ())
-> ConduitM TarChunk (CommunityName, FilePath) m ()
forall (m :: * -> *) o.
MonadThrow m =>
(Header -> ConduitM ByteString o m ()) -> ConduitM TarChunk o m ()
Tar.withEntries Header -> ConduitM ByteString (CommunityName, FilePath) m ()
forall (m :: * -> *).
Monad m =>
Header -> ConduitT ByteString (CommunityName, FilePath) m ()
action
  where
    action :: Header -> ConduitT ByteString (CommunityName, FilePath) m ()
action Header
header =
      Bool
-> ConduitT ByteString (CommunityName, FilePath) m ()
-> ConduitT ByteString (CommunityName, 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 (CommunityName, FilePath) m ()
 -> ConduitT ByteString (CommunityName, FilePath) m ())
-> ConduitT ByteString (CommunityName, FilePath) m ()
-> ConduitT ByteString (CommunityName, 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 (CommunityName, FilePath) m [ByteString]
-> ConduitT ByteString (CommunityName, FilePath) m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConduitT ByteString (CommunityName, 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
            result :: [(FilePath, FilePath)]
result =
              let 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)
               in 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
_ -> []

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

-- | Load @community.db@ from @path@.
-- @desc@ files in the db will be parsed by @descParser@.
loadProcessedCommunity :: (MonadUnliftIO m, PrimMonad m, MonadThrow m) => FilePath -> m CommunityDB
loadProcessedCommunity :: FilePath -> m CommunityDB
loadProcessedCommunity FilePath
path = [(CommunityName, FilePath)] -> CommunityDB
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(CommunityName, FilePath)] -> CommunityDB)
-> m [(CommunityName, FilePath)] -> m CommunityDB
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConduitT () Void (ResourceT m) [(CommunityName, FilePath)]
-> m [(CommunityName, FilePath)]
forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes (FilePath -> ConduitT () (CommunityName, FilePath) (ResourceT m) ()
forall (m :: * -> *) i.
(MonadResource m, PrimMonad m, MonadThrow m) =>
FilePath -> ConduitT i (CommunityName, FilePath) m ()
loadCommunity FilePath
path ConduitT () (CommunityName, FilePath) (ResourceT m) ()
-> ConduitM
     (CommunityName, FilePath)
     Void
     (ResourceT m)
     [(CommunityName, FilePath)]
-> ConduitT () Void (ResourceT m) [(CommunityName, FilePath)]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM
  (CommunityName, FilePath)
  Void
  (ResourceT m)
  [(CommunityName, 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 :: [Effect]).
MemberWithError (Reader CommunityDB) r =>
Sem r CommunityDB
forall i (r :: [Effect]). MemberWithError (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 -> CommunityName
forall n. HasMyName n => n -> CommunityName
toCommunityName n
name CommunityName -> 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 CommunityVersion
versionInCommunity :: n -> Sem r FilePath
versionInCommunity n
name =
  forall (r :: [Effect]).
MemberWithError (Reader CommunityDB) r =>
Sem r CommunityDB
forall i (r :: [Effect]). MemberWithError (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 -> CommunityName -> Maybe FilePath
forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? n -> CommunityName
forall n. HasMyName n => n -> CommunityName
toCommunityName 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 :: [Effect]) a.
MemberWithError (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