PackageFetcher.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}

module Config.PackageFetcher (fetcherDecoder, fetcherKeys) where

import Config.Common
import Data.Coerce (coerce)
import Data.Foldable (asum)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Generics (Generic)
import Lens.Micro
import NvFetcher.NixFetcher
import NvFetcher.Types
import NvFetcher.Types.Lens
import TOML

fetcherDecoder :: Decoder PackageFetcher
fetcherDecoder =
  asum
    [ gitHubDecoder,
      pypiDecoder,
      openVsxDecoder,
      vscodeMarketplaceDecoder,
      gitDecoder,
      urlDecoder,
      tarballDecoder,
      dockerDecoder
    ]

fetcherKeys :: [Text]
fetcherKeys =
  [ "github",
    "pypi",
    "openvsx",
    "vsmarketplace",
    "git",
    "url",
    "tarball",
    "docker"
  ]

--------------------------------------------------------------------------------

data GitOptions = GitOptions
  { goDeepClone :: Maybe Bool,
    goFetchSubmodules :: Maybe Bool,
    goLeaveDotGit :: Maybe Bool
  }
  deriving (Eq, Generic)

gitOptionsDecoder :: Decoder GitOptions
gitOptionsDecoder =
  GitOptions
    <$> getFieldsOpt ["git", "deepClone"]
    <*> getFieldsOpt ["git", "fetchSubmodules"]
    <*> getFieldsOpt ["git", "leaveDotGit"]

_GitOptions :: Traversal' (NixFetcher f) GitOptions
_GitOptions f x@FetchGit {..} =
  ( \GitOptions {..} ->
      x
        & deepClone .~ fromMaybe False goDeepClone
        & fetchSubmodules .~ fromMaybe False goFetchSubmodules
        & leaveDotGit .~ fromMaybe False goLeaveDotGit
  )
    <$> f (GitOptions (Just _deepClone) (Just _fetchSubmodules) (Just _leaveDotGit))
_GitOptions f x@FetchGitHub {..} =
  ( \GitOptions {..} ->
      x
        & deepClone .~ fromMaybe False goDeepClone
        & fetchSubmodules .~ fromMaybe False goFetchSubmodules
        & leaveDotGit .~ fromMaybe False goLeaveDotGit
  )
    <$> f (GitOptions (Just _deepClone) (Just _fetchSubmodules) (Just _leaveDotGit))
_GitOptions _ x = pure x

--------------------------------------------------------------------------------

gitHubDecoder :: Decoder PackageFetcher
gitHubDecoder = do
  (owner, repo) <- getFieldsWith githubDecoder ["fetch", "github"]
  gitOptions <- gitOptionsDecoder
  pure $ \v -> gitHubFetcher (owner, repo) v & _GitOptions .~ gitOptions

--------------------------------------------------------------------------------

gitDecoder :: Decoder PackageFetcher
gitDecoder = do
  url <- getFields ["fetch", "git"]
  gitOptions <- gitOptionsDecoder
  pure $ \v -> gitFetcher url v & _GitOptions .~ gitOptions

--------------------------------------------------------------------------------

pypiDecoder :: Decoder PackageFetcher
pypiDecoder = pypiFetcher <$> getFields ["fetch", "pypi"]

--------------------------------------------------------------------------------

openVsxDecoder :: Decoder PackageFetcher
openVsxDecoder = openVsxFetcher <$> getFieldsWith vscodeExtensionDecoder ["fetch", "openvsx"]

--------------------------------------------------------------------------------

vscodeMarketplaceDecoder :: Decoder PackageFetcher
vscodeMarketplaceDecoder = vscodeMarketplaceFetcher <$> getFieldsWith vscodeExtensionDecoder ["fetch", "vsmarketplace"]

--------------------------------------------------------------------------------

urlDecoder :: Decoder PackageFetcher
urlDecoder = do
  url <- getFields ["fetch", "url"]
  pure $ \(coerce -> v) -> urlFetcher $ T.replace "$ver" v url

--------------------------------------------------------------------------------

tarballDecoder :: Decoder PackageFetcher
tarballDecoder = do
  url <- getFields ["fetch", "tarball"]
  pure $ \(coerce -> v) -> tarballFetcher $ T.replace "$ver" v url

--------------------------------------------------------------------------------

dockerDecoder :: Decoder PackageFetcher
dockerDecoder =
  (\f (coerce -> v) -> f & imageTag .~ v)
    <$> ( FetchDocker
            <$> getFields ["fetch", "docker"]
            <*> pure "" -- set in fmap
            <*> pure ()
            <*> pure ()
            <*> getFieldsOpt ["docker", "os"]
            <*> getFieldsOpt ["docker", "arch"]
            <*> getFieldsOpt ["docker", "finalImageName"]
            <*> getFieldsOpt ["docker", "finalImageTag"]
            <*> getFieldsOpt ["docker", "tlsVerify"]
        )