{-# 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 'HackageDB' and 'GenericPackageDescription'.
module Distribution.ArchHs.Hackage
  ( lookupHackagePath,
    loadHackageDB,
    insertDB,
    parseCabalFile,
    getLatestCabal,
    getCabal,
    getPackageFlag,
    traverseHackage,
    getLatestSHA256,
    HackageDB,
  )
where

import qualified Data.ByteString as BS
import qualified Data.Map as Map
import Data.Maybe (fromJust)
import Distribution.ArchHs.Exception
import Distribution.ArchHs.Internal.Prelude
import Distribution.ArchHs.Types
import Distribution.ArchHs.Utils (getPkgName, getPkgVersion)
import Distribution.Hackage.DB (HackageDB, VersionData (VersionData, cabalFile), readTarball, tarballHashes)
import Distribution.PackageDescription.Parsec (parseGenericPackageDescriptionMaybe)
import System.Directory (findFile, getHomeDirectory, listDirectory)

-- | Look up hackage tarball path from @~/.cabal@.
-- Arbitrary hackage mirror is potential to be selected.
-- Preferred to @01-index.tar@, whereas fallback to @00-index.tar@.
lookupHackagePath :: IO FilePath
lookupHackagePath :: IO FilePath
lookupHackagePath = do
  FilePath
home <- (\FilePath
d -> FilePath
d FilePath -> FilePath -> FilePath
</> FilePath
".cabal" FilePath -> FilePath -> FilePath
</> FilePath
"packages") (FilePath -> FilePath) -> IO FilePath -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO FilePath
getHomeDirectory
  [FilePath]
subs <- (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath
home FilePath -> FilePath -> FilePath
</>) ([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO [FilePath]
listDirectory FilePath
home
  Maybe FilePath
legacy <- [FilePath] -> FilePath -> IO (Maybe FilePath)
findFile [FilePath]
subs FilePath
"00-index.tar"
  Maybe FilePath
new <- [FilePath] -> FilePath -> IO (Maybe FilePath)
findFile [FilePath]
subs FilePath
"01-index.tar"
  case Maybe FilePath
new Maybe FilePath -> Maybe FilePath -> Maybe FilePath
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe FilePath
legacy of
    Just FilePath
x -> FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
x
    Maybe FilePath
Nothing -> FilePath -> IO FilePath
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
"Unable to find hackage index tarball from " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> [FilePath] -> FilePath
forall a. Show a => a -> FilePath
show [FilePath]
subs

-- | Read and parse hackage index tarball.
loadHackageDB :: FilePath -> IO HackageDB
loadHackageDB :: FilePath -> IO HackageDB
loadHackageDB = Maybe UTCTime -> FilePath -> IO HackageDB
readTarball Maybe UTCTime
forall a. Maybe a
Nothing

-- | Insert a 'GenericPackageDescription' into 'HackageDB'.
insertDB :: GenericPackageDescription -> HackageDB -> HackageDB
insertDB :: GenericPackageDescription -> HackageDB -> HackageDB
insertDB GenericPackageDescription
cabal = PackageName -> Map Version VersionData -> HackageDB -> HackageDB
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert PackageName
name Map Version VersionData
packageData
  where
    name :: PackageName
name = PackageDescription -> PackageName
getPkgName (PackageDescription -> PackageName)
-> PackageDescription -> PackageName
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> PackageDescription
packageDescription GenericPackageDescription
cabal
    version :: Version
version = PackageDescription -> Version
getPkgVersion (PackageDescription -> Version) -> PackageDescription -> Version
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> PackageDescription
packageDescription GenericPackageDescription
cabal
    versionData :: VersionData
versionData = GenericPackageDescription -> Map FilePath FilePath -> VersionData
VersionData GenericPackageDescription
cabal Map FilePath FilePath
forall k a. Map k a
Map.empty
    packageData :: Map Version VersionData
packageData = Version -> VersionData -> Map Version VersionData
forall k a. k -> a -> Map k a
Map.singleton Version
version VersionData
versionData

-- | Read and parse @.cabal@ file.
parseCabalFile :: FilePath -> IO GenericPackageDescription
parseCabalFile :: FilePath -> IO GenericPackageDescription
parseCabalFile FilePath
path = do
  ByteString
bs <- FilePath -> IO ByteString
BS.readFile FilePath
path
  case ByteString -> Maybe GenericPackageDescription
parseGenericPackageDescriptionMaybe ByteString
bs of
    Just GenericPackageDescription
x -> GenericPackageDescription -> IO GenericPackageDescription
forall (m :: * -> *) a. Monad m => a -> m a
return GenericPackageDescription
x
    Maybe GenericPackageDescription
_ -> FilePath -> IO GenericPackageDescription
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO GenericPackageDescription)
-> FilePath -> IO GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ FilePath
"Failed to parse .cabal from " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
path

withLatestVersion :: Members [HackageEnv, WithMyErr] r => (VersionData -> a) -> PackageName -> Sem r a
withLatestVersion :: (VersionData -> a) -> PackageName -> Sem r a
withLatestVersion VersionData -> a
f PackageName
name = do
  HackageDB
db <- forall (r :: [Effect]).
MemberWithError (Reader HackageDB) r =>
Sem r HackageDB
forall i (r :: [Effect]). MemberWithError (Reader i) r => Sem r i
ask @HackageDB
  case PackageName -> HackageDB -> Maybe (Map Version VersionData)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name HackageDB
db of
    (Just Map Version VersionData
m) -> case Map Version VersionData -> Maybe (Version, VersionData)
forall k a. Map k a -> Maybe (k, a)
Map.lookupMax Map Version VersionData
m of
      Just (Version
_, VersionData
vdata) -> a -> Sem r a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Sem r a) -> a -> Sem r a
forall a b. (a -> b) -> a -> b
$ VersionData -> a
f VersionData
vdata
      Maybe (Version, VersionData)
Nothing -> MyException -> Sem r a
forall e (r :: [Effect]) a.
MemberWithError (Error e) r =>
e -> Sem r a
throw (MyException -> Sem r a) -> MyException -> Sem r a
forall a b. (a -> b) -> a -> b
$ PackageName -> Version -> MyException
VersionNotFound PackageName
name Version
nullVersion
    Maybe (Map Version VersionData)
Nothing -> MyException -> Sem r a
forall e (r :: [Effect]) a.
MemberWithError (Error e) r =>
e -> Sem r a
throw (MyException -> Sem r a) -> MyException -> Sem r a
forall a b. (a -> b) -> a -> b
$ PackageName -> MyException
forall n. HasMyName n => n -> MyException
PkgNotFound PackageName
name

-- | Get the latest 'GenericPackageDescription'.
getLatestCabal :: Members [HackageEnv, WithMyErr] r => PackageName -> Sem r GenericPackageDescription
getLatestCabal :: PackageName -> Sem r GenericPackageDescription
getLatestCabal = (VersionData -> GenericPackageDescription)
-> PackageName -> Sem r GenericPackageDescription
forall (r :: [Effect]) a.
Members '[Reader HackageDB, WithMyErr] r =>
(VersionData -> a) -> PackageName -> Sem r a
withLatestVersion VersionData -> GenericPackageDescription
cabalFile

-- | Get the latest SHA256 sum of the tarball .
getLatestSHA256 :: Members [HackageEnv, WithMyErr] r => PackageName -> Sem r (Maybe String)
getLatestSHA256 :: PackageName -> Sem r (Maybe FilePath)
getLatestSHA256 = (VersionData -> Maybe FilePath)
-> PackageName -> Sem r (Maybe FilePath)
forall (r :: [Effect]) a.
Members '[Reader HackageDB, WithMyErr] r =>
(VersionData -> a) -> PackageName -> Sem r a
withLatestVersion (\VersionData
vdata -> VersionData -> Map FilePath FilePath
tarballHashes VersionData
vdata Map FilePath FilePath -> FilePath -> Maybe FilePath
forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? FilePath
"sha256")

-- | Get 'GenericPackageDescription' with a specific version.
getCabal :: Members [HackageEnv, WithMyErr] r => PackageName -> Version -> Sem r GenericPackageDescription
getCabal :: PackageName -> Version -> Sem r GenericPackageDescription
getCabal PackageName
name Version
version = do
  HackageDB
db <- forall (r :: [Effect]).
MemberWithError (Reader HackageDB) r =>
Sem r HackageDB
forall i (r :: [Effect]). MemberWithError (Reader i) r => Sem r i
ask @HackageDB
  case PackageName -> HackageDB -> Maybe (Map Version VersionData)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name HackageDB
db of
    (Just Map Version VersionData
m) -> case Version -> Map Version VersionData -> Maybe VersionData
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Version
version Map Version VersionData
m of
      Just VersionData
vdata -> GenericPackageDescription -> Sem r GenericPackageDescription
forall (m :: * -> *) a. Monad m => a -> m a
return (GenericPackageDescription -> Sem r GenericPackageDescription)
-> GenericPackageDescription -> Sem r GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ VersionData
vdata VersionData
-> (VersionData -> GenericPackageDescription)
-> GenericPackageDescription
forall a b. a -> (a -> b) -> b
& VersionData -> GenericPackageDescription
cabalFile
      Maybe VersionData
Nothing -> MyException -> Sem r GenericPackageDescription
forall e (r :: [Effect]) a.
MemberWithError (Error e) r =>
e -> Sem r a
throw (MyException -> Sem r GenericPackageDescription)
-> MyException -> Sem r GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ PackageName -> Version -> MyException
VersionNotFound PackageName
name Version
version
    Maybe (Map Version VersionData)
Nothing -> MyException -> Sem r GenericPackageDescription
forall e (r :: [Effect]) a.
MemberWithError (Error e) r =>
e -> Sem r a
throw (MyException -> Sem r GenericPackageDescription)
-> MyException -> Sem r GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ PackageName -> MyException
forall n. HasMyName n => n -> MyException
PkgNotFound PackageName
name

-- | Get flags of a package.
getPackageFlag :: Members [HackageEnv, WithMyErr] r => PackageName -> Sem r [Flag]
getPackageFlag :: PackageName -> Sem r [Flag]
getPackageFlag PackageName
name = do
  GenericPackageDescription
cabal <- PackageName -> Sem r GenericPackageDescription
forall (r :: [Effect]).
Members '[Reader HackageDB, WithMyErr] r =>
PackageName -> Sem r GenericPackageDescription
getLatestCabal PackageName
name
  [Flag] -> Sem r [Flag]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Flag] -> Sem r [Flag]) -> [Flag] -> Sem r [Flag]
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription
cabal GenericPackageDescription
-> (GenericPackageDescription -> [Flag]) -> [Flag]
forall a b. a -> (a -> b) -> b
& GenericPackageDescription -> [Flag]
genPackageFlags

