{-# 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 String
lookupHackagePath = do
  String
home <- (\String
d -> String
d String -> String -> String
</> String
".cabal" String -> String -> String
</> String
"packages") forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String
getHomeDirectory
  [String]
subs <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String
home String -> String -> String
</>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
listDirectory String
home
  Maybe String
legacy <- [String] -> String -> IO (Maybe String)
findFile [String]
subs String
"00-index.tar"
  Maybe String
new <- [String] -> String -> IO (Maybe String)
findFile [String]
subs String
"01-index.tar"
  case Maybe String
new forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe String
legacy of
    Just String
x -> forall (m :: * -> *) a. Monad m => a -> m a
return String
x
    Maybe String
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Unable to find hackage index tarball from " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show [String]
subs

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

-- | Insert a 'GenericPackageDescription' into 'HackageDB'.
insertDB :: GenericPackageDescription -> HackageDB -> HackageDB
insertDB :: GenericPackageDescription -> HackageDB -> HackageDB
insertDB GenericPackageDescription
cabal = 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 forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> PackageDescription
packageDescription GenericPackageDescription
cabal
    version :: Version
version = PackageDescription -> Version
getPkgVersion forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> PackageDescription
packageDescription GenericPackageDescription
cabal
    versionData :: VersionData
versionData = GenericPackageDescription -> Map String String -> VersionData
VersionData GenericPackageDescription
cabal forall k a. Map k a
Map.empty
    packageData :: Map Version VersionData
packageData = forall k a. k -> a -> Map k a
Map.singleton Version
version VersionData
versionData

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

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

-- | Get the latest 'GenericPackageDescription'.
getLatestCabal :: Members [HackageEnv, WithMyErr] r => PackageName -> Sem r GenericPackageDescription
getLatestCabal :: forall (r :: EffectRow).
Members '[HackageEnv, WithMyErr] r =>
PackageName -> Sem r GenericPackageDescription
getLatestCabal = forall (r :: EffectRow) a.
Members '[HackageEnv, 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 :: forall (r :: EffectRow).
Members '[HackageEnv, WithMyErr] r =>
PackageName -> Sem r (Maybe String)
getLatestSHA256 = forall (r :: EffectRow) a.
Members '[HackageEnv, WithMyErr] r =>
(VersionData -> a) -> PackageName -> Sem r a
withLatestVersion (\VersionData
vdata -> VersionData -> Map String String
tarballHashes VersionData
vdata forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? String
"sha256")

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

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

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