{- Downloads binary serialized https://package.elm-lang.org/all-packages
   as Elm compiler expects it to parse.

  Takes Elm upstream code from:
  - https://github.com/elm/compiler/blob/master/builder/src/Deps/Cache.hs
  - https://github.com/elm/compiler/blob/master/builder/src/Deps/Website.hs
  - https://github.com/elm/compiler/blob/master/compiler/src/Elm/Package.hs

-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
module Elm2Nix.PackagesSnapshot
  ( snapshot
  ) where

import Control.Monad (liftM2, liftM3)
import qualified Data.Aeson as Aeson
import qualified Data.Binary as Binary
import Data.Binary (Binary, put, get, putWord8, getWord8)
import Data.Binary.Put (putBuilder)
import Data.Binary.Get.Internal (readN)
import qualified Data.Map as Map
#if MIN_VERSION_req(2,0,0)
#else
import Data.Default (def)
#endif
import Data.Map (Map)
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.Word (Word16)
import qualified Network.HTTP.Req as Req
import System.FilePath ((</>))
import qualified Data.List as List
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as BS


data Name =
  Name
    { Name -> Text
_author :: !Text
    , Name -> Text
_project :: !Text
    }
    deriving (Name -> Name -> Bool
(Name -> Name -> Bool) -> (Name -> Name -> Bool) -> Eq Name
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Name -> Name -> Bool
$c/= :: Name -> Name -> Bool
== :: Name -> Name -> Bool
$c== :: Name -> Name -> Bool
Eq, Eq Name
Eq Name
-> (Name -> Name -> Ordering)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Name)
-> (Name -> Name -> Name)
-> Ord Name
Name -> Name -> Bool
Name -> Name -> Ordering
Name -> Name -> Name
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 :: Name -> Name -> Name
$cmin :: Name -> Name -> Name
max :: Name -> Name -> Name
$cmax :: Name -> Name -> Name
>= :: Name -> Name -> Bool
$c>= :: Name -> Name -> Bool
> :: Name -> Name -> Bool
$c> :: Name -> Name -> Bool
<= :: Name -> Name -> Bool
$c<= :: Name -> Name -> Bool
< :: Name -> Name -> Bool
$c< :: Name -> Name -> Bool
compare :: Name -> Name -> Ordering
$ccompare :: Name -> Name -> Ordering
$cp1Ord :: Eq Name
Ord)

data Package =
  Package
    { Package -> Name
_name :: !Name
    , Package -> Version
_version :: !Version
    }
    deriving (Package -> Package -> Bool
(Package -> Package -> Bool)
-> (Package -> Package -> Bool) -> Eq Package
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Package -> Package -> Bool
$c/= :: Package -> Package -> Bool
== :: Package -> Package -> Bool
$c== :: Package -> Package -> Bool
Eq, Eq Package
Eq Package
-> (Package -> Package -> Ordering)
-> (Package -> Package -> Bool)
-> (Package -> Package -> Bool)
-> (Package -> Package -> Bool)
-> (Package -> Package -> Bool)
-> (Package -> Package -> Package)
-> (Package -> Package -> Package)
-> Ord Package
Package -> Package -> Bool
Package -> Package -> Ordering
Package -> Package -> Package
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 :: Package -> Package -> Package
$cmin :: Package -> Package -> Package
max :: Package -> Package -> Package
$cmax :: Package -> Package -> Package
>= :: Package -> Package -> Bool
$c>= :: Package -> Package -> Bool
> :: Package -> Package -> Bool
$c> :: Package -> Package -> Bool
<= :: Package -> Package -> Bool
$c<= :: Package -> Package -> Bool
< :: Package -> Package -> Bool
$c< :: Package -> Package -> Bool
compare :: Package -> Package -> Ordering
$ccompare :: Package -> Package -> Ordering
$cp1Ord :: Eq Package
Ord)