-- | Traverse hackage packages.
traverseHackage :: (Member HackageEnv r, Applicative f) => ((PackageName, GenericPackageDescription) -> f b) -> Sem r (f [b])
traverseHackage :: ((PackageName, GenericPackageDescription) -> f b) -> Sem r (f [b])
traverseHackage (PackageName, GenericPackageDescription) -> f b
f = do
  HackageDB
db <- forall (r :: [Effect]).
MemberWithError (Reader HackageDB) r =>
Sem r HackageDB
forall i (r :: [Effect]). MemberWithError (Reader i) r => Sem r i
ask @HackageDB
  let x :: [(PackageName, GenericPackageDescription)]
x =
        Map PackageName GenericPackageDescription
-> [(PackageName, GenericPackageDescription)]
forall k a. Map k a -> [(k, a)]
Map.toList
          (Map PackageName GenericPackageDescription
 -> [(PackageName, GenericPackageDescription)])
-> (Map PackageName (Maybe (Version, VersionData))
    -> Map PackageName GenericPackageDescription)
-> Map PackageName (Maybe (Version, VersionData))
-> [(PackageName, GenericPackageDescription)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (Version, VersionData) -> GenericPackageDescription)
-> Map PackageName (Maybe (Version, VersionData))
-> Map PackageName GenericPackageDescription
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (VersionData -> GenericPackageDescription
cabalFile (VersionData -> GenericPackageDescription)
-> (Maybe (Version, VersionData) -> VersionData)
-> Maybe (Version, VersionData)
-> GenericPackageDescription
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Version, VersionData)
-> Getting VersionData (Version, VersionData) VersionData
-> VersionData
forall s a. s -> Getting a s a -> a
^. Getting VersionData (Version, VersionData) VersionData
forall s t a b. Field2 s t a b => Lens s t a b
_2) ((Version, VersionData) -> VersionData)
-> (Maybe (Version, VersionData) -> (Version, VersionData))
-> Maybe (Version, VersionData)
-> VersionData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Version, VersionData) -> (Version, VersionData)
forall a. HasCallStack => Maybe a -> a
fromJust)
          (Map PackageName (Maybe (Version, VersionData))
 -> Map PackageName GenericPackageDescription)
