{-# LANGUAGE CPP #-}
-- |
-- Module: Staversion.Internal.BuildPlan.Stackage
-- Description: dealing with Stackage and build-plan repositories online.
-- Maintainer: Toshio Ito <debug.ito@gmail.com>
--
-- __This is an internal module. End-users should not use it.__
--
-- This module is meant to be exposed only to
-- "Staversion.Internal.BuildPlan" and test modules.

module Staversion.Internal.BuildPlan.Stackage
       ( -- * High level API
         ExactResolver(..),
         PartialResolver(..),
         parseResolverString,
         formatResolverString,
         formatExactResolverString,
         Disambiguator,
         fetchDisambiguator,
         -- * Low level API
         parseDisambiguator
       ) where

import Control.Monad (void)
import Control.Applicative ((<|>), (*>), (<$>), (<*>), empty, pure)
import qualified Control.Exception as Exception (handle)
import Data.Aeson (FromJSON(..), Value(..))
import qualified Data.Aeson as Aeson
import qualified Data.ByteString.Lazy as BSL
import Data.Function (on)
#if MIN_VERSION_aeson(2,0,0)
import Data.Aeson.Key (toString)
import qualified Data.Aeson.KeyMap as HM
#else
import Data.Text (unpack)
import qualified Data.HashMap.Strict as HM
#endif
import qualified Data.Map as M
import Data.Maybe (listToMaybe)
import Data.List (sortBy)
import Data.Word (Word)
import Data.IORef (IORef)
import System.IO.Error (ioError, userError)
import qualified Text.ParserCombinators.ReadP as P
import Text.Printf (printf)
import Text.Read.Lex (readDecP)

import Staversion.Internal.HTTP (Manager, fetchURL, OurHttpException)
import Staversion.Internal.Query (Resolver, ErrorMsg)

-- | Non-ambiguous fully-resolved resolver for stackage.
data ExactResolver = ExactLTS Word Word  -- ^ lts-(major).(minor)
                   | ExactNightly Word Word Word -- ^ nightly-(year)-(month)-(day)
                   deriving (Int -> ExactResolver -> ShowS
[ExactResolver] -> ShowS
ExactResolver -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ExactResolver] -> ShowS
$cshowList :: [ExactResolver] -> ShowS
show :: ExactResolver -> [Char]
$cshow :: ExactResolver -> [Char]
showsPrec :: Int -> ExactResolver -> ShowS
$cshowsPrec :: Int -> ExactResolver -> ShowS
Show,ExactResolver -> ExactResolver -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ExactResolver -> ExactResolver -> Bool
$c/= :: ExactResolver -> ExactResolver -> Bool
== :: ExactResolver -> ExactResolver -> Bool
$c== :: ExactResolver -> ExactResolver -> Bool
Eq,Eq ExactResolver
ExactResolver -> ExactResolver -> Bool
ExactResolver -> ExactResolver -> Ordering
ExactResolver -> ExactResolver -> ExactResolver
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ExactResolver -> ExactResolver -> ExactResolver
$cmin :: ExactResolver -> ExactResolver -> ExactResolver
max :: ExactResolver -> ExactResolver -> ExactResolver
$cmax :: ExactResolver -> ExactResolver -> ExactResolver
>= :: ExactResolver -> ExactResolver -> Bool
$c>= :: ExactResolver -> ExactResolver -> Bool
> :: ExactResolver -> ExactResolver -> Bool
$c> :: ExactResolver -> ExactResolver -> Bool
<= :: ExactResolver -> ExactResolver -> Bool
$c<= :: ExactResolver -> ExactResolver -> Bool
< :: ExactResolver -> ExactResolver -> Bool
$c< :: ExactResolver -> ExactResolver -> Bool
compare :: ExactResolver -> ExactResolver -> Ordering
$ccompare :: ExactResolver -> ExactResolver -> Ordering
Ord)