data Version =
  Version
    { Version -> Word16
_major :: {-# UNPACK #-} !Word16
    , Version -> Word16
_minor :: {-# UNPACK #-} !Word16
    , Version -> Word16
_patch :: {-# UNPACK #-} !Word16
    }
    deriving (Version -> Version -> Bool
(Version -> Version -> Bool)
-> (Version -> Version -> Bool) -> Eq Version
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Version -> Version -> Bool
$c/= :: Version -> Version -> Bool
== :: Version -> Version -> Bool
$c== :: Version -> Version -> Bool
Eq, Eq Version
Eq Version
-> (Version -> Version -> Ordering)
-> (Version -> Version -> Bool)
-> (Version -> Version -> Bool)
-> (Version -> Version -> Bool)
-> (Version -> Version -> Bool)
-> (Version -> Version -> Version)
-> (Version -> Version -> Version)
-> Ord Version
Version -> Version -> Bool
Version -> Version -> Ordering
Version -> Version -> Version
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 :: Version -> Version -> Version
$cmin :: Version -> Version -> Version
max :: Version -> Version -> Version
$cmax :: Version -> Version -> Version
>= :: Version -> Version -> Bool
$c>= :: Version -> Version -> Bool
> :: Version -> Version -> Bool
$c> :: Version -> Version -> Bool
<= :: Version -> Version -> Bool
$c<= :: Version -> Version -> Bool
< :: Version -> Version -> Bool
$c< :: Version -> Version -> Bool
compare :: Version -> Version -> Ordering
$ccompare :: Version -> Version -> Ordering
$cp1Ord :: Eq Version
Ord)

data KnownVersions =
  KnownVersions
    { KnownVersions -> Version
_newest :: Version
    , KnownVersions -> [Version]
_previous :: ![Version]
    }

data Registry =
  Registry
    { Registry -> Int
_count :: !Int
    , Registry -> Map Name KnownVersions
_versions :: !(Map Name KnownVersions)
    }

putUnder256 :: BS.ByteString -> Binary.Put
putUnder256 :: ByteString -> Put
putUnder256 ByteString
bs =
  do  Word8 -> Put
putWord8 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
bs))
      Builder -> Put
putBuilder (ByteString -> Builder
BS.byteString ByteString
bs)

getUnder256 :: Binary.Get (BS.ByteString)
getUnder256 :: Get ByteString
getUnder256 =
  do  Word8
word <- Get Word8
getWord8
      let !n :: Int
n = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
word
      Int -> (ByteString -> ByteString) -> Get ByteString
forall a. Int -> (ByteString -> a) -> Get a
readN Int
n ByteString -> ByteString
forall a. a -> a
id

instance Binary Name where
  get :: Get Name
get =
    (Text -> Text -> Name) -> Get Text -> Get Text -> Get Name
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Text -> Text -> Name
Name
      ((ByteString -> Text) -> Get ByteString -> Get Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
Text.decodeUtf8 Get ByteString
getUnder256)
      ((ByteString -> Text) -> Get ByteString -> Get Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
Text.decodeUtf8 Get ByteString
getUnder256)

  put :: Name -> Put
put (Name Text
author Text
project) =
    do ByteString -> Put
putUnder256 (Text -> ByteString
Text.encodeUtf8 Text
author)
       ByteString -> Put
putUnder256 (Text -> ByteString
Text.encodeUtf8 Text
project)

instance Binary Package where
  get :: Get Package
get =
    (Name -> Version -> Package)
-> Get Name -> Get Version -> Get Package
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Name -> Version -> Package
Package Get Name
forall t. Binary t => Get t
get Get Version
forall t. Binary t => Get t
get

  put :: Package -> Put
put (Package Name
name Version
version) =
    do  Name -> Put
forall t. Binary t => t -> Put
put Name
name
        Version -> Put
forall t. Binary t => t -> Put
put Version
version

instance Binary Version where
  get :: Get Version
get =
    do  Word8
word <- Get Word8
getWord8
        if Word8
word Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
255
          then (Word16 -> Word16 -> Word16 -> Version)
-> Get Word16 -> Get Word16 -> Get Word16 -> Get Version
forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 Word16 -> Word16 -> Word16 -> Version
Version Get Word16
forall t. Binary t => Get t
get Get Word16
forall t. Binary t => Get t
get Get Word16
forall t. Binary t => Get t
get
          else
            do  Word16
minor <- (Word8 -> Word16) -> Get Word8 -> Get Word16
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Get Word8
getWord8
                Word16
patch <- (Word8 -> Word16) -> Get Word8 -> Get Word16
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Get Word8
getWord8
                Version -> Get Version
forall (m :: * -> *) a. Monad m => a -> m a
return (Word16 -> Word16 -> Word16 -> Version
Version (Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
word) Word16
minor Word16
patch)

  put :: Version -> Put
put (Version Word16
major Word16
minor Word16
patch) =
    if Word16
major Word16 -> Word16 -> Bool
forall a. Ord a => a -> a -> Bool
< Word16
256 Bool -> Bool -> Bool
&& Word16
minor Word16 -> Word16 -> Bool
forall a. Ord a => a -> a -> Bool
< Word16
256 Bool -> Bool -> Bool
&& Word16
patch Word16 -> Word16 -> Bool
forall a. Ord a => a -> a -> Bool
< Word16
256 then
      do  Word8 -> Put
putWord8 (Word16 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
major)
          Word8 -> Put
putWord8 (Word16 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
minor)
          Word8 -> Put
putWord8 (Word16 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
patch)
    else
      do  Word8 -> Put
putWord8 Word8
255
          Word16 -> Put
forall t. Binary t => t -> Put
put Word16
major
          Word16 -> Put
forall t. Binary t => t -> Put
put Word16
minor
          Word16 -> Put
forall t. Binary t => t -> Put
put Word16
patch

instance Binary KnownVersions where
  get :: Get KnownVersions
get = (Version -> [Version] -> KnownVersions)
-> Get Version -> Get [Version] -> Get KnownVersions
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Version -> [Version] -> KnownVersions
KnownVersions Get Version
forall t. Binary t => Get t
get Get [Version]
forall t. Binary t => Get t
get
  put :: KnownVersions -> Put
put (KnownVersions Version
a [Version]
b) = Version -> Put
forall t. Binary t => t -> Put
put Version
a Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Version] -> Put
forall t. Binary t => t -> Put
put [Version]
b

