{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}

module Niv.GitHub.Cmd
  ( githubCmd,
  )
where

import Control.Applicative
import Data.Aeson ((.=))
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Key as K
import qualified Data.Aeson.KeyMap as KM
import Data.Bifunctor
import qualified Data.ByteString.Char8 as B8
import Data.Char (isAlphaNum)
import Data.Maybe
import Data.String.QQ (s)
import qualified Data.Text as T
import Data.Text.Extended
import Niv.Cmd
import Niv.GitHub
import Niv.GitHub.API
import Niv.Sources
import Niv.Update
import qualified Options.Applicative as Opts
import qualified Options.Applicative.Help.Pretty as Opts
import System.Exit (ExitCode (ExitSuccess))
import System.Process (readProcessWithExitCode)

githubCmd :: Cmd
githubCmd :: Cmd
githubCmd =
  Cmd
    { description :: forall a. InfoMod a
description = forall a. InfoMod a
describeGitHub,
      parseCmdShortcut :: Text -> Maybe (PackageName, Object)
parseCmdShortcut = Text -> Maybe (PackageName, Object)
parseAddShortcutGitHub,
      parsePackageSpec :: Parser PackageSpec
parsePackageSpec = Parser PackageSpec
parseGitHubPackageSpec,
      updateCmd :: Update () ()
updateCmd = Update () ()
githubUpdate',
      name :: Text
name = Text
"github",
      extraLogs :: Attrs -> [Text]
extraLogs = forall a b. a -> b -> a
const []
      -- TODO: here filter by type == tarball or file or builtin-
    }

parseGitHubPackageSpec :: Opts.Parser PackageSpec
parseGitHubPackageSpec :: Parser PackageSpec
parseGitHubPackageSpec =
  (Object -> PackageSpec
PackageSpec forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. [(Key, v)] -> KeyMap v
KM.fromList)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser (Key, Value)
parseAttribute
  where
    parseAttribute :: Opts.Parser (K.Key, Aeson.Value)
    parseAttribute :: Parser (Key, Value)
parseAttribute =
      forall a. ReadM a -> Mod OptionFields a -> Parser a
Opts.option
        (forall a. (String -> Maybe a) -> ReadM a
Opts.maybeReader String -> Maybe (Key, Value)
parseKeyValJSON)
        ( forall (f :: * -> *) a. HasName f => String -> Mod f a
Opts.long String
"attribute"
            forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => Char -> Mod f a
Opts.short Char
'a'
            forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
Opts.metavar String
"KEY=VAL"
            forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
Opts.help String
"Set the package spec attribute <KEY> to <VAL>, where <VAL> may be JSON."
        )
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. ReadM a -> Mod OptionFields a -> Parser a
Opts.option
          (forall a. (String -> Maybe a) -> ReadM a
Opts.maybeReader ((String -> Value) -> String -> Maybe (Key, Value)
parseKeyVal forall a. ToJSON a => a -> Value
Aeson.toJSON))
          ( forall (f :: * -> *) a. HasName f => String -> Mod f a
Opts.long String
"string-attribute"
              forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => Char -> Mod f a
Opts.short Char
's'
              forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
Opts.metavar String
"KEY=VAL"
              forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
Opts.help String
"Set the package spec attribute <KEY> to <VAL>."
          )
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (Key, Value)
shortcutAttributes
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ( ((Key
"url_template",) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value
Aeson.String)
                forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. IsString s => Mod OptionFields s -> Parser s
Opts.strOption
                  ( forall (f :: * -> *) a. HasName f => String -> Mod f a
Opts.long String
"template"
                      forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => Char -> Mod f a
Opts.short Char
't'
                      forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
Opts.metavar String
"URL"
                      forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
Opts.help String
"Used during 'update' when building URL. Occurrences of <foo> are replaced with attribute 'foo'."
                  )
            )
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ( ((Key
"type",) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value
Aeson.String)
                forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. IsString s => Mod OptionFields s -> Parser s
Opts.strOption
                  ( forall (f :: * -> *) a. HasName f => String -> Mod f a
Opts.long String
"type"
                      forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => Char -> Mod f a
Opts.short Char
'T'
                      forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
Opts.metavar String
"TYPE"
                      forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
Opts.help String
"The type of the URL target. The value can be either 'file' or 'tarball'. If not set, the value is inferred from the suffix of the URL."
                  )
            )
    parseKeyValJSON :: String -> Maybe (Key, Value)