-- | Potentially partial resolver for stackage.
data PartialResolver = PartialExact ExactResolver
                     | PartialLTSLatest -- ^ lts (latest)
                     | PartialLTSMajor Word -- ^ lts-(major)
                     | PartialNightlyLatest -- ^ nightly (latest)
                     deriving (Int -> PartialResolver -> ShowS
[PartialResolver] -> ShowS
PartialResolver -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PartialResolver] -> ShowS
$cshowList :: [PartialResolver] -> ShowS
show :: PartialResolver -> [Char]
$cshow :: PartialResolver -> [Char]
showsPrec :: Int -> PartialResolver -> ShowS
$cshowsPrec :: Int -> PartialResolver -> ShowS
Show,PartialResolver -> PartialResolver -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PartialResolver -> PartialResolver -> Bool
$c/= :: PartialResolver -> PartialResolver -> Bool
== :: PartialResolver -> PartialResolver -> Bool
$c== :: PartialResolver -> PartialResolver -> Bool
Eq,Eq PartialResolver
PartialResolver -> PartialResolver -> Bool
PartialResolver -> PartialResolver -> Ordering
PartialResolver -> PartialResolver -> PartialResolver
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PartialResolver -> PartialResolver -> PartialResolver
$cmin :: PartialResolver -> PartialResolver -> PartialResolver
max :: PartialResolver -> PartialResolver -> PartialResolver
$cmax :: PartialResolver -> PartialResolver -> PartialResolver
>= :: PartialResolver -> PartialResolver -> Bool
$c>= :: PartialResolver -> PartialResolver -> Bool
> :: PartialResolver -> PartialResolver -> Bool
$c> :: PartialResolver -> PartialResolver -> Bool
<= :: PartialResolver -> PartialResolver -> Bool
$c<= :: PartialResolver -> PartialResolver -> Bool
< :: PartialResolver -> PartialResolver -> Bool
$c< :: PartialResolver -> PartialResolver -> Bool
compare :: PartialResolver -> PartialResolver -> Ordering
$ccompare :: PartialResolver -> PartialResolver -> Ordering
Ord)

parseResolverString :: Resolver -> Maybe PartialResolver
parseResolverString :: [Char] -> Maybe PartialResolver
parseResolverString = forall {b} {a}. [(b, [a])] -> Maybe b
getResult forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ReadP a -> ReadS a
P.readP_to_S ReadP PartialResolver
parser where
  getResult :: [(b, [a])] -> Maybe b
getResult = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
listToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd))
  decimal :: ReadP Word
decimal = forall a. (Eq a, Num a) => ReadP a
readDecP
  parser :: ReadP PartialResolver
parser = ReadP PartialResolver
lts forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReadP PartialResolver
nightly
  lts :: ReadP PartialResolver
lts = [Char] -> ReadP [Char]
P.string [Char]
"lts" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ( ReadP PartialResolver
lts_exact forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReadP PartialResolver
lts_major forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (ReadP ()
P.eof forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure PartialResolver
PartialLTSLatest) )
  lts_exact :: ReadP PartialResolver
lts_exact = do
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Char -> ReadP Char
P.char Char
'-'
    Word
major <- ReadP Word
decimal
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Char -> ReadP Char
P.char Char
'.'
    Word
minor <- ReadP Word
decimal
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ExactResolver -> PartialResolver
PartialExact forall a b. (a -> b) -> a -> b
$ Word -> Word -> ExactResolver
ExactLTS Word
major Word
minor
  lts_major :: ReadP PartialResolver
lts_major = Char -> ReadP Char
P.char Char
'-' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ( Word -> PartialResolver
PartialLTSMajor forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP Word
decimal )
  nightly :: ReadP PartialResolver
nightly = [Char] -> ReadP [Char]
P.string [Char]
"nightly" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ( ReadP PartialResolver
nightly_exact forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (ReadP ()
P.eof forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure PartialResolver
PartialNightlyLatest) )
  nightly_exact :: ReadP PartialResolver
nightly_exact = do
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Char -> ReadP Char
P.char Char
'-'
    Word
year <- ReadP Word
decimal
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Char -> ReadP Char
P.char Char
'-'
    Word
month <- ReadP Word
decimal
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Char -> ReadP Char
P.char Char
'-'
    Word
day <- ReadP Word
decimal
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ExactResolver -> PartialResolver
PartialExact forall a b. (a -> b) -> a -> b
$ Word -> Word -> Word -> ExactResolver
ExactNightly Word
year Word
month Word
day

formatResolverString :: PartialResolver -> Resolver
formatResolverString :: PartialResolver -> [Char]
formatResolverString PartialResolver
pr = case PartialResolver
pr of
  PartialExact (ExactLTS Word
major Word
minor) -> [Char]
"lts-" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Word
major forall a. [a] -> [a] -> [a]
++ [Char]
"." forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Word
minor
  PartialExact (ExactNightly Word
year Word
month Word
day) -> forall r. PrintfType r => [Char] -> r
printf [Char]
"nightly-%04d-%02d-%02d" Word
year Word
month Word
day
  PartialResolver
