{-# 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 @extra.db@ of pacman.
module Distribution.ArchHs.ExtraDB
  ( defaultExtraDBPath,
    loadExtraDB,
    isInExtra,
    versionInExtra,
    getPkgDesc,
#ifdef ALPM
    loadExtraDBFFI,
#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 Data.Maybe (mapMaybe)

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

#ifdef ALPM
{-# LANGUAGE ForeignFunctionInterface #-}

import Data.IORef (IORef, modifyIORef', newIORef, readIORef)
import Distribution.ArchHs.Utils (extractFromEVR)
import Foreign.C.String (CString, peekCString)
import Foreign.Ptr (FunPtr, freeHaskellFunPtr)

foreign import ccall "wrapper"
  wrap :: (CString -> CString -> CString -> CString -> IO ()) -> IO (FunPtr (CString -> CString -> CString -> CString -> IO ()))

foreign import ccall "clib.h query_extra"
  query_extra :: FunPtr (CString -> CString -> CString -> CString -> IO ()) -> FunPtr (CString -> CString -> CString -> CString -> IO ()) -> IO ()

type RawPkgSet = IORef (Map.Map ArchLinuxName ((ArchLinuxVersion, String, String), IORef (Map.Map String [(ArchLinuxName, Maybe ArchLinuxVersion)])))

pkgCallback :: RawPkgSet -> CString -> CString -> CString -> CString -> IO ()
pkgCallback ref name version desc url = do
  name' <- peekCString name
  version' <- peekCString version
  desc' <- peekCString desc
  url' <- peekCString url
  m <- newIORef Map.empty
  modifyIORef' ref (Map.insert (ArchLinuxName name') ((extractFromEVR version', desc', url'), m))

listCallback :: RawPkgSet -> CString -> CString -> CString -> CString -> IO ()
listCallback ref name key dm dv = do
  name' <- peekCString name
  key' <- peekCString key
  dm' <- peekCString dm
  dv' <- peekCString dv
  s <- snd . (\r -> r Map.! ArchLinuxName name') <$> readIORef ref
  modifyIORef' s (Map.insertWith (++) key' [(ArchLinuxName dm', if null dv' then Nothing else Just (extractFromEVR dv'))])

-- | The same purpose as 'loadExtra' but use alpm to query extra db instead.
loadExtraDBFFI :: IO ExtraDB
loadExtraDBFFI = do
  ref <- newIORef Map.empty
  pkgCallbackW <- wrap $ pkgCallback ref
  listCallbackW <- wrap $ listCallback ref
  query_extra pkgCallbackW listCallbackW
  freeHaskellFunPtr pkgCallbackW
  freeHaskellFunPtr listCallbackW
  s <- readIORef ref
  re <-
    mapM
      ( \(name, ((ver, desc, url), r)) -> do
          l <- readIORef r
          let f (Just xs) = uncurry PkgDependent <$> xs
              f Nothing = []
          pure
            ( name,
              PkgDesc
                { _name = name,
                  _version = ver,
                  _desc = desc,
                  _url = if null url then Nothing else Just url,
                  _depends = f $ l Map.!? "depends",
                  _provides = f $ l Map.!? "provides",
                  _conflicts = f $ l Map.!? "conflicts",
                  _optDepends = f $ l Map.!? "optdepends",
                  _makeDepends = f $ l Map.!? "makedepends",
                  _checkDepends = f $ l Map.!? "checkdepends",
                  _replaces = f $ l Map.!? "replaces"
                }
            )
      )
      $ Map.toList s
  pure $ Map.fromList re
#endif
-----------------------------------------------------------------------------

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

loadExtraDBC ::
  (MonadResource m, PrimMonad m, MonadThrow m) =>
  FilePath ->
  ConduitT i (ArchLinuxName, PkgDesc) m ()
loadExtraDBC :: forall (m :: * -> *) i.
(MonadResource m, PrimMonad m, MonadThrow m) =>
FilePath -> ConduitT i (ArchLinuxName, PkgDesc) m ()
loadExtraDBC FilePath
path = do
  forall (m :: * -> *) i.
MonadResource m =>
FilePath -> ConduitT i ByteString m ()
sourceFileBS FilePath
path 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 (ArchLinuxName, PkgDesc) m ()
action
  where
    action :: Header -> ConduitT ByteString (ArchLinuxName, PkgDesc) m ()
action Header
header =
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Header -> FileType
Tar.headerFileType Header
header forall a. Eq a => a -> a -> Bool
== FileType
Tar.FTNormal) forall a b. (a -> b) -> a -> b
$ 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 :: FilePath
txt = Text -> FilePath
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 forall a b. (a -> b) -> a -> b
$ ByteString
x
            parsed :: Either (ParseErrorBundle FilePath Void) PkgDesc
parsed = FilePath
-> FilePath -> Either (ParseErrorBundle FilePath Void) PkgDesc
runDescParser (Header -> FilePath
Tar.headerFilePath Header
header) FilePath
txt
            result :: [PkgDesc]
result = case Either (ParseErrorBundle FilePath Void) PkgDesc
parsed of
              Right PkgDesc
desc ->
                PkgDesc
desc
                  forall a. a -> [a] -> [a]
: ( if PkgDesc -> ArchLinuxName
_name PkgDesc
desc forall a. Eq a => a -> a -> Bool
== FilePath -> ArchLinuxName
ArchLinuxName FilePath
"ghc"
                        Bool -> Bool -> Bool
|| PkgDesc -> ArchLinuxName
_name PkgDesc
desc forall a. Eq a => a -> a -> Bool
== FilePath -> ArchLinuxName
ArchLinuxName FilePath
"ghc-libs"
                        then forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe PkgDependent -> Maybe PkgDesc
promoteDependent (PkgDesc -> PkgDependentList
_provides PkgDesc
desc)
                        else []
                    )
              -- Drop it if failed to parse
              Left ParseErrorBundle FilePath Void
_ -> []
        forall (m :: * -> *) mono i.
(Monad m, MonoFoldable mono) =>
mono -> ConduitT i (Element mono) m ()
yieldMany forall a b. (a -> b) -> a -> b
$ (\PkgDesc
desc -> (PkgDesc -> ArchLinuxName
_name PkgDesc
desc, PkgDesc
desc)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PkgDesc]
result

-- | Load @extra.db@ from @path@.
-- @desc@ files in the db will be parsed by @descParser@.
loadExtraDB :: FilePath -> IO ExtraDB
loadExtraDB :: FilePath -> IO ExtraDB
loadExtraDB FilePath
path = 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) =>
FilePath -> ConduitT i (ArchLinuxName, PkgDesc) m ()
loadExtraDBC FilePath
path 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)

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

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

-- | Get the version of a package in archlinux extra repo.
-- If the package does not exist, 'PkgNotFound' will be thrown.
versionInExtra :: (HasMyName n, Members [ExtraEnv, WithMyErr] r) => n -> Sem r ArchLinuxVersion
versionInExtra :: forall n (r :: EffectRow).
(HasMyName n, Members '[ExtraEnv, WithMyErr] r) =>
n -> Sem r FilePath
versionInExtra n
name = PkgDesc -> FilePath
_version forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall n (r :: EffectRow).
(HasMyName n, Members '[ExtraEnv, WithMyErr] r) =>
n -> Sem r PkgDesc
getPkgDesc n
name

-- | Get the pkgdesc a package in archlinux extra repo.
-- If the package does not exist, 'PkgNotFound' will be thrown.
getPkgDesc :: (HasMyName n, Members [ExtraEnv, WithMyErr] r) => n -> Sem r PkgDesc
getPkgDesc :: forall n (r :: EffectRow).
(HasMyName n, Members '[ExtraEnv, WithMyErr] r) =>
n -> Sem r PkgDesc
getPkgDesc n
name =
  forall i (r :: EffectRow). Member (Reader i) r => Sem r i
ask @ExtraDB forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ExtraDB
db -> case ExtraDB
db forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? forall n. HasMyName n => n -> ArchLinuxName
toArchLinuxName n
name of
    Just PkgDesc
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure PkgDesc
x
    Maybe PkgDesc
_ -> forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw forall a b. (a -> b) -> a -> b
$ forall n. HasMyName n => n -> MyException
PkgNotFound n
name