parseKeyValJSON = (String -> Value) -> String -> Maybe (Key, Value)
parseKeyVal forall a b. (a -> b) -> a -> b
$ \String
x ->
      forall a. a -> Maybe a -> a
fromMaybe (forall a. ToJSON a => a -> Value
Aeson.toJSON String
x) (forall a. FromJSON a => ByteString -> Maybe a
Aeson.decodeStrict (String -> ByteString
B8.pack String
x))
    -- Parse "key=val" into ("key", val)
    parseKeyVal ::
      -- how to convert to JSON
      (String -> Aeson.Value) ->
      String ->
      Maybe (K.Key, Aeson.Value)
    parseKeyVal :: (String -> Value) -> String -> Maybe (Key, Value)
parseKeyVal String -> Value
toJSON String
str = case forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall a. Eq a => a -> a -> Bool
/= Char
'=') String
str of
      (String
key, Char
'=' : String
val) -> forall a. a -> Maybe a
Just (String -> Key
K.fromString String
key, String -> Value
toJSON String
val)
      (String, String)
_ -> forall a. Maybe a
Nothing
    -- Shortcuts for common attributes
    shortcutAttributes :: Opts.Parser (K.Key, Aeson.Value)
    shortcutAttributes :: Parser (Key, Value)
shortcutAttributes =
      forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) forall (f :: * -> *) a. Alternative f => f a
empty forall a b. (a -> b) -> a -> b
$
        Text -> Parser (Key, Value)
mkShortcutAttribute
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text
"branch", Text
"owner", Text
"rev", Text
"version"]
    -- TODO: infer those shortcuts from 'Update' keys
    mkShortcutAttribute :: T.Text -> Opts.Parser (K.Key, Aeson.Value)
    mkShortcutAttribute :: Text -> Parser (Key, Value)
mkShortcutAttribute = \case
      attr :: Text
attr@(Text -> Maybe (Char, Text)
T.uncons -> Just (Char
c, Text
_)) ->
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Text -> Value
Aeson.String) forall a b. (a -> b) -> a -> b
$
          (Text -> Key
K.fromText Text
attr,)
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. IsString s => Mod OptionFields s -> Parser s
Opts.strOption
              ( forall (f :: * -> *) a. HasName f => String -> Mod f a
Opts.long (Text -> String
T.unpack Text
attr)
                  forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => Char -> Mod f a
Opts.short Char
c
                  forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
Opts.metavar (Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ Text -> Text
T.toUpper Text
attr)
                  forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
Opts.help
                    ( Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$
                        Text
"Equivalent to --attribute "
                          forall a. Semigroup a => a -> a -> a
<> Text
attr
                          forall a. Semigroup a => a -> a -> a
<> Text
"=<"
                          forall a. Semigroup a => a -> a -> a
<> (Text -> Text
T.toUpper Text
attr)
                          forall a. Semigroup a => a -> a -> a
<> Text
">"
                    )
              )
      Text
_ -> forall (f :: * -> *) a. Alternative f => f a
empty

describeGitHub :: Opts.InfoMod a
describeGitHub :: forall a. InfoMod a
describeGitHub =
  forall a. Monoid a => [a] -> a
mconcat
    [ forall a. InfoMod a
Opts.fullDesc,
      forall a. String -> InfoMod a
Opts.progDesc String
"Add a GitHub dependency",
      forall a. Maybe Doc -> InfoMod a
Opts.headerDoc forall a b. (a -> b) -> a -> b
$
        forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
          Doc
"Examples:"
            Doc -> Doc -> Doc
Opts.<$$> Doc
""
            Doc -> Doc -> Doc
Opts.<$$> Doc
"  niv add stedolan/jq"
            Doc -> Doc -> Doc
Opts.<$$> Doc
"  niv add NixOS/nixpkgs -n nixpkgs -b nixpkgs-unstable"
            Doc -> Doc -> Doc
Opts.<$$> Doc
"  niv add my-package -v alpha-0.1 -t http://example.com/archive/<version>.zip"
    ]

