{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
module Distribution.ArchHs.Community
( defaultCommunityPath,
loadProcessedCommunity,
isInCommunity,
versionInCommunity,
)
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
defaultCommunityPath :: FilePath
= 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 ()
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
extractVer (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")]
Left ParseErrorBundle FilePath Void
_ -> []
extractVer :: FilePath -> FilePath
extractVer FilePath
ver = [FilePath] -> FilePath
forall a. [a] -> a
head ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$
FilePath -> FilePath -> [FilePath]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn FilePath
"-" (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall a b. (a -> b) -> a -> b
$ case FilePath -> FilePath -> [FilePath]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn FilePath
":" FilePath
ver of
(FilePath
_ : FilePath
v : []) -> FilePath
v
FilePath
v : [] -> FilePath
v
[FilePath]
_ -> FilePath -> FilePath
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"err"
[(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
loadProcessedCommunity :: (MonadUnliftIO m, PrimMonad m, MonadThrow m) => FilePath -> m CommunityDB
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 (ConduitT () Void (ResourceT m) [(CommunityName, FilePath)]
-> m [(CommunityName, FilePath)])
-> ConduitT () Void (ResourceT m) [(CommunityName, FilePath)]
-> m [(CommunityName, FilePath)]
forall a b. (a -> b) -> a -> b
$ 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)
isInCommunity :: (HasMyName n, Member CommunityEnv r) => n -> Sem r Bool
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
versionInCommunity :: (HasMyName n, Members [CommunityEnv, WithMyErr] r) => n -> Sem r CommunityVersion
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