Registry.hs

{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE BangPatterns, OverloadedStrings #-}
module Deps.Registry
  ( Registry(..)
  , KnownVersions(..)
  , read
  , fetch
  , update
  , latest
  , getVersions
  , getVersions'
  )
  where


import Prelude hiding (read)
import Control.Monad (liftM2)
import Data.Binary (Binary, get, put)
import qualified Data.List as List
import qualified Data.Map.Strict as Map

import qualified Deps.Website as Website
import qualified Elm.Package as Pkg
import qualified Elm.Version as V
import qualified File
import qualified Http
import qualified Json.Decode as D
import qualified Parse.Primitives as P
import qualified Reporting.Exit as Exit
import qualified Stuff


import Lamdera
import qualified Lamdera.Project

-- REGISTRY


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


data KnownVersions =
  KnownVersions
    { _newest :: V.Version
    , _previous :: ![V.Version]
    }



-- READ


read :: Stuff.PackageCache -> IO (Maybe Registry)
read cache =
  File.readBinary (Stuff.registry cache)
    & registryAddLamderaCoreDeps



-- FETCH


fetch :: Http.Manager -> Stuff.PackageCache -> IO (Either Exit.RegistryProblem Registry)
fetch manager cache =
  post manager "/all-packages" allPkgsDecoder $
   lamderaAddCorePackages $
    \versions ->
      do  let size = Map.foldr' addEntry 0 versions
          let registry = Registry size versions
          let path = Stuff.registry cache
          File.writeBinary path registry
          return registry


addEntry :: KnownVersions -> Int -> Int
addEntry (KnownVersions _ vs) count =
  count + 1 + length vs


allPkgsDecoder :: D.Decoder () (Map.Map Pkg.Name KnownVersions)
allPkgsDecoder =
  let
    keyDecoder =
      Pkg.keyDecoder bail

    versionsDecoder =
      D.list (D.mapError (\_ -> ()) V.decoder)

    toKnownVersions versions =
      case List.sortBy (flip compare) versions of
        v:vs -> return (KnownVersions v vs)
        []   -> D.failure ()
  in
  D.dict keyDecoder (toKnownVersions =<< versionsDecoder)



-- UPDATE


update :: Http.Manager -> Stuff.PackageCache -> Registry -> IO (Either Exit.RegistryProblem Registry)
update manager cache oldRegistry@(Registry size packages) =
  post manager ("/all-packages/since/" ++ show size) (D.list newPkgDecoder) $
    \news ->
      case news of
        [] ->
          return oldRegistry

        _:_ ->
          let
            newSize = size + length news
            newPkgs = foldr addNew packages news
            newRegistry = Registry newSize newPkgs
          in
          do  File.writeBinary (Stuff.registry cache) newRegistry
              return newRegistry


addNew :: (Pkg.Name, V.Version) -> Map.Map Pkg.Name KnownVersions -> Map.Map Pkg.Name KnownVersions
addNew (name, version) versions =
  let
    add maybeKnowns =
      case maybeKnowns of
        Just (KnownVersions v vs) ->
          KnownVersions version (v:vs)

        Nothing ->
          KnownVersions version []
  in
  Map.alter (Just . add) name versions



-- NEW PACKAGE DECODER


newPkgDecoder :: D.Decoder () (Pkg.Name, V.Version)
newPkgDecoder =
  D.customString newPkgParser bail


newPkgParser :: P.Parser () (Pkg.Name, V.Version)
newPkgParser =
  do  pkg <- P.specialize (\_ _ _ -> ()) Pkg.parser
      P.word1 0x40 {-@-} bail
      vsn <- P.specialize (\_ _ _ -> ()) V.parser
      return (pkg, vsn)


bail :: row -> col -> ()
bail _ _ =
  ()



-- LATEST


latest :: Http.Manager -> Stuff.PackageCache -> IO (Either Exit.RegistryProblem Registry)
latest manager cache =
  do  maybeOldRegistry <- read cache
      case maybeOldRegistry of
        Just oldRegistry ->
          update manager cache oldRegistry

        Nothing ->
          fetch manager cache



-- GET VERSIONS


getVersions :: Pkg.Name -> Registry -> Maybe KnownVersions
getVersions name (Registry _ versions) =
  Map.lookup name versions


getVersions' :: Pkg.Name -> Registry -> Either [Pkg.Name] KnownVersions
getVersions' name (Registry _ versions) =
  case Map.lookup name versions of
    Just kvs -> Right kvs
    Nothing -> Left $ Pkg.nearbyNames name (Map.keys versions)



-- POST


post :: Http.Manager -> String -> D.Decoder x a -> (a -> IO b) -> IO (Either Exit.RegistryProblem b)
post manager path decoder callback =
  let
    url = Website.route path []
  in
  Http.post manager url [] Exit.RP_Http $
    \body ->
      case D.fromByteString decoder body of
        Right a -> Right <$> callback a
        Left _ -> return $ Left $ Exit.RP_Data url body



-- BINARY


instance Binary Registry where
  get = liftM2 Registry get get
  put (Registry a b) = put a >> put b


instance Binary KnownVersions where
  get = liftM2 KnownVersions get get
  put (KnownVersions a b) = put a >> put b



-- @LAMDERA

{- Slips inbetween the existing HTTP handler and injects lamdera core packages
that aren't published to https://package.elm-lang.org/

Note: cannot extract this package as it depends on types defined in this file
-}
lamderaAddCorePackages :: (Map.Map Pkg.Name KnownVersions -> IO Registry) -> Map.Map Pkg.Name KnownVersions -> IO Registry
lamderaAddCorePackages originalFn versions = do
  overridePackages <- Lamdera.Project.findOverridePackages
  versions
    & Map.union lamderaCoreDeps
    & (\packages ->
      overridePackages
        & fmap (\(pkg, major, minor, patch) -> (pkg, KnownVersions { _newest = V.Version major minor patch, _previous = [] }))
        & Map.fromList
        & Map.union packages
      )
    & originalFn


registryAddLamderaCoreDeps :: IO (Maybe Registry) -> IO (Maybe Registry)
registryAddLamderaCoreDeps registry =
  registry
    & (fmap . fmap) (\r ->
       _versions r
         & Map.union lamderaCoreDeps
         & (\new -> r { _versions = new })
     )


lamderaCoreDeps :: Map.Map Pkg.Name KnownVersions
lamderaCoreDeps =
  Map.fromList
    [ (Lamdera.Project.lamderaCodecs, KnownVersions { _newest = V.Version 1 0 0, _previous = [] })
    , (Lamdera.Project.lamderaCore, KnownVersions { _newest = V.Version 1 0 0, _previous = [] })
    , (Lamdera.Project.lamderaContainers, KnownVersions { _newest = V.Version 1 0 0, _previous = [] })
    , (Lamdera.Project.lamderaProgramTest, KnownVersions { _newest = V.Version 4 0 0, _previous = [ V.Version 1 0 0, V.Version 2 0 0, V.Version 3 0 0 ] })
    , (Lamdera.Project.lamderaWebsocket, KnownVersions { _newest = V.Version 1 0 0, _previous = [] })
    , (Lamdera.Project.lamderaFusion, KnownVersions { _newest = V.Version 1 0 0, _previous = [] })
    ]