{- 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
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
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
Ord)

data Package =
  Package
    { Package -> Name
_name :: !Name
    , Package -> Version
_version :: !Version
    }
    deriving (Package -> Package -> Bool
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
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
Ord)

data Version =
  Version
    { Version -> Word16
_major :: {-# UNPACK #-} !Word16
    , Version -> Word16
_minor :: {-# UNPACK #-} !Word16
    , Version -> Word16
_patch :: {-# UNPACK #-} !Word16
    }
    deriving (Version -> Version -> Bool
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
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
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 (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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
word
      forall a. Int -> (ByteString -> a) -> Get a
readN Int
n forall a. a -> a
id

instance Binary Name where
  get :: Get Name
get =
    forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Text -> Text -> Name
Name
      (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
Text.decodeUtf8 Get ByteString
getUnder256)
      (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 =
    forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Name -> Version -> Package
Package forall t. Binary t => Get t
get forall t. Binary t => Get t
get

  put :: Package -> Put
put (Package Name
name Version
version) =
    do  forall t. Binary t => t -> Put
put Name
name
        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 forall a. Eq a => a -> a -> Bool
== Word8
255
          then 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 forall t. Binary t => Get t
get forall t. Binary t => Get t
get forall t. Binary t => Get t
get
          else
            do  Word16
minor <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (Integral a, Num b) => a -> b
fromIntegral Get Word8
getWord8
                Word16
patch <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (Integral a, Num b) => a -> b
fromIntegral Get Word8
getWord8
                forall (m :: * -> *) a. Monad m => a -> m a
return (Word16 -> Word16 -> Word16 -> Version
Version (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 forall a. Ord a => a -> a -> Bool
< Word16
256 Bool -> Bool -> Bool
&& Word16
minor forall a. Ord a => a -> a -> Bool
< Word16
256 Bool -> Bool -> Bool
&& Word16
patch forall a. Ord a => a -> a -> Bool
< Word16
256 then
      do  Word8 -> Put
putWord8 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
major)
          Word8 -> Put
putWord8 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
minor)
          Word8 -> Put
putWord8 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
patch)
    else
      do  Word8 -> Put
putWord8 Word8
255
          forall t. Binary t => t -> Put
put Word16
major
          forall t. Binary t => t -> Put
put Word16
minor
          forall t. Binary t => t -> Put
put Word16
patch

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

instance Binary Registry where
  get :: Get Registry
get = forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Int -> Map Name KnownVersions -> Registry
Registry forall t. Binary t => Get t
get forall t. Binary t => Get t
get
  put :: Registry -> Put
put (Registry Int
a Map Name KnownVersions
b) = forall t. Binary t => t -> Put
put Int
a forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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 <- forall (m :: * -> *) a. MonadIO m => HttpConfig -> Req a -> m a
Req.runReq HttpConfig
defHttpConfig forall a b. (a -> b) -> a -> b
$
    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" forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
Req./: Text
"all-packages")
    NoReqBody
Req.NoReqBody
    forall a. Proxy (JsonResponse a)
Req.jsonResponse
    forall a. Monoid a => a
mempty
  let packages :: Map Name KnownVersions
packages = Packages -> Map Name KnownVersions
unwrap forall a b. (a -> b) -> a -> b
$ case forall a. FromJSON a => Value -> Result a
Aeson.fromJSON (forall response.
HttpResponse response =>
response -> HttpResponseBody response
Req.responseBody JsonResponse Value
r) of
         Aeson.Error String
s -> forall a. HasCallStack => String -> a
error String
s
         Aeson.Success Packages
val -> Packages
val
      size :: Int
size = 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 forall a. Num a => a -> a -> a
+ Int
1 forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Version]
vs

  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  =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[Version]
versions ->
          case forall a. (a -> a -> Ordering) -> [a] -> [a]
List.sortBy (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Ord a => a -> a -> Ordering
compare) [Version]
versions of
            Version
v:[Version]
vs -> Version -> [Version] -> KnownVersions
KnownVersions Version
v [Version]
vs
            [] -> forall a. HasCallStack => a
undefined
       )

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


instance Aeson.FromJSON Version where
  parseJSON :: Value -> Parser Version
parseJSON = forall a. String -> (Text -> Parser a) -> Value -> Parser a
Aeson.withText String
"string" 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] ->
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Word16 -> Word16 -> Word16 -> Version
Version
                  (forall a. Read a => String -> a
read (Text -> String
Text.unpack Text
major))
                  (forall a. Read a => String -> a
read (Text -> String
Text.unpack Text
minor))
                  (forall a. Read a => String -> a
read (Text -> String
Text.unpack Text
patch))
      [Text]
_ ->
        forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"failure parsing version"


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


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