instance Binary Registry where
  get :: Get Registry
get = (Int -> Map Name KnownVersions -> Registry)
-> Get Int -> Get (Map Name KnownVersions) -> Get Registry
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Int -> Map Name KnownVersions -> Registry
Registry Get Int
forall t. Binary t => Get t
get Get (Map Name KnownVersions)
forall t. Binary t => Get t
get
  put :: Registry -> Put
put (Registry Int
a Map Name KnownVersions
b) = Int -> Put
forall t. Binary t => t -> Put
put Int
a Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Map Name KnownVersions -> Put
forall t. Binary t => t -> Put
put Map Name KnownVersions
b

#if MIN_VERSION_req(2,0,0)
defHttpConfig :: HttpConfig
defHttpConfig = HttpConfig
Req.defaultHttpConfig
#else
defHttpConfig = def
#endif

snapshot :: String -> IO ()
snapshot :: String -> IO ()
snapshot String
dir = do
  JsonResponse Value
r <- HttpConfig -> Req (JsonResponse Value) -> IO (JsonResponse Value)
forall (m :: * -> *) a. MonadIO m => HttpConfig -> Req a -> m a
Req.runReq HttpConfig
defHttpConfig (Req (JsonResponse Value) -> IO (JsonResponse Value))
-> Req (JsonResponse Value) -> IO (JsonResponse Value)
forall a b. (a -> b) -> a -> b
$
    POST
-> Url 'Https
-> NoReqBody
-> Proxy (JsonResponse Value)
-> Option 'Https
-> Req (JsonResponse Value)
forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
 HttpResponse response,
 HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
Req.req
    POST
Req.POST
    (Text -> Url 'Https
Req.https Text
"package.elm-lang.org" Url 'Https -> Text -> Url 'Https
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
Req./: Text
"all-packages")
    NoReqBody
Req.NoReqBody
    Proxy (JsonResponse Value)
forall a. Proxy (JsonResponse a)
Req.jsonResponse
    Option 'Https
forall a. Monoid a => a
mempty
  let packages :: Map Name KnownVersions
packages = Packages -> Map Name KnownVersions
unwrap (Packages -> Map Name KnownVersions)
-> Packages -> Map Name KnownVersions
forall a b. (a -> b) -> a -> b
$ case Value -> Result Packages
forall a. FromJSON a => Value -> Result a
Aeson.fromJSON (JsonResponse Value -> HttpResponseBody (JsonResponse Value)
forall response.
HttpResponse response =>
response -> HttpResponseBody response
Req.responseBody JsonResponse Value
r) of
         Aeson.Error String
s -> String -> Packages
forall a. HasCallStack => String -> a
error String
s
         Aeson.Success Packages
val -> Packages
val
      size :: Int
size = (KnownVersions -> Int -> Int)
-> Int -> Map Name KnownVersions -> Int
forall a b k. (a -> b -> b) -> b -> Map k a -> b
Map.foldr' KnownVersions -> Int -> Int
addEntry Int
0 Map Name KnownVersions
packages
      registry :: Registry
registry = Int -> Map Name KnownVersions -> Registry
Registry Int
size Map Name KnownVersions
packages

      addEntry :: KnownVersions -> Int -> Int
      addEntry :: KnownVersions -> Int -> Int
addEntry (KnownVersions Version
_ [Version]
vs) Int
count =
        Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Version] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Version]
vs

  String -> Registry -> IO ()
forall a. Binary a => String -> a -> IO ()
Binary.encodeFile (String
dir String -> String -> String
</> String
"registry.dat") Registry
registry

newtype Packages = Packages { Packages -> Map Name KnownVersions
unwrap :: Map.Map Name KnownVersions }