PartialLTSLatest -> [Char]
"lts"
  PartialLTSMajor Word
major -> [Char]
"lts-" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Word
major
  PartialResolver
PartialNightlyLatest -> [Char]
"nightly"

formatExactResolverString :: ExactResolver -> Resolver
formatExactResolverString :: ExactResolver -> [Char]
formatExactResolverString ExactResolver
er = PartialResolver -> [Char]
formatResolverString forall a b. (a -> b) -> a -> b
$ ExactResolver -> PartialResolver
PartialExact ExactResolver
er

type Disambiguator = PartialResolver -> Maybe ExactResolver

-- | Fetch the 'Disambiguator' from the Internet.
fetchDisambiguator :: Manager -> IO (Either ErrorMsg Disambiguator)
fetchDisambiguator :: Manager -> IO (Either [Char] Disambiguator)
fetchDisambiguator Manager
man = (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {b}. Maybe b -> Either [Char] b
toEither forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe Disambiguator
parseDisambiguator) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Manager -> [Char] -> IO ByteString
fetchURL Manager
man [Char]
disambiguator_url where
  disambiguator_url :: [Char]
disambiguator_url = [Char]
"https://www.stackage.org/download/snapshots.json"
  toEither :: Maybe b -> Either [Char] b
toEither = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left ([Char]
"Failed to parse disambiguator from" forall a. [a] -> [a] -> [a]
++ [Char]
disambiguator_url)) forall a b. b -> Either a b
Right

newtype DisamMap = DisamMap { DisamMap -> Map PartialResolver ExactResolver
unDisamMap :: M.Map PartialResolver ExactResolver }

instance FromJSON DisamMap where
  parseJSON :: Value -> Parser DisamMap
parseJSON (Object Object
o) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Map PartialResolver ExactResolver -> DisamMap
DisamMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
M.fromList) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Key, Value) -> Parser (PartialResolver, ExactResolver)
parsePair forall a b. (a -> b) -> a -> b
$ forall v. KeyMap v -> [(Key, v)]
HM.toList Object
o
    where
    parsePair :: (Key, Value) -> Parser (PartialResolver, ExactResolver)
parsePair (Key
k,Value
v) = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {f :: * -> *}.
(Alternative f, Monad f) =>
Key -> f PartialResolver
parseKey Key
k forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Parser ExactResolver
parseValue Value
v
    parseKey :: Key -> f PartialResolver
parseKey Key
key = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (f :: * -> *) a. Alternative f => f a
empty forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe PartialResolver
parseResolverString forall a b. (a -> b) -> a -> b
$ Key -> [Char]
toString Key
key
    parseValue :: Value -> Parser ExactResolver
parseValue Value
v = (forall {m :: * -> *}.
(Monad m, Alternative m) =>
Maybe PartialResolver -> m ExactResolver
expectExact forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Maybe PartialResolver
parseResolverString) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
    expectExact :: Maybe PartialResolver -> m ExactResolver
expectExact (Just (PartialExact ExactResolver
e)) = forall (m :: * -> *) a. Monad m => a -> m a
return ExactResolver
e
    expectExact Maybe PartialResolver
_ = forall (f :: * -> *) a. Alternative f => f a
empty
#if !MIN_VERSION_aeson(2,0,0)
    toString = unpack
#endif
  parseJSON Value
_ = forall (f :: * -> *) a. Alternative f => f a
empty

parseDisambiguator :: BSL.ByteString -- ^ disambiguation JSON text.
                   -> Maybe Disambiguator
parseDisambiguator :: ByteString -> Maybe Disambiguator
parseDisambiguator ByteString
input = DisamMap -> Disambiguator
toDisam forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => ByteString -> Maybe a
Aeson.decode ByteString
input where
  toDisam :: DisamMap -> Disambiguator
toDisam DisamMap
_ (PartialExact ExactResolver
e) = forall a. a -> Maybe a
Just ExactResolver
e
  toDisam DisamMap
dis_map PartialResolver
key = forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PartialResolver
key (DisamMap -> Map PartialResolver ExactResolver
unDisamMap DisamMap
dis_map)