-- parse a github shortcut of the form "owner/repo"
parseAddShortcutGitHub :: T.Text -> Maybe (PackageName, Aeson.Object)
parseAddShortcutGitHub :: Text -> Maybe (PackageName, Object)
parseAddShortcutGitHub Text
str =
  -- parses a string "owner/repo" into package name (repo) and spec (owner +
  -- repo)
  case (Char -> Bool) -> Text -> (Text, Text)
T.span (forall a. Eq a => a -> a -> Bool
/= Char
'/') Text
str of
    ( owner :: Text
owner@(Text -> Bool
T.null -> Bool
False),
      Text -> Maybe (Char, Text)
T.uncons -> Just (Char
'/', repo :: Text
repo@(Text -> Bool
T.null -> Bool
False))
      ) ->
        forall a. a -> Maybe a
Just
          ( Text -> PackageName
PackageName Text
repo,
            forall v. [(Key, v)] -> KeyMap v
KM.fromList [Key
"owner" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
owner, Key
"repo" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
repo]
          )
    -- XXX: this should be "Nothing" but for the time being we keep
    -- backwards compatibility with "niv add foo" adding "foo" as a
    -- package name.
    (Text, Text)
_ -> forall a. a -> Maybe a
Just (Text -> PackageName
PackageName Text
str, forall v. KeyMap v
KM.empty)

-- | The IO (real) github update
githubUpdate' :: Update () ()
githubUpdate' :: Update () ()
githubUpdate' = (Bool -> Text -> IO Text)
-> (Text -> Text -> Text -> IO Text)
-> (Text -> Text -> IO GithubRepo)
-> Update () ()
githubUpdate Bool -> Text -> IO Text
nixPrefetchURL Text -> Text -> Text -> IO Text
githubLatestRev Text -> Text -> IO GithubRepo
githubRepo

nixPrefetchURL :: Bool -> T.Text -> IO T.Text
nixPrefetchURL :: Bool -> Text -> IO Text
nixPrefetchURL Bool
unpack turl :: Text
turl@(Text -> String
T.unpack -> String
url) = do
  (ExitCode
exitCode, String
sout, String
serr) <- IO (ExitCode, String, String)
runNixPrefetch
  case (ExitCode
exitCode, String -> [String]
lines String
sout) of
    (ExitCode
ExitSuccess, String
l : [String]
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
l
    (ExitCode, [String])
_ -> forall a. [Text] -> Text -> Text -> IO a
abortNixPrefetchExpectedOutput (String -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
args) (String -> Text
T.pack String
sout) (String -> Text
T.pack String
serr)
  where
    args :: [String]
args = (if Bool
unpack then [String
"--unpack"] else []) forall a. Semigroup a => a -> a -> a
<> [String
url, String
"--name", Text -> String
sanitizeName Text
basename]
    runNixPrefetch :: IO (ExitCode, String, String)
runNixPrefetch = String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode String
"nix-prefetch-url" [String]
args String
""
    sanitizeName :: Text -> String
sanitizeName = Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
T.filter Char -> Bool
isOk
    basename :: Text
basename = forall a. [a] -> a
last forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
T.splitOn Text
"/" Text
turl
    -- From the nix-prefetch-url documentation:
    --  Path names are alphanumeric and can include the symbols +-._?= and must
    --  not begin with a period.
    -- (note: we assume they don't begin with a period)
    isOk :: Char -> Bool
isOk = \Char
c -> Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| (Char -> Bool) -> Text -> Bool
T.any (Char
c forall a. Eq a => a -> a -> Bool
==) Text
"+-._?="

abortNixPrefetchExpectedOutput :: [T.Text] -> T.Text -> T.Text -> IO a
abortNixPrefetchExpectedOutput :: forall a. [Text] -> Text -> Text -> IO a
abortNixPrefetchExpectedOutput [Text]
args Text
sout Text
serr =
  forall (io :: * -> *) a. MonadIO io => Text -> io a
abort forall a b. (a -> b) -> a -> b
$
    [s|
Could not read the output of 'nix-prefetch-url'. This is a bug. Please create a
ticket:

  https://github.com/nmattia/niv/issues/new

Thanks! I'll buy you a beer.
|]
      forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unlines [Text
"command: ", Text
"nix-prefetch-url" forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unwords [Text]
args, Text
"stdout: ", Text
sout, Text
"stderr: ", Text
serr]