{-# LANGUAGE BlockArguments #-}

module Hercules.CLI.Nix where

import Control.Concurrent.Async (mapConcurrently)
import Control.Monad.IO.Unlift (unliftIO)
import Data.Has (Has)
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Text as T
import Hercules.API.Agent.Evaluate.EvaluateEvent.InputDeclaration (InputDeclaration (SiblingInput))
import qualified Hercules.API.Agent.Evaluate.EvaluateEvent.InputDeclaration as InputDeclaration
import qualified Hercules.API.Inputs.ImmutableGitInput as API.ImmutableGitInput
import Hercules.API.Projects (getJobSource)
import Hercules.Agent.NixFile (getVirtualValueByPath)
import qualified Hercules.Agent.NixFile.GitSource as GitSource
import Hercules.Agent.NixFile.HerculesCIArgs (CISystems (CISystems), HerculesCIArgs)
import qualified Hercules.Agent.NixFile.HerculesCIArgs as HerculesCIArgs
import Hercules.CLI.Client (HerculesClientEnv, HerculesClientToken, determineDefaultApiBaseUrl, runHerculesClient)
import Hercules.CLI.Common (runAuthenticated)
import Hercules.CLI.Git (getGitRoot, getRef, getRev, getUpstreamURL, guessForgeTypeFromURL)
import Hercules.CLI.Options (scanOption)
import Hercules.CLI.Project (ProjectPath (projectPathProject), getProjectPath, projectPathReadM, projectResourceClientByPath)
import Hercules.CNix (Store)
import Hercules.CNix.Expr as Expr (EvalState, Match (IsAttrs), NixAttrs, RawValue, Value, getAttr, getAttrs, getFlakeFromGit, init, isDerivation, match', toValue, withEvalState, withStore)
import qualified Hercules.CNix.Util as CNix.Util
import qualified Hercules.CNix.Verbosity as CNix.Verbosity
import Options.Applicative as Optparse
import Options.Applicative.Types (unReadM)
import Protolude hiding (evalState)
import RIO (RIO)
import UnliftIO (MonadUnliftIO, UnliftIO (UnliftIO), askUnliftIO)

createHerculesCIArgs :: Maybe Text -> IO HerculesCIArgs
createHerculesCIArgs :: Maybe Text -> IO HerculesCIArgs
createHerculesCIArgs Maybe Text
passedRef = do
  String
gitRoot <- IO String
getGitRoot
  Text
gitRev <- IO Text
getRev
  Text
ref <- Maybe Text -> IO Text
computeRef Maybe Text
passedRef
  Text
upstreamURL <- IO Text
getUpstreamURL
  let remoteHttpUrl :: Maybe Text
remoteHttpUrl = Text
upstreamURL forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text
"http" Text -> Text -> Bool
`T.isPrefixOf` Text
upstreamURL)
      remoteSshUrl :: Maybe Text
remoteSshUrl = Text
upstreamURL forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (Text
"http" Text -> Text -> Bool
`T.isPrefixOf` Text
upstreamURL))
      guessWebUrlFromHttpUrl :: Text -> Text
guessWebUrlFromHttpUrl Text
url = Text -> Text -> Maybe Text
T.stripSuffix Text
".git" Text
url forall a b. a -> (a -> b) -> b
& forall a. a -> Maybe a -> a
fromMaybe Text
url
  let gitSource :: GitSource
gitSource =
        GitSource.GitSource
          { outPath :: Text
outPath = forall a b. ConvertText a b => a -> b
toS String
gitRoot,
            ref :: Text
ref = Text
ref,
            rev :: Text
rev = Text
gitRev,
            shortRev :: Text
shortRev = Text -> Text
GitSource.shortRevFromRev Text
gitRev,
            branch :: Maybe Text
branch = Text -> Maybe Text
GitSource.branchFromRef Text
ref,
            tag :: Maybe Text
tag = Text -> Maybe Text
GitSource.tagFromRef Text
ref,
            remoteHttpUrl :: Maybe Text
remoteHttpUrl = Maybe Text
remoteHttpUrl,
            remoteSshUrl :: Maybe Text
remoteSshUrl = Maybe Text
remoteSshUrl,
            webUrl :: Maybe Text
webUrl = Text -> Text
guessWebUrlFromHttpUrl forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
remoteHttpUrl,
            forgeType :: Maybe Text
forgeType = Text -> Maybe Text
guessForgeTypeFromURL Text
upstreamURL,
            owner :: Maybe Text
owner = forall a. Maybe a
Nothing {- TODO; agent only for now -},
            name :: Maybe Text
name = forall a. Maybe a
Nothing {- TODO; agent only for now -}
          }
  Text
url <- IO Text
determineDefaultApiBaseUrl
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ GitSource -> HerculesCIMeta -> HerculesCIArgs
HerculesCIArgs.fromGitSource GitSource
gitSource HerculesCIArgs.HerculesCIMeta {apiBaseUrl :: Text
apiBaseUrl = Text
url, ciSystems :: CISystems
ciSystems = Maybe (Map Text ()) -> CISystems
CISystems forall a. Maybe a
Nothing}

computeRef :: Maybe Text -> IO Text
computeRef :: Maybe Text -> IO Text
computeRef Maybe Text
Nothing = IO Text
getRef
computeRef (Just Text
passedRef) = forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
passedRef

resolveInputs ::
  (Has HerculesClientToken r, Has HerculesClientEnv r) =>
  UnliftIO (RIO r) ->
  Ptr EvalState ->
  Maybe ProjectPath ->
  Map ByteString InputDeclaration ->
  IO (Value NixAttrs)
resolveInputs :: forall r.
(Has HerculesClientToken r, Has HerculesClientEnv r) =>
UnliftIO (RIO r)
-> Ptr EvalState
-> Maybe ProjectPath
-> Map ByteString InputDeclaration
-> IO (Value NixAttrs)
resolveInputs UnliftIO (RIO r)
uio Ptr EvalState
evalState Maybe ProjectPath
projectMaybe Map ByteString InputDeclaration
inputs = do
  ProjectPath
projectPath <- forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO (RIO r)
uio forall a b. (a -> b) -> a -> b
$ forall r.
(Has HerculesClientToken r, Has HerculesClientEnv r) =>
Maybe ProjectPath -> RIO r ProjectPath
getProjectPath Maybe ProjectPath
projectMaybe
  let resolveInput :: ByteString -> InputDeclaration -> IO RawValue
      resolveInput :: ByteString -> InputDeclaration -> IO RawValue
resolveInput ByteString
_name (SiblingInput SiblingInput
input) = forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO (RIO r)
uio do
        let resourceClient :: ProjectResourceGroup ClientAuth (AsClientT ClientM)
resourceClient = ProjectPath -> ProjectResourceGroup ClientAuth (AsClientT ClientM)
projectResourceClientByPath (ProjectPath
projectPath {projectPathProject :: Text
projectPathProject = SiblingInput -> Text
InputDeclaration.project SiblingInput
input})
            jobNames :: [a]
jobNames = []
        ImmutableGitInput
immutableGitInput <- forall a r.
(NFData a, Has HerculesClientToken r, Has HerculesClientEnv r) =>
(Token -> ClientM a) -> RIO r a
runHerculesClient (forall auth f.
ProjectResourceGroup auth f
-> f
   :- (Summary
         "Get source information from the latest successful job/jobs satisfying the provided requirements."
       :> (Description
             "The job parameter can be omitted to require all jobs for a commit to succeed. This can have the unexpected effect of reverting when a change in the extraInputs causes a regression. So it is recommended to specify one or more jobs. Common examples are \"onPush.default\" for a pinned build or \"onPush.ci\" for a build using extraInputs to integrate continuously."
           :> ("source"
               :> (QueryParam'
                     '[Optional,
                       Description
                         "Constrain the results by git ref, such as refs/heads/my-branch. Defaults to HEAD."]
                     "ref"
                     Text
                   :> (QueryParams "jobs" Text
                       :> (auth :> Get '[JSON] ImmutableGitInput))))))
getJobSource ProjectResourceGroup ClientAuth (AsClientT ClientM)
resourceClient (SiblingInput -> Maybe Text
InputDeclaration.ref SiblingInput
input) forall a. [a]
jobNames)
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Ptr EvalState -> ImmutableGitInput -> IO RawValue
mkImmutableGitInputFlakeThunk Ptr EvalState
evalState ImmutableGitInput
immutableGitInput
      resolveInput ByteString
_name InputDeclaration.BogusInput {} = forall a. HasCallStack => Text -> a
panic Text
"resolveInput: not implemented yet"
  Map ByteString InputDeclaration
inputs
    forall a b. a -> (a -> b) -> b
& forall k a b. (k -> a -> b) -> Map k a -> Map k b
M.mapWithKey (,)
    forall a b. a -> (a -> b) -> b
& forall (t :: * -> *) a b.
Traversable t =>
(a -> IO b) -> t a -> IO (t b)
mapConcurrently (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ByteString -> InputDeclaration -> IO RawValue
resolveInput)
    forall a b. a -> (a -> b) -> b
& (forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a.
ToValue a =>
Ptr EvalState -> a -> IO (Value (NixTypeFor a))
toValue Ptr EvalState
evalState)

refBranchToRef :: Maybe Text -> Maybe Text -> Maybe Text
refBranchToRef :: Maybe Text -> Maybe Text -> Maybe Text
refBranchToRef Maybe Text
ref Maybe Text
branch = Maybe Text
ref forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((Text
"refs/heads/" forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
branch)

withNix :: (MonadUnliftIO m) => (Store -> Ptr EvalState -> m b) -> m b
withNix :: forall (m :: * -> *) b.
MonadUnliftIO m =>
(Store -> Ptr EvalState -> m b) -> m b
withNix Store -> Ptr EvalState -> m b
f = do
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
    IO ()
Expr.init
    IO ()
CNix.Util.installDefaultSigINTHandler
  UnliftIO forall a. m a -> IO a
uio <- forall (m :: * -> *). MonadUnliftIO m => m (UnliftIO m)
askUnliftIO
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadUnliftIO m => (Store -> m a) -> m a
withStore \Store
store -> forall a. Store -> (Ptr EvalState -> IO a) -> IO a
withEvalState Store
store (forall a. m a -> IO a
uio forall b c a. (b -> c) -> (a -> b) -> a -> c
. Store -> Ptr EvalState -> m b
f Store
store)

ciNixAttributeCompleter :: Optparse.Completer
ciNixAttributeCompleter :: Completer
ciNixAttributeCompleter = (Text -> IO [(CompletionItemOptions, Text)]) -> Completer
mkTextCompleter \Text
partial -> do
  forall (m :: * -> *) b.
MonadUnliftIO m =>
(Store -> Ptr EvalState -> m b) -> m b
withNix \Store
_store Ptr EvalState
evalState -> do
    Verbosity -> IO ()
CNix.Verbosity.setVerbosity Verbosity
CNix.Verbosity.Error
    Maybe Text
ref <- do
      Maybe Text
ref <- Text -> IO (Maybe Text)
scanOption Text
"--as-ref"
      Maybe Text
branch <- Text -> IO (Maybe Text)
scanOption Text
"--as-branch"
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Maybe Text -> Maybe Text -> Maybe Text
refBranchToRef Maybe Text
ref Maybe Text
branch
    Maybe ProjectPath
projectMaybe <-
      Text -> IO (Maybe Text)
scanOption Text
"--project" forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Maybe Text
maybeStr -> do
        Text
s <- Maybe Text
maybeStr
        forall l r. Either l r -> Maybe r
rightToMaybe (forall e a. Except e a -> Either e a
runExcept (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall a. ReadM a -> ReaderT String (Except ParseError) a
unReadM ReadM ProjectPath
projectPathReadM) (forall a b. ConvertText a b => a -> b
toS Text
s)))
    HerculesCIArgs
args <- Maybe Text -> IO HerculesCIArgs
createHerculesCIArgs Maybe Text
ref
    let partialComponents :: [Text]
partialComponents = (Char -> Bool) -> Text -> [Text]
T.split (forall a. Eq a => a -> a -> Bool
== Char
'.') Text
partial
        prefix :: [Text]
prefix = forall a. [a] -> [a]
L.init [Text]
partialComponents
        partialComponent :: Text
partialComponent = forall a. [a] -> Maybe a
lastMay [Text]
partialComponents forall a b. a -> (a -> b) -> b
& forall a. a -> Maybe a -> a
fromMaybe Text
""
        prefixStr :: Text
prefixStr = Text -> [Text] -> Text
T.intercalate Text
"." [Text]
prefix
        addPrefix :: Text -> Text
addPrefix Text
x = Text -> [Text] -> Text
T.intercalate Text
"." ([Text]
prefix forall a. Semigroup a => a -> a -> a
<> [Text
x])
    forall b. RIO (HerculesClientToken, HerculesClientEnv) b -> IO b
runAuthenticated do
      UnliftIO (RIO (HerculesClientToken, HerculesClientEnv))
uio <- forall (m :: * -> *). MonadUnliftIO m => m (UnliftIO m)
askUnliftIO
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
        Ptr EvalState
-> String
-> HerculesCIArgs
-> (Map ByteString InputDeclaration -> IO (Value NixAttrs))
-> [ByteString]
-> IO (Maybe RawValue)
getVirtualValueByPath Ptr EvalState
evalState (forall a b. ConvertText a b => a -> b
toS forall a b. (a -> b) -> a -> b
$ GitSource -> Text
GitSource.outPath forall a b. (a -> b) -> a -> b
$ HerculesCIArgs -> GitSource
HerculesCIArgs.primaryRepo HerculesCIArgs
args) HerculesCIArgs
args (forall r.
(Has HerculesClientToken r, Has HerculesClientEnv r) =>
UnliftIO (RIO r)
-> Ptr EvalState
-> Maybe ProjectPath
-> Map ByteString InputDeclaration
-> IO (Value NixAttrs)
resolveInputs UnliftIO (RIO (HerculesClientToken, HerculesClientEnv))
uio Ptr EvalState
evalState Maybe ProjectPath
projectMaybe) (Text -> ByteString
encodeUtf8 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
prefix) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Maybe RawValue
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
          Just RawValue
focusValue -> do
            Ptr EvalState -> RawValue -> IO Match
match' Ptr EvalState
evalState RawValue
focusValue forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              IsAttrs Value NixAttrs
attrset -> do
                Map ByteString RawValue
attrs <- Ptr EvalState -> Value NixAttrs -> IO (Map ByteString RawValue)
getAttrs Ptr EvalState
evalState Value NixAttrs
attrset
                Bool
isDeriv <- Ptr EvalState -> RawValue -> IO Bool
isDerivation Ptr EvalState
evalState RawValue
focusValue
                if Bool
isDeriv
                  then forall (f :: * -> *) a. Applicative f => a -> f a
pure [(forall a. Monoid a => a
mempty {cioFiles :: Bool
Optparse.cioFiles = Bool
False}, Text
prefixStr)]
                  else
                    let matches :: [Text]
matches =
                          Map ByteString RawValue
attrs
                            forall a b. a -> (a -> b) -> b
& forall k a. Map k a -> [k]
M.keys
                            forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map ByteString -> Text
decodeUtf8
                            forall a b. a -> (a -> b) -> b
& forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= Text
"recurseForDerivations")
                            forall a b. a -> (a -> b) -> b
& forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Text -> Bool
T.isPrefixOf Text
partialComponent)
                     in case [Text]
matches of
                          [Text
singleMatch] -> do
                            Maybe RawValue
ma <- Ptr EvalState
-> Value NixAttrs -> ByteString -> IO (Maybe RawValue)
getAttr Ptr EvalState
evalState Value NixAttrs
attrset (Text -> ByteString
encodeUtf8 Text
singleMatch)
                            Bool
matchIsDeriv <-
                              Maybe RawValue
ma
                                forall a b. a -> (a -> b) -> b
& forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Ptr EvalState -> RawValue -> IO Bool
isDerivation Ptr EvalState
evalState)
                                forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall a. a -> Maybe a -> a
fromMaybe Bool
False
                            if Bool
matchIsDeriv
                              then
                                forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
                                  [Text]
matches
                                    forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\Text
match -> (forall a. Monoid a => a
mempty {cioAddSpace :: Bool
Optparse.cioAddSpace = Bool
True, cioFiles :: Bool
Optparse.cioFiles = Bool
False}, Text -> Text
addPrefix Text
match))
                              else
                                forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
                                  [Text]
matches
                                    forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\Text
match -> (forall a. Monoid a => a
mempty {cioAddSpace :: Bool
Optparse.cioAddSpace = Bool
False, cioFiles :: Bool
Optparse.cioFiles = Bool
False}, Text -> Text
addPrefix Text
match forall a. Semigroup a => a -> a -> a
<> Text
"."))
                          [Text]
_ ->
                            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
                              [Text]
matches
                                forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\Text
match -> (forall a. Monoid a => a
mempty {cioAddSpace :: Bool
Optparse.cioAddSpace = Bool
False, cioFiles :: Bool
Optparse.cioFiles = Bool
False}, Text -> Text
addPrefix Text
match))
              Match
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []

attrByPath :: Ptr EvalState -> RawValue -> [ByteString] -> IO (Maybe RawValue)
attrByPath :: Ptr EvalState -> RawValue -> [ByteString] -> IO (Maybe RawValue)
attrByPath Ptr EvalState
_ RawValue
v [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just RawValue
v)
attrByPath Ptr EvalState
evalState RawValue
v (ByteString
a : [ByteString]
as) = do
  Ptr EvalState -> RawValue -> IO Match
match' Ptr EvalState
evalState RawValue
v forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    IsAttrs Value NixAttrs
attrs ->
      Ptr EvalState
-> Value NixAttrs -> ByteString -> IO (Maybe RawValue)
getAttr Ptr EvalState
evalState Value NixAttrs
attrs ByteString
a
        forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\RawValue
attrValue -> Ptr EvalState -> RawValue -> [ByteString] -> IO (Maybe RawValue)
attrByPath Ptr EvalState
evalState RawValue
attrValue [ByteString]
as)
        forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *) a. Monad m => m (m a) -> m a
join
    Match
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

mkTextCompleter :: (Text -> IO [(Optparse.CompletionItemOptions, Text)]) -> Completer
mkTextCompleter :: (Text -> IO [(CompletionItemOptions, Text)]) -> Completer
mkTextCompleter Text -> IO [(CompletionItemOptions, Text)]
f = (String -> IO [CompletionItem]) -> Completer
Optparse.mkCompleterWithOptions (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry CompletionItemOptions -> String -> CompletionItem
CompletionItem forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. ConvertText a b => a -> b
toS)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> IO [(CompletionItemOptions, Text)]
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ConvertText a b => a -> b
toS)

mkImmutableGitInputFlakeThunk :: Ptr EvalState -> API.ImmutableGitInput.ImmutableGitInput -> IO RawValue
mkImmutableGitInputFlakeThunk :: Ptr EvalState -> ImmutableGitInput -> IO RawValue
mkImmutableGitInputFlakeThunk Ptr EvalState
evalState ImmutableGitInput
git = do
  -- TODO: allow picking ssh/http url
  Ptr EvalState -> Text -> Text -> Text -> IO RawValue
getFlakeFromGit
    Ptr EvalState
evalState
    (ImmutableGitInput -> Text
API.ImmutableGitInput.httpURL ImmutableGitInput
git)
    (ImmutableGitInput -> Text
API.ImmutableGitInput.ref ImmutableGitInput
git)
    (ImmutableGitInput -> Text
API.ImmutableGitInput.rev ImmutableGitInput
git)