-> (Map PackageName (Maybe (Version, VersionData))
    -> Map PackageName (Maybe (Version, VersionData)))
-> Map PackageName (Maybe (Version, VersionData))
-> Map PackageName GenericPackageDescription
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (Version, VersionData) -> Bool)
-> Map PackageName (Maybe (Version, VersionData))
-> Map PackageName (Maybe (Version, VersionData))
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Maybe (Version, VersionData)
-> Maybe (Version, VersionData) -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe (Version, VersionData)
forall a. Maybe a
Nothing)
          (Map PackageName (Maybe (Version, VersionData))
 -> [(PackageName, GenericPackageDescription)])
-> Map PackageName (Maybe (Version, VersionData))
-> [(PackageName, GenericPackageDescription)]
forall a b. (a -> b) -> a -> b
$ (Map Version VersionData -> Maybe (Version, VersionData))
-> HackageDB -> Map PackageName (Maybe (Version, VersionData))
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Map Version VersionData -> Maybe (Version, VersionData)
forall k a. Map k a -> Maybe (k, a)
Map.lookupMax HackageDB
db
  f [b] -> Sem r (f [b])
forall (m :: * -> *) a. Monad m => a -> m a
return (f [b] -> Sem r (f [b])) -> f [b] -> Sem r (f [b])
forall a b. (a -> b) -> a -> b
$ ((PackageName, GenericPackageDescription) -> f b)
-> [(PackageName, GenericPackageDescription)] -> f [b]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (PackageName, GenericPackageDescription) -> f b
f [(PackageName, GenericPackageDescription)]
x