toKnownVersions ::  Map.Map Name [Version] -> Map.Map Name KnownVersions
toKnownVersions :: Map Name [Version] -> Map Name KnownVersions
toKnownVersions  =
  ([Version] -> KnownVersions)
-> Map Name [Version] -> Map Name KnownVersions
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[Version]
versions ->
          case (Version -> Version -> Ordering) -> [Version] -> [Version]
forall a. (a -> a -> Ordering) -> [a] -> [a]
List.sortBy ((Version -> Version -> Ordering) -> Version -> Version -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip Version -> Version -> Ordering
forall a. Ord a => a -> a -> Ordering
compare) [Version]
versions of
            Version
v:[Version]
vs -> Version -> [Version] -> KnownVersions
KnownVersions Version
v [Version]
vs
            [] -> KnownVersions
forall a. HasCallStack => a
undefined
       )

instance Aeson.FromJSON Packages where
  parseJSON :: Value -> Parser Packages
parseJSON Value
v = Map Name KnownVersions -> Packages
Packages (Map Name KnownVersions -> Packages)
-> Parser (Map Name KnownVersions) -> Parser Packages
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Map Name [Version] -> Map Name KnownVersions)
-> Parser (Map Name [Version]) -> Parser (Map Name KnownVersions)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Map Name [Version] -> Map Name KnownVersions
toKnownVersions (Value -> Parser (Map Name [Version])
forall a. FromJSON a => Value -> Parser a
Aeson.parseJSON Value
v)


instance Aeson.FromJSON Version where
  parseJSON :: Value -> Parser Version
parseJSON = String -> (Text -> Parser Version) -> Value -> Parser Version
forall a. String -> (Text -> Parser a) -> Value -> Parser a
Aeson.withText String
"string" ((Text -> Parser Version) -> Value -> Parser Version)
-> (Text -> Parser Version) -> Value -> Parser Version
forall a b. (a -> b) -> a -> b
$ \Text
x ->
    case Text -> Text -> [Text]
Text.splitOn Text
"." Text
x of
      [Text
major, Text
minor, Text
patch] ->
        Version -> Parser Version
forall (m :: * -> *) a. Monad m => a -> m a
return (Version -> Parser Version) -> Version -> Parser Version
forall a b. (a -> b) -> a -> b
$ Word16 -> Word16 -> Word16 -> Version
Version
                  (String -> Word16
forall a. Read a => String -> a
read (Text -> String
Text.unpack Text
major))
                  (String -> Word16
forall a. Read a => String -> a
read (Text -> String
Text.unpack Text
minor))
                  (String -> Word16
forall a. Read a => String -> a
read (Text -> String
Text.unpack Text
patch))
      [Text]
_ ->
        String -> Parser Version
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"failure parsing version"


instance Aeson.FromJSON Name where
  parseJSON :: Value -> Parser Name
parseJSON = String -> (Text -> Parser Name) -> Value -> Parser Name
forall a. String -> (Text -> Parser a) -> Value -> Parser a
Aeson.withText String
"string" ((Text -> Parser Name) -> Value -> Parser Name)
-> (Text -> Parser Name) -> Value -> Parser Name
forall a b. (a -> b) -> a -> b
$ \Text
x ->
    case Text -> Text -> [Text]
Text.splitOn Text
"/" Text
x of
      [Text
author, Text
package] -> Name -> Parser Name
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Parser Name) -> Name -> Parser Name
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Name
Name Text
author Text
package
      [Text]
lst -> String -> Parser Name
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Name) -> String -> Parser Name
forall a b. (a -> b) -> a -> b
$ String
"wrong package name: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Text] -> String
forall a. Show a => a -> String
show [Text]
lst


instance Aeson.FromJSONKey Name where
  fromJSONKey :: FromJSONKeyFunction Name
fromJSONKey = (Text -> Parser Name) -> FromJSONKeyFunction Name
forall a. (Text -> Parser a) -> FromJSONKeyFunction a
Aeson.FromJSONKeyTextParser ((Text -> Parser Name) -> FromJSONKeyFunction Name)
-> (Text -> Parser Name) -> FromJSONKeyFunction Name
forall a b. (a -> b) -> a -> b
$ \Text
x ->
    case Text -> Text -> [Text]
Text.splitOn Text
"/" Text
x of
      [Text
author, Text
package] -> Name -> Parser Name
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Parser Name) -> Name -> Parser Name
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Name
Name Text
author Text
package
      [Text]
lst -> String -> Parser Name
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Name) -> String -> Parser Name
forall a b. (a -> b) -> a -> b
$ String
"wrong package name: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Text] -> String
forall a. Show a => a -> String
show [Text]
lst