module Hix.Hackage where

import Control.Monad.Extra (fromMaybeM)
import Data.Aeson (FromJSON (parseJSON), eitherDecodeStrict', withObject, (.:))
import Data.IORef (IORef, modifyIORef', readIORef)
import qualified Data.Map.Strict as Map
import Data.Map.Strict ((!?))
import qualified Data.Text as Text
import Distribution.Parsec (eitherParsec)
import Hix.Data.Version (Version)
import Exon (exon)
import Network.HTTP.Client (Manager, Request (..), Response (..), defaultRequest, httpLbs)
import Network.HTTP.Types (
  Status (statusCode, statusMessage),
  hAccept,
  statusIsClientError,
  statusIsServerError,
  statusIsSuccessful,
  )
import System.Exit (ExitCode (ExitFailure, ExitSuccess))
import System.Process.Typed (proc, readProcess)

import Hix.Data.Error (Error (Fatal))
import Hix.Data.PackageId (PackageId, renderPackage)
import Hix.Data.PackageName (PackageName)
import Hix.Data.Version (SourceHash (SourceHash))
import qualified Hix.Log as Log
import Hix.Monad (M, throwM, tryIOM)
import Hix.Pretty (showP)

data HackageVersions =
  HackageVersions {
    HackageVersions -> [[Char]]
versions :: [String]
  }
  deriving stock (HackageVersions -> HackageVersions -> Bool
(HackageVersions -> HackageVersions -> Bool)
-> (HackageVersions -> HackageVersions -> Bool)
-> Eq HackageVersions
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HackageVersions -> HackageVersions -> Bool
== :: HackageVersions -> HackageVersions -> Bool
$c/= :: HackageVersions -> HackageVersions -> Bool
/= :: HackageVersions -> HackageVersions -> Bool
Eq, Int -> HackageVersions -> ShowS
[HackageVersions] -> ShowS
HackageVersions -> [Char]
(Int -> HackageVersions -> ShowS)
-> (HackageVersions -> [Char])
-> ([HackageVersions] -> ShowS)
-> Show HackageVersions
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HackageVersions -> ShowS
showsPrec :: Int -> HackageVersions -> ShowS
$cshow :: HackageVersions -> [Char]
show :: HackageVersions -> [Char]
$cshowList :: [HackageVersions] -> ShowS
showList :: [HackageVersions] -> ShowS
Show, (forall x. HackageVersions -> Rep HackageVersions x)
-> (forall x. Rep HackageVersions x -> HackageVersions)
-> Generic HackageVersions
forall x. Rep HackageVersions x -> HackageVersions
forall x. HackageVersions -> Rep HackageVersions x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. HackageVersions -> Rep HackageVersions x
from :: forall x. HackageVersions -> Rep HackageVersions x
$cto :: forall x. Rep HackageVersions x -> HackageVersions
to :: forall x. Rep HackageVersions x -> HackageVersions
Generic)

instance FromJSON HackageVersions where
  parseJSON :: Value -> Parser HackageVersions
parseJSON = [Char]
-> (Object -> Parser HackageVersions)
-> Value
-> Parser HackageVersions
forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
withObject [Char]
"HackageVersions" \ Object
o -> [[Char]] -> HackageVersions
HackageVersions ([[Char]] -> HackageVersions)
-> Parser [[Char]] -> Parser HackageVersions
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser [[Char]]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"normal-version"

parseVersion :: String -> Either (String, String) Version
parseVersion :: [Char] -> Either ([Char], [Char]) Version
parseVersion [Char]
s = ([Char] -> ([Char], [Char]))
-> Either [Char] Version -> Either ([Char], [Char]) Version
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ([Char]
s,) ([Char] -> Either [Char] Version
forall a. Parsec a => [Char] -> Either [Char] a
eitherParsec [Char]
s)

parseResult :: LByteString -> M (Either Text [Version])
parseResult :: ByteString -> M (Either Text [Version])
parseResult ByteString
body =
  case ByteString -> Either [Char] HackageVersions
forall a. FromJSON a => ByteString -> Either [Char] a
eitherDecodeStrict' (ByteString -> ByteString
forall l s. LazyStrict l s => l -> s
toStrict ByteString
body) of
    Left [Char]
err ->
      Text -> M (Either Text [Version])
forall {a} {b}. a -> M (Either a b)
noVersion [exon|Hackage response parse error: #{toText err}|]
    Right (HackageVersions []) ->
      Text -> M (Either Text [Version])
forall {a} {b}. a -> M (Either a b)
noVersion Text
"No versions on Hackage"
    Right (HackageVersions [[Char]]
versions) ->
      case ([Char] -> Either ([Char], [Char]) Version)
-> [[Char]] -> Either ([Char], [Char]) [Version]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse [Char] -> Either ([Char], [Char]) Version
parseVersion [[Char]]
versions of
        Left ([Char]
v, [Char]
err) -> Text -> M (Either Text [Version])
forall {a} {b}. a -> M (Either a b)
noVersion ([Char] -> Text
forall a. ToText a => a -> Text
toText [exon|Version '#{v}' has invalid format (#{err})|])
        Right [Version]
vs -> Either Text [Version] -> M (Either Text [Version])
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Version] -> Either Text [Version]
forall a b. b -> Either a b
Right [Version]
vs)
  where
    noVersion :: a -> M (Either a b)
noVersion = Either a b -> M (Either a b)
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either a b -> M (Either a b))
-> (a -> Either a b) -> a -> M (Either a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either a b
forall a b. a -> Either a b
Left

versionsHackage :: Manager -> PackageName -> M [Version]
versionsHackage :: Manager -> PackageName -> M [Version]
versionsHackage Manager
manager PackageName
pkg = do
  Response ByteString
res <- IO (Response ByteString) -> M (Response ByteString)
forall a. IO a -> M a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Request -> Manager -> IO (Response ByteString)
httpLbs Request
request Manager
manager)
  let
    body :: ByteString
body = Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
res

    status :: Status
status = Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
res

    errorStatus :: Text -> M [Version]
errorStatus Text
category = Text -> M [Version]
noVersion [exon|#{category} (#{decodeUtf8 (statusMessage status)})|]

  if
    | Status -> Bool
statusIsSuccessful Status
status -> (Text -> M [Version]) -> Either Text [Version] -> M [Version]
forall (m :: * -> *) a b.
Applicative m =>
(a -> m b) -> Either a b -> m b
leftA Text -> M [Version]
noVersion (Either Text [Version] -> M [Version])
-> M (Either Text [Version]) -> M [Version]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ByteString -> M (Either Text [Version])
parseResult ByteString
body
    | Status -> Int
statusCode Status
status Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
404 -> Text -> M [Version]
noVersion Text
"PackageId does not exist"
    | Status -> Bool
statusIsClientError Status
status -> Text -> M [Version]
errorStatus Text
"Client error"
    | Status -> Bool
statusIsServerError Status
status -> Text -> M [Version]
errorStatus Text
"Server error"
    | Bool
otherwise -> Text -> M [Version]
errorStatus Text
"Weird error"

  where
    request :: Request
request =
      Request
defaultRequest {
        host = "hackage.haskell.org",
        secure = False,
        method = "GET",
        path = [exon|/package/##{pkg}/preferred|],
        requestHeaders = [(hAccept, "application/json")]
      }

    noVersion :: Text -> M [Version]
noVersion Text
msg =
      [] [Version] -> M () -> M [Version]
forall a b. a -> M b -> M a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> M ()
Log.error [exon|Hackage request for '##{pkg}' failed: #{msg}|]

latestVersionHackage :: Manager -> PackageName -> M (Maybe Version)
latestVersionHackage :: Manager -> PackageName -> M (Maybe Version)
latestVersionHackage Manager
manager PackageName
pkg =
  [Version] -> Maybe Version
forall a. [a] -> Maybe a
head ([Version] -> Maybe Version) -> M [Version] -> M (Maybe Version)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Manager -> PackageName -> M [Version]
versionsHackage Manager
manager PackageName
pkg

fetchHashHackage ::
  PackageId ->
  M SourceHash
fetchHashHackage :: PackageId -> M SourceHash
fetchHashHackage PackageId
package = do
  Text -> M ()
Log.debug [exon|Fetching hash for '##{slug}' from ##{url}|]
  IO (ExitCode, ByteString, ByteString)
-> M (ExitCode, ByteString, ByteString)
forall a. IO a -> M a
tryIOM (ProcessConfig () () () -> IO (ExitCode, ByteString, ByteString)
forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ExitCode, ByteString, ByteString)
readProcess ProcessConfig () () ()
conf) M (ExitCode, ByteString, ByteString)
-> ((ExitCode, ByteString, ByteString) -> M SourceHash)
-> M SourceHash
forall a b. M a -> (a -> M b) -> M b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    (ExitFailure Int
_, ByteString
_, ByteString
err) ->
      Error -> M SourceHash
forall a. Error -> M a
throwM (Text -> Error
Fatal [exon|Prefetching source of '##{slug}' from hackage failed: #{decodeUtf8 err}|])
    (ExitCode
ExitSuccess, ByteString
hash, ByteString
_) ->
      SourceHash -> M SourceHash
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> SourceHash
SourceHash (Text -> Text
Text.stripEnd (ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 ByteString
hash)))
  where
    conf :: ProcessConfig () () ()
conf = [Char] -> [[Char]] -> ProcessConfig () () ()
proc [Char]
"nix-prefetch-url" [[Char]
Item [[Char]]
"--unpack", [Char]
Item [[Char]]
url]
    url :: [Char]
url = [exon|https://hackage.haskell.org/package/#{slug}/#{slug}.tar.gz|]
    slug :: [Char]
slug = PackageId -> [Char]
forall b a. (Pretty a, IsString b) => a -> b
showP PackageId
package

fetchHashHackageCached ::
  IORef (Map Text SourceHash) ->
  PackageId ->
  M SourceHash
fetchHashHackageCached :: IORef (Map Text SourceHash) -> PackageId -> M SourceHash
fetchHashHackageCached IORef (Map Text SourceHash)
cacheRef PackageId
package =
  IO (Map Text SourceHash) -> M (Map Text SourceHash)
forall a. IO a -> M a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Map Text SourceHash) -> IO (Map Text SourceHash)
forall a. IORef a -> IO a
readIORef IORef (Map Text SourceHash)
cacheRef) M (Map Text SourceHash)
-> (Map Text SourceHash -> M SourceHash) -> M SourceHash
forall a b. M a -> (a -> M b) -> M b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ Map Text SourceHash
cache ->
    M SourceHash -> M (Maybe SourceHash) -> M SourceHash
forall (m :: * -> *) a. Monad m => m a -> m (Maybe a) -> m a
fromMaybeM M SourceHash
fetch (Maybe SourceHash -> M (Maybe SourceHash)
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Text SourceHash
cache Map Text SourceHash -> Text -> Maybe SourceHash
forall k a. Ord k => Map k a -> k -> Maybe a
!? Text
cacheKey))
  where
    fetch :: M SourceHash
fetch = do
      SourceHash
hash <- PackageId -> M SourceHash
fetchHashHackage PackageId
package
      SourceHash
hash SourceHash -> M () -> M SourceHash
forall a b. a -> M b -> M a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ SourceHash -> M ()
addToCache SourceHash
hash

    addToCache :: SourceHash -> M ()
addToCache SourceHash
hash = IO () -> M ()
forall a. IO a -> M a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Map Text SourceHash)
-> (Map Text SourceHash -> Map Text SourceHash) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (Map Text SourceHash)
cacheRef (Text -> SourceHash -> Map Text SourceHash -> Map Text SourceHash
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
cacheKey SourceHash
hash))

    cacheKey :: Text
cacheKey = PackageId -> Text
renderPackage PackageId
package