{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}

-- | This module contains the logic to load the dhall configuration
module Podenv.Config
  ( load,
    decodeExpr,
    select,
    Config (..),
    Atom (..),
    ApplicationRecord (..),
    defaultConfigPath,
    defaultApp,
    loadSystem,
    defaultSystemConfig,
    podenvImportTxt,
  )
where

import Control.Exception (bracket_)
import Data.Digest.Pure.SHA qualified as SHA
import Data.Either.Validation
import Data.Text qualified as Text
import Data.Text.IO qualified as Text (readFile)
import Dhall qualified
import Dhall.Core qualified as Dhall
import Dhall.Import qualified
import Dhall.Map qualified as DM
import Dhall.Marshal.Decode (DhallErrors (..), extractError)
import Dhall.Parser qualified
import Dhall.Src qualified
import Podenv.Dhall hiding (name)
import Podenv.Prelude
import System.Directory
import System.Environment (setEnv, unsetEnv)
import System.FilePath.Posix (dropExtension, isExtensionOf, splitPath)
import Text.Show qualified

data Config
  = -- | A standalone application, e.g. defaultSelector
    ConfigDefault ApplicationRecord
  | -- | A single application
    ConfigApplication Atom
  | -- | A collection of applications
    ConfigApplications [(Text, Atom)]

data Atom
  = -- | A literal application
    Lit ApplicationRecord
  | -- | A paremeterized application
    LamArg ArgName (Text -> ApplicationRecord)
  | LamArg2 ArgName ArgName (Text -> Text -> ApplicationRecord)
  | -- | A functional application
    LamApp (Application -> ApplicationRecord)

-- | A wrapper around the true Application type to manage weakly typed configuration
-- (e.g. so that `{ runtime.image = "ubi8" }` can be manually decoded)
newtype ApplicationRecord = ApplicationRecord {ApplicationRecord -> Application
unRecord :: Application}

instance Dhall.FromDhall ApplicationRecord where
  autoWith :: InputNormalizer -> Decoder ApplicationRecord
autoWith = Decoder ApplicationRecord
-> InputNormalizer -> Decoder ApplicationRecord
forall a b. a -> b -> a
const Decoder ApplicationRecord
appRecordDecoder

newtype ArgName = ArgName Text

instance Text.Show.Show ArgName where
  show :: ArgName -> String
show (ArgName Text
n) = Text -> String
forall a. ToString a => a -> String
toString Text
n

-- | Config load entrypoint
load :: Maybe Text -> Maybe Text -> IO Config
load :: Maybe Text -> Maybe Text -> IO Config
load Maybe Text
selectorM Maybe Text
configTxt = case Maybe Text
selectorM Maybe Text -> (Text -> Maybe Application) -> Maybe Application
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Application
defaultSelector of
  Just Application
c -> Config -> IO Config
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Config -> IO Config) -> Config -> IO Config
forall a b. (a -> b) -> a -> b
$ ApplicationRecord -> Config
ConfigDefault (Application -> ApplicationRecord
ApplicationRecord Application
c)
  Maybe Application
Nothing -> DhallExpr -> Config
decodeExpr (DhallExpr -> Config)
-> (DhallExpr -> DhallExpr) -> DhallExpr -> Config
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DhallExpr -> DhallExpr
forall a s t. Eq a => Expr s a -> Expr t a
Dhall.normalize (DhallExpr -> Config) -> IO DhallExpr -> IO Config
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text -> IO DhallExpr
loadExpr Maybe Text
configTxt

defaultSelector :: Text -> Maybe Application
defaultSelector :: Text -> Maybe Application
defaultSelector Text
s
  | Text
"image:" Text -> Text -> Bool
`Text.isPrefixOf` Text
s = Text -> Maybe Application
imageApp Text
s
  | Text
"nix:" Text -> Text -> Bool
`Text.isPrefixOf` Text
s = Text -> Maybe Application
nixApp Text
s
  | Text
"nixpkgs#" Text -> Text -> Bool
`Text.isPrefixOf` Text
s = Text -> Maybe Application
nixApp' Text
s
  | Text
"rootfs:" Text -> Text -> Bool
`Text.isPrefixOf` Text
s = Text -> Maybe Application
rootfsApp Text
s
  | Bool
otherwise = Maybe Application
forall a. Maybe a
Nothing
  where
    imageApp :: Text -> Maybe Application
imageApp Text
x = Text -> Runtime -> Maybe Application
mkApp (Text
"image-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
mkName Text
x) (Text -> Runtime
Image (Text -> Runtime) -> Text -> Runtime
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
Text.drop (Text -> Int
Text.length Text
"image:") Text
x)
    nixApp' :: Text -> Maybe Application
nixApp' Text
x = Text -> Runtime -> Maybe Application
mkApp (Text
"nix-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
mkName Text
x) (Flakes -> Runtime
Nix (Flakes -> Runtime) -> Flakes -> Runtime
forall a b. (a -> b) -> a -> b
$ [Text] -> Maybe Text -> Flakes
Flakes [Text
x] Maybe Text
forall a. Maybe a
Nothing)
    nixApp :: Text -> Maybe Application
nixApp Text
x = Text -> Maybe Application
nixApp' (Text -> Maybe Application) -> Text -> Maybe Application
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
Text.drop (Text -> Int
Text.length Text
"nix:") Text
x
    rootfsApp :: Text -> Maybe Application
rootfsApp Text
x = Text -> Runtime -> Maybe Application
mkApp (Text
"rootfs-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
mkName Text
x) (Text -> Runtime
Rootfs (Text -> Runtime) -> Text -> Runtime
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
Text.drop (Text -> Int
Text.length Text
"rootfs:") Text
x)
    mkApp :: Text -> Runtime -> Maybe Application
mkApp Text
name Runtime
runtime' = Application -> Maybe Application
forall a. a -> Maybe a
Just (Application -> Maybe Application)
-> Application -> Maybe Application
forall a b. (a -> b) -> a -> b
$ Application
defaultApp Application -> (Application -> Application) -> Application
forall a b. a -> (a -> b) -> b
& ((Text -> Identity Text) -> Application -> Identity Application
forall (f :: * -> *).
Functor f =>
(Text -> f Text) -> Application -> f Application
appName ((Text -> Identity Text) -> Application -> Identity Application)
-> Text -> Application -> Application
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
name) (Application -> Application)
-> (Application -> Application) -> Application -> Application
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Runtime -> Identity Runtime)
-> Application -> Identity Application
forall (f :: * -> *).
Functor f =>
(Runtime -> f Runtime) -> Application -> f Application
appRuntime ((Runtime -> Identity Runtime)
 -> Application -> Identity Application)
-> Runtime -> Application -> Application
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Runtime
runtime')
    mkName :: Text -> Text
mkName = Int -> Text -> Text
Text.take Int
6 (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. ToText a => a -> Text
toText (String -> Text) -> (Text -> String) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Digest SHA1State -> String
forall t. Digest t -> String
SHA.showDigest (Digest SHA1State -> String)
-> (Text -> Digest SHA1State) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Digest SHA1State
SHA.sha1 (ByteString -> Digest SHA1State)
-> (Text -> ByteString) -> Text -> Digest SHA1State
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8

-- | Inject the package.dhall into the environ so that config can use `env:PODENV`
loadWithEnv :: FilePath -> Dhall.Expr Dhall.Src.Src Dhall.Import -> IO DhallExpr
loadWithEnv :: String -> Expr Src Import -> IO DhallExpr
loadWithEnv String
baseDir Expr Src Import
expr = IO DhallExpr -> IO DhallExpr
forall c. IO c -> IO c
withEnv (IO DhallExpr -> IO DhallExpr) -> IO DhallExpr -> IO DhallExpr
forall a b. (a -> b) -> a -> b
$ (StateT Status IO DhallExpr -> Status -> IO DhallExpr)
-> Status -> StateT Status IO DhallExpr -> IO DhallExpr
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT Status IO DhallExpr -> Status -> IO DhallExpr
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT Status
initialState (StateT Status IO DhallExpr -> IO DhallExpr)
-> StateT Status IO DhallExpr -> IO DhallExpr
forall a b. (a -> b) -> a -> b
$ Expr Src Import -> StateT Status IO DhallExpr
Dhall.Import.loadWith Expr Src Import
expr
  where
    -- Set the PODENV environment variable to the frozen url of the current hub
    withEnv :: IO c -> IO c
withEnv = IO () -> IO () -> IO c -> IO c
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (String -> String -> IO ()
setEnv String
"PODENV" (Text -> String
forall a. ToString a => a -> String
toString Text
podenvImportTxt)) (String -> IO ()
unsetEnv String
"PODENV")
    -- Then use a custom Dhall.Import.Status state that inject the static code
    -- The goal is to only pretty print (text encode) the package when the cache is cold
    initialState :: Status
initialState = Status
baseStatus Status -> (Status -> Status) -> Status
forall a b. a -> (a -> b) -> b
& LensLike' Identity Status (URL -> StateT Status IO Text)
forall (f :: * -> *).
Functor f =>
LensLike' f Status (URL -> StateT Status IO Text)
Dhall.Import.remote LensLike' Identity Status (URL -> StateT Status IO Text)
-> (URL -> StateT Status IO Text) -> Status -> Status
forall s t a b. ASetter s t a b -> b -> s -> t
.~ URL -> StateT Status IO Text
fetchUrl
    baseStatus :: Status
baseStatus = String -> Status
Dhall.Import.emptyStatus String
baseDir
    fetchUrl :: URL -> StateT Status IO Text
fetchUrl URL
url
      | URL
url URL -> URL -> Bool
forall a. Eq a => a -> a -> Bool
== URL
podenvUrl = Text -> StateT Status IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr Void Void -> Text
forall a. Pretty a => a -> Text
Dhall.pretty Expr Void Void
podenvPackage)
      | Bool
otherwise = (Status
baseStatus Status
-> FoldLike
     (URL -> StateT Status IO Text)
     Status
     Status
     (URL -> StateT Status IO Text)
     (URL -> StateT Status IO Text)
-> URL
-> StateT Status IO Text
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike
  (URL -> StateT Status IO Text)
  Status
  Status
  (URL -> StateT Status IO Text)
  (URL -> StateT Status IO Text)
forall (f :: * -> *).
Functor f =>
LensLike' f Status (URL -> StateT Status IO Text)
Dhall.Import.remote) URL
url

-- | Helper function to parse the initial configuration
loadExpr :: Maybe Text -> IO DhallExpr
loadExpr :: Maybe Text -> IO DhallExpr
loadExpr Maybe Text
configM = case Maybe Text
configM of
  Just Text
configTxt -> do
    String
cwd' <- IO String
getCurrentDirectory
    String -> Expr Src Import -> IO DhallExpr
loadWithEnv String
cwd' (Expr Src Import -> IO DhallExpr)
-> Expr Src Import -> IO DhallExpr
forall a b. (a -> b) -> a -> b
$ Text -> Expr Src Import
exprFromText' Text
configTxt
  Maybe Text
Nothing -> do
    String
baseDir <- IO String
getConfigDir
    let configPath :: String
configPath = String
baseDir String -> ShowS
</> String
"config.dhall"

    -- load main config
    Text
configContent <-
      IO Text -> IO Text -> Bool -> IO Text
forall a. a -> a -> Bool -> a
bool (Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"(env:PODENV).Hub") (String -> IO Text
Text.readFile String
configPath) (Bool -> IO Text) -> IO Bool -> IO Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO Bool
doesFileExist String
configPath
    let configExpr :: Expr Src Import
configExpr = Text -> Expr Src Import
exprFromText' Text
configContent

    -- lookup local.d configs
    let locald :: String
locald = String
baseDir String -> ShowS
</> String
"local.d"
    [String]
localFiles <- IO [String] -> IO [String] -> Bool -> IO [String]
forall a. a -> a -> Bool -> a
bool ([String] -> IO [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) (String -> IO [String]
listDirectory String
locald) (Bool -> IO [String]) -> IO Bool -> IO [String]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO Bool
doesPathExist String
locald
    let localConfig :: Expr Src Import
localConfig = String -> [String] -> Expr Src Import
createLocalRecord String
locald [String]
localFiles

    -- adds local.d to the main config using the `//` operator
    let expr' :: Expr Src Import
expr' = Maybe CharacterSet
-> PreferAnnotation Src Import
-> Expr Src Import
-> Expr Src Import
-> Expr Src Import
forall s a.
Maybe CharacterSet
-> PreferAnnotation s a -> Expr s a -> Expr s a -> Expr s a
Dhall.Prefer Maybe CharacterSet
forall a. Maybe a
Nothing PreferAnnotation Src Import
forall s a. PreferAnnotation s a
Dhall.PreferFromSource Expr Src Import
configExpr Expr Src Import
localConfig
    String -> Expr Src Import -> IO DhallExpr
loadWithEnv String
baseDir Expr Src Import
expr'
  where
    exprFromText' :: Text -> Dhall.Expr Dhall.Src.Src Dhall.Import
    exprFromText' :: Text -> Expr Src Import
exprFromText' Text
configTxt = case String -> Text -> Either ParseError (Expr Src Import)
Dhall.Parser.exprFromText String
"<config>" Text
configTxt of
      Right Expr Src Import
expr -> Expr Src Import
expr
      Left ParseError
e -> Text -> Expr Src Import
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> Expr Src Import) -> Text -> Expr Src Import
forall a b. (a -> b) -> a -> b
$ Text
"Invalid config: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ParseError -> Text
forall b a. (Show a, IsString b) => a -> b
show ParseError
e

-- | Create a record for local.d config
createLocalRecord :: FilePath -> [FilePath] -> Dhall.Expr Dhall.Src.Src Dhall.Import
createLocalRecord :: String -> [String] -> Expr Src Import
createLocalRecord String
baseDir =
  Map Text (RecordField Src Import) -> Expr Src Import
forall s a. Map Text (RecordField s a) -> Expr s a
Dhall.RecordLit (Map Text (RecordField Src Import) -> Expr Src Import)
-> ([String] -> Map Text (RecordField Src Import))
-> [String]
-> Expr Src Import
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, RecordField Src Import)]
-> Map Text (RecordField Src Import)
forall l. IsList l => [Item l] -> l
fromList ([(Text, RecordField Src Import)]
 -> Map Text (RecordField Src Import))
-> ([String] -> [(Text, RecordField Src Import)])
-> [String]
-> Map Text (RecordField Src Import)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> (Text, RecordField Src Import))
-> [String] -> [(Text, RecordField Src Import)]
forall a b. (a -> b) -> [a] -> [b]
map String -> (Text, RecordField Src Import)
toRecord ([String] -> [(Text, RecordField Src Import)])
-> ([String] -> [String])
-> [String]
-> [(Text, RecordField Src Import)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
isExtensionOf String
".dhall")
  where
    toRecord :: FilePath -> (Text, Dhall.RecordField Dhall.Src.Src Dhall.Import)
    toRecord :: String -> (Text, RecordField Src Import)
toRecord String
name = (String -> Text
forall a. ToText a => a -> Text
toText (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ShowS
dropExtension String
name, Expr Src Import -> RecordField Src Import
forall s a. Expr s a -> RecordField s a
Dhall.makeRecordField (Import -> Expr Src Import
forall s a. a -> Expr s a
Dhall.Embed (Import -> Expr Src Import) -> Import -> Expr Src Import
forall a b. (a -> b) -> a -> b
$ String -> Import
toImport String
name))
    toImport :: FilePath -> Dhall.Import
    toImport :: String -> Import
toImport String
name =
      let file :: File
file = Directory -> Text -> File
Dhall.File ([Text] -> Directory
Dhall.Directory ([Text] -> Directory) -> [Text] -> Directory
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
forall a. ToText a => a -> Text
toText ([String] -> [Text]) -> [String] -> [Text]
forall a b. (a -> b) -> a -> b
$ String -> [String]
splitPath String
baseDir) (String -> Text
forall a. ToText a => a -> Text
toText String
name)
       in ImportHashed -> ImportMode -> Import
Dhall.Import (Maybe SHA256Digest -> ImportType -> ImportHashed
Dhall.ImportHashed Maybe SHA256Digest
forall a. Maybe a
Nothing (FilePrefix -> File -> ImportType
Dhall.Local FilePrefix
Dhall.Absolute File
file)) ImportMode
Dhall.Code

-- | The static hub package expression
podenvUrl :: Dhall.URL
podenvUrl :: URL
podenvUrl =
  Scheme
-> Text -> File -> Maybe Text -> Maybe (Expr Src Import) -> URL
Dhall.URL Scheme
Dhall.HTTPS Text
"raw.githubusercontent.com" File
path Maybe Text
forall a. Maybe a
Nothing Maybe (Expr Src Import)
forall a. Maybe a
Nothing
  where
    hubVersion :: Text
hubVersion = case Decoder Text -> DhallExpr -> Extractor Src Void Text
forall a. Decoder a -> DhallExpr -> Extractor Src Void a
Dhall.extract Decoder Text
forall a. FromDhall a => Decoder a
Dhall.auto (Expr Void Void -> DhallExpr
forall a s. Expr Void a -> Expr s a
Dhall.renote Expr Void Void
hubCommit) of
      Success Text
x -> Int -> Text -> Text
Text.dropEnd Int
1 Text
x
      Failure ExtractErrors Src Void
v -> Text -> Text
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
"Unknown hub commit: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ExtractErrors Src Void -> Text
forall b a. (Show a, IsString b) => a -> b
show ExtractErrors Src Void
v
    path :: File
path = Directory -> Text -> File
Dhall.File ([Text] -> Directory
Dhall.Directory [Text
hubVersion, Text
"hub", Text
"podenv"]) Text
"package.dhall"

podenvImport :: Dhall.Import
podenvImport :: Import
podenvImport =
  ImportHashed -> ImportMode -> Import
Dhall.Import (Maybe SHA256Digest -> ImportType -> ImportHashed
Dhall.ImportHashed (SHA256Digest -> Maybe SHA256Digest
forall a. a -> Maybe a
Just SHA256Digest
hash) (URL -> ImportType
Dhall.Remote URL
podenvUrl)) ImportMode
Dhall.Code
  where
    hash :: SHA256Digest
hash = Expr Void Void -> SHA256Digest
Dhall.Import.hashExpression (Expr Void Void -> Expr Void Void
forall s a. Expr s a -> Expr s a
Dhall.alphaNormalize Expr Void Void
podenvPackage)

podenvImportTxt :: Text
podenvImportTxt :: Text
podenvImportTxt = Text -> Text -> Text -> Text
Text.replace Text
"\n " Text
"" (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Import -> Text
forall a. Pretty a => a -> Text
Dhall.pretty Import
podenvImport

-- | Pure config load
decodeExpr :: DhallExpr -> Config
decodeExpr :: DhallExpr -> Config
decodeExpr DhallExpr
expr = case Text -> DhallExpr -> DhallParser [(Text, Atom)]
loadConfig Text
"" DhallExpr
expr of
  Success [(Text
selector, Lit ApplicationRecord
app)] -> Atom -> Config
ConfigApplication (Atom -> Config) -> Atom -> Config
forall a b. (a -> b) -> a -> b
$ ApplicationRecord -> Atom
Lit (Text -> ApplicationRecord -> ApplicationRecord
ensureName Text
selector ApplicationRecord
app)
  Success [(Text
_, Atom
x)] -> Atom -> Config
ConfigApplication Atom
x
  Success [] -> Text -> Config
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"No application found"
  Success [(Text, Atom)]
xs -> [(Text, Atom)] -> Config
ConfigApplications [(Text, Atom)]
xs
  Failure (DhallErrors (ExtractError Src Void
x :| [ExtractError Src Void]
_)) -> Text -> Config
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> Config) -> Text -> Config
forall a b. (a -> b) -> a -> b
$ ExtractError Src Void -> Text
forall b a. (Show a, IsString b) => a -> b
show ExtractError Src Void
x

-- | When an application doesn't have a name, set it to the selector path
ensureName :: Text -> ApplicationRecord -> ApplicationRecord
ensureName :: Text -> ApplicationRecord -> ApplicationRecord
ensureName Text
x ApplicationRecord
app = case ApplicationRecord -> Application
unRecord ApplicationRecord
app Application
-> FoldLike Text Application Application Text Text -> Text
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike Text Application Application Text Text
forall (f :: * -> *).
Functor f =>
(Text -> f Text) -> Application -> f Application
appName of
  Text
"" -> Application -> ApplicationRecord
ApplicationRecord (Application -> ApplicationRecord)
-> Application -> ApplicationRecord
forall a b. (a -> b) -> a -> b
$ ApplicationRecord -> Application
unRecord ApplicationRecord
app Application -> (Application -> Application) -> Application
forall a b. a -> (a -> b) -> b
& (Text -> Identity Text) -> Application -> Identity Application
forall (f :: * -> *).
Functor f =>
(Text -> f Text) -> Application -> f Application
appName ((Text -> Identity Text) -> Application -> Identity Application)
-> Text -> Application -> Application
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
x
  Text
_ -> ApplicationRecord
app

-- | The main config load function. It recursively descend the
-- tree by extending the selector name.
loadConfig :: Text -> DhallExpr -> DhallParser [(Text, Atom)]
loadConfig :: Text -> DhallExpr -> DhallParser [(Text, Atom)]
loadConfig Text
baseSelector DhallExpr
expr = case DhallExpr
expr of
  -- When the node is a function, assume it is an app.
  Dhall.Lam {} -> (\Atom
app -> [(Text
baseSelector, Atom
app)]) (Atom -> [(Text, Atom)])
-> Validation (ExtractErrors Src Void) Atom
-> DhallParser [(Text, Atom)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DhallExpr -> Validation (ExtractErrors Src Void) Atom
loadApp DhallExpr
expr
  Dhall.RecordLit Map Text (RecordField Src Void)
kv
    | -- When the node has a "runtime" attribute, assume it is an app.
      Text -> Map Text (RecordField Src Void) -> Bool
forall k v. Ord k => k -> Map k v -> Bool
DM.member Text
"runtime" Map Text (RecordField Src Void)
kv ->
        (\Atom
app -> [(Text
baseSelector, Atom
app)]) (Atom -> [(Text, Atom)])
-> Validation (ExtractErrors Src Void) Atom
-> DhallParser [(Text, Atom)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DhallExpr -> Validation (ExtractErrors Src Void) Atom
loadApp DhallExpr
expr
    | -- Otherwise, traverse each attributes
      Bool
otherwise ->
        [[(Text, Atom)]] -> [(Text, Atom)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Text, Atom)]] -> [(Text, Atom)])
-> Validation (ExtractErrors Src Void) [[(Text, Atom)]]
-> DhallParser [(Text, Atom)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Text, RecordField Src Void) -> DhallParser [(Text, Atom)])
-> [(Text, RecordField Src Void)]
-> Validation (ExtractErrors Src Void) [[(Text, Atom)]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Text -> RecordField Src Void -> DhallParser [(Text, Atom)])
-> (Text, RecordField Src Void) -> DhallParser [(Text, Atom)]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> RecordField Src Void -> DhallParser [(Text, Atom)]
loadCollection) (Map Text (RecordField Src Void) -> [(Text, RecordField Src Void)]
forall k v. Ord k => Map k v -> [(k, v)]
DM.toList Map Text (RecordField Src Void)
kv)
    where
      loadCollection :: Text -> RecordField Src Void -> DhallParser [(Text, Atom)]
loadCollection Text
n RecordField Src Void
e
        -- Skip leaf starting with `use`, otherwise they can be used and likely fail with:
        -- FromDhall: You cannot decode a function if it does not have the correct type
        | Text
"use" Text -> Text -> Bool
`Text.isPrefixOf` Text
n = [(Text, Atom)] -> DhallParser [(Text, Atom)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        | Bool
otherwise = Text -> DhallExpr -> DhallParser [(Text, Atom)]
loadConfig (Text -> Text
mkSelector Text
n) (RecordField Src Void -> DhallExpr
forall s a. RecordField s a -> Expr s a
Dhall.recordFieldValue RecordField Src Void
e)
      mkSelector :: Text -> Text
mkSelector Text
name
        | Text
baseSelector Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
forall a. Monoid a => a
mempty = Text
name
        | Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"default" = Text
baseSelector
        | Bool
otherwise = Text
baseSelector Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
  DhallExpr
_ -> Text -> DhallParser [(Text, Atom)]
forall s a b. Text -> Extractor s a b
extractError (Text -> DhallParser [(Text, Atom)])
-> Text -> DhallParser [(Text, Atom)]
forall a b. (a -> b) -> a -> b
$ Text
baseSelector Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": expected a record literal, but got: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
Text.take Int
256 (DhallExpr -> Text
forall b a. (Show a, IsString b) => a -> b
show DhallExpr
expr)

-- | Select the application, returning the unused cli args.
select :: Config -> [Text] -> Either Text ([Text], Application)
select :: Config -> [Text] -> Either Text ([Text], Application)
select Config
config [Text]
args = (ApplicationRecord -> Application)
-> ([Text], ApplicationRecord) -> ([Text], Application)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ApplicationRecord -> Application
unRecord (([Text], ApplicationRecord) -> ([Text], Application))
-> Either Text ([Text], ApplicationRecord)
-> Either Text ([Text], Application)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Config -> [Text] -> Either Text ([Text], ApplicationRecord)
select' Config
config [Text]
args

select' :: Config -> [Text] -> Either Text ([Text], ApplicationRecord)
select' :: Config -> [Text] -> Either Text ([Text], ApplicationRecord)
select' Config
config [Text]
args = case Config
config of
  -- config default is always selected, drop the first args
  ConfigDefault ApplicationRecord
app -> ([Text], ApplicationRecord)
-> Either Text ([Text], ApplicationRecord)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty Text -> [Text]
forall (f :: * -> *) a. IsNonEmpty f a [a] "tail" => f a -> [a]
tail ([Item (NonEmpty Text)] -> NonEmpty Text
forall l. IsList l => [Item l] -> l
fromList [Text]
[Item (NonEmpty Text)]
args), ApplicationRecord
app)
  -- config has only one application, don't touch the args
  ConfigApplication Atom
atom -> [(Text, Atom)]
-> [Text] -> Atom -> Either Text ([Text], ApplicationRecord)
selectApp [] [Text]
args Atom
atom
  -- config has some applications, the first arg is a selector
  ConfigApplications [(Text, Atom)]
atoms -> case [Text]
args of
    (Text
selector : [Text]
xs) -> do
      Atom
atom <- Text -> [(Text, Atom)] -> Maybe Atom
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
selector [(Text, Atom)]
atoms Maybe Atom -> Text -> Either Text Atom
forall a. Maybe a -> Text -> Either Text a
`orDie` (Text
selector Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": not found")
      ([Text]
args', ApplicationRecord
app) <- [(Text, Atom)]
-> [Text] -> Atom -> Either Text ([Text], ApplicationRecord)
selectApp [(Text, Atom)]
atoms [Text]
xs Atom
atom
      let name' :: Text
name' = Text -> [Text] -> Text
Text.intercalate Text
"-" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
take ([Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
args Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
args') [Text]
args
      ([Text], ApplicationRecord)
-> Either Text ([Text], ApplicationRecord)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text]
args', Text -> ApplicationRecord -> ApplicationRecord
ensureName Text
name' ApplicationRecord
app)
    [] -> Text -> Either Text ([Text], ApplicationRecord)
forall a b. a -> Either a b
Left Text
"Multiple apps configured, provides a selector"
  where
    selectApp :: [(Text, Atom)]
-> [Text] -> Atom -> Either Text ([Text], ApplicationRecord)
selectApp [(Text, Atom)]
atoms [Text]
args' Atom
atom = case Atom
atom of
      -- App is not a function, don't touch the arg
      Lit ApplicationRecord
app -> ([Text], ApplicationRecord)
-> Either Text ([Text], ApplicationRecord)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text]
args', ApplicationRecord
app)
      -- App needs an argument, the tail is the arg
      LamArg ArgName
arg Text -> ApplicationRecord
f -> case [Text]
args' of
        (Text
x : [Text]
xs) -> ([Text], ApplicationRecord)
-> Either Text ([Text], ApplicationRecord)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text]
xs, Text -> ApplicationRecord
f Text
x)
        [] -> Text -> Either Text ([Text], ApplicationRecord)
forall a b. a -> Either a b
Left (Text
"Missing argument: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ArgName -> Text
forall b a. (Show a, IsString b) => a -> b
show ArgName
arg)
      LamArg2 ArgName
arg1 ArgName
arg2 Text -> Text -> ApplicationRecord
f -> case [Text]
args' of
        (Text
x : Text
y : [Text]
xs) -> ([Text], ApplicationRecord)
-> Either Text ([Text], ApplicationRecord)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text]
xs, Text -> Text -> ApplicationRecord
f Text
x Text
y)
        (Text
_ : [Text]
_) -> Text -> Either Text ([Text], ApplicationRecord)
forall a b. a -> Either a b
Left (Text
"Missing argument: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ArgName -> Text
forall b a. (Show a, IsString b) => a -> b
show ArgName
arg2)
        [Text]
_ -> Text -> Either Text ([Text], ApplicationRecord)
forall a b. a -> Either a b
Left (Text
"Missing arguments: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ArgName -> Text
forall b a. (Show a, IsString b) => a -> b
show ArgName
arg1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ArgName -> Text
forall b a. (Show a, IsString b) => a -> b
show ArgName
arg2)
      LamApp Application -> ApplicationRecord
f -> case [Text]
args' of
        (Text
x : [Text]
xs) -> case Text -> Maybe Application
defaultSelector Text
x of
          Just Application
app -> ([Text], ApplicationRecord)
-> Either Text ([Text], ApplicationRecord)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text]
xs, Application -> ApplicationRecord
f Application
app)
          Maybe Application
Nothing -> do
            -- Recursively select the app to eval arg `mod app arg` as `mod (app arg)`
            -- e.g. LamApp should be applied at the end.
            Atom
atom' <- Text -> [(Text, Atom)] -> Maybe Atom
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
x [(Text, Atom)]
atoms Maybe Atom -> Text -> Either Text Atom
forall a. Maybe a -> Text -> Either Text a
`orDie` (Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": unknown lam arg")
            ([Text]
rest, ApplicationRecord
app) <- [(Text, Atom)]
-> [Text] -> Atom -> Either Text ([Text], ApplicationRecord)
selectApp [(Text, Atom)]
atoms [Text]
xs Atom
atom'
            ([Text], ApplicationRecord)
-> Either Text ([Text], ApplicationRecord)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text]
rest, Application -> ApplicationRecord
f (ApplicationRecord -> Application
unRecord ApplicationRecord
app))
        [] -> Text -> Either Text ([Text], ApplicationRecord)
forall a b. a -> Either a b
Left Text
"Missing app argument"

defaultConfigPath :: Text
defaultConfigPath :: Text
defaultConfigPath = Text
"~/.config/podenv/config.dhall"

-- | The default app
defaultApp :: Application
defaultApp :: Application
defaultApp = case Decoder Application -> DhallExpr -> Extractor Src Void Application
forall a. Decoder a -> DhallExpr -> Extractor Src Void a
Dhall.extract Decoder Application
forall a. FromDhall a => Decoder a
Dhall.auto (Expr Void Void -> DhallExpr
forall a s. Expr Void a -> Expr s a
Dhall.renote Expr Void Void
appDefault) of
  Success Application
app -> Application
app
  Failure ExtractErrors Src Void
v -> Text -> Application
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> Application) -> Text -> Application
forall a b. (a -> b) -> a -> b
$ Text
"Invalid default application: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ExtractErrors Src Void -> Text
forall b a. (Show a, IsString b) => a -> b
show ExtractErrors Src Void
v

-- | A type synonym to simplify function annotation.
type DhallParser a = Dhall.Extractor Dhall.Src.Src Void a

-- | A type synonym to simplify function annotation.
type DhallExpr = Dhall.Expr Dhall.Src.Src Void

type DhallExtractor a = Dhall.Extractor Dhall.Src.Src Void a

-- | The `//` dhall record update operation
pref :: Dhall.Expr s a -> Dhall.Expr s a -> Dhall.Expr s a
pref :: Expr s a -> Expr s a -> Expr s a
pref = Maybe CharacterSet
-> PreferAnnotation s a -> Expr s a -> Expr s a -> Expr s a
forall s a.
Maybe CharacterSet
-> PreferAnnotation s a -> Expr s a -> Expr s a -> Expr s a
Dhall.Prefer Maybe CharacterSet
forall a. Maybe a
Nothing PreferAnnotation s a
forall s a. PreferAnnotation s a
Dhall.PreferFromSource

mkRecord :: [(Text, Dhall.Expr s a)] -> Dhall.Expr s a
mkRecord :: [(Text, Expr s a)] -> Expr s a
mkRecord [(Text, Expr s a)]
kv = Map Text (RecordField s a) -> Expr s a
forall s a. Map Text (RecordField s a) -> Expr s a
Dhall.RecordLit (Expr s a -> RecordField s a
forall s a. Expr s a -> RecordField s a
Dhall.makeRecordField (Expr s a -> RecordField s a)
-> Map Text (Expr s a) -> Map Text (RecordField s a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Expr s a)] -> Map Text (Expr s a)
forall k v. Ord k => [(k, v)] -> Map k v
DM.fromList [(Text, Expr s a)]
kv)

recordItems :: DM.Map Text (Dhall.RecordField s a) -> [(Text, Dhall.Expr Void a)]
recordItems :: Map Text (RecordField s a) -> [(Text, Expr Void a)]
recordItems Map Text (RecordField s a)
kv = (RecordField s a -> Expr Void a)
-> (Text, RecordField s a) -> (Text, Expr Void a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Expr s a -> Expr Void a
forall s a t. Expr s a -> Expr t a
Dhall.denote (Expr s a -> Expr Void a)
-> (RecordField s a -> Expr s a) -> RecordField s a -> Expr Void a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecordField s a -> Expr s a
forall s a. RecordField s a -> Expr s a
Dhall.recordFieldValue) ((Text, RecordField s a) -> (Text, Expr Void a))
-> [(Text, RecordField s a)] -> [(Text, Expr Void a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Text (RecordField s a) -> [(Text, RecordField s a)]
forall k v. Ord k => Map k v -> [(k, v)]
DM.toList Map Text (RecordField s a)
kv

-- | A custom Dhall Decoder that can convert a weakly type Application
-- This is done by modifying the 'base' Dhall.Expr with:
--   App.default // (base // { capabilities = Caps.default // base.capabilities })
-- so that the missing fields are automatically added.
--
-- For the runtime value, this convert may convert a tag record to an Union variant
appRecordDecoder :: Dhall.Decoder ApplicationRecord
appRecordDecoder :: Decoder ApplicationRecord
appRecordDecoder = Application -> ApplicationRecord
ApplicationRecord (Application -> ApplicationRecord)
-> Decoder Application -> Decoder ApplicationRecord
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DhallExpr -> Extractor Src Void Application)
-> Expector DhallExpr -> Decoder Application
forall a.
(DhallExpr -> Extractor Src Void a)
-> Expector DhallExpr -> Decoder a
Dhall.Decoder DhallExpr -> Extractor Src Void Application
extract Expector DhallExpr
forall e s. Validation e (Expr s Void)
expected
  where
    extract :: Dhall.Expr Dhall.Src.Src Void -> DhallExtractor Application
    extract :: DhallExpr -> Extractor Src Void Application
extract (Dhall.RecordLit Map Text (RecordField Src Void)
kv) = case Text
-> Map Text (RecordField Src Void) -> Maybe (RecordField Src Void)
forall k v. Ord k => k -> Map k v -> Maybe v
DM.lookup Text
"runtime" Map Text (RecordField Src Void)
kv of
      Just (Dhall.RecordField Maybe Src
_ (Dhall.RecordLit Map Text (RecordField Src Void)
kv') Maybe Src
_ Maybe Src
_) -> Map Text (RecordField Src Void)
-> Expr Void Void -> Extractor Src Void Application
forall s.
Map Text (RecordField s Void)
-> Expr Void Void -> Extractor Src Void Application
extract' Map Text (RecordField Src Void)
kv (Map Text (RecordField Src Void) -> Expr Void Void
forall s. Map Text (RecordField s Void) -> Expr Void Void
runtimeFromRecord Map Text (RecordField Src Void)
kv')
      Just (Dhall.RecordField Maybe Src
_ DhallExpr
v Maybe Src
_ Maybe Src
_) -> Map Text (RecordField Src Void)
-> Expr Void Void -> Extractor Src Void Application
forall s.
Map Text (RecordField s Void)
-> Expr Void Void -> Extractor Src Void Application
extract' Map Text (RecordField Src Void)
kv (DhallExpr -> Expr Void Void
forall s a t. Expr s a -> Expr t a
Dhall.denote DhallExpr
v)
      Maybe (RecordField Src Void)
Nothing -> Text -> Extractor Src Void Application
forall s a b. Text -> Extractor s a b
Dhall.extractError Text
"Application does not have a runtime"
    extract DhallExpr
_ = Text -> Extractor Src Void Application
forall s a b. Text -> Extractor s a b
Dhall.extractError Text
"Application is not a record"

    runtimeFromRecord :: DM.Map Text (Dhall.RecordField s Void) -> Dhall.Expr Void Void
    runtimeFromRecord :: Map Text (RecordField s Void) -> Expr Void Void
runtimeFromRecord Map Text (RecordField s Void)
kv = case Map Text (RecordField s Void) -> [(Text, Expr Void Void)]
forall s a. Map Text (RecordField s a) -> [(Text, Expr Void a)]
recordItems Map Text (RecordField s Void)
kv of
      [(Text
"image", Expr Void Void
x)] -> Text -> Expr Void Void -> Expr Void Void
mkRuntime Text
"Image" Expr Void Void
x
      [(Text
"nix", Expr Void Void
x)] -> Text -> Expr Void Void -> Expr Void Void
mkRuntime Text
"Nix" (Expr Void Void -> Expr Void Void
forall s a. Expr s a -> Expr s a
mkNixRecord Expr Void Void
x)
      [(Text
"containerfile", Expr Void Void
x)] -> Text -> Expr Void Void -> Expr Void Void
mkRuntime Text
"Container" (Expr Void Void -> Expr Void Void -> Expr Void Void
forall s a. Expr s a -> Expr s a -> Expr s a
pref Expr Void Void
containerBuildDefault ([(Text, Expr Void Void)] -> Expr Void Void
forall s a. [(Text, Expr s a)] -> Expr s a
mkRecord [(Text
"containerfile", Expr Void Void
x)]))
      [(Text, Expr Void Void)]
_ -> Text -> Expr Void Void -> Expr Void Void
mkRuntime Text
"Container" (Expr Void Void -> Expr Void Void -> Expr Void Void
forall s a. Expr s a -> Expr s a -> Expr s a
pref Expr Void Void
containerBuildDefault (Expr s Void -> Expr Void Void
forall s a t. Expr s a -> Expr t a
Dhall.denote (Map Text (RecordField s Void) -> Expr s Void
forall s a. Map Text (RecordField s a) -> Expr s a
Dhall.RecordLit Map Text (RecordField s Void)
kv)))
      where
        mkNixRecord :: Expr s a -> Expr s a
mkNixRecord Expr s a
v =
          [(Text, Expr s a)] -> Expr s a
forall s a. [(Text, Expr s a)] -> Expr s a
mkRecord
            [ (Text
"installables", Maybe (Expr s a) -> Seq (Expr s a) -> Expr s a
forall s a. Maybe (Expr s a) -> Seq (Expr s a) -> Expr s a
Dhall.ListLit Maybe (Expr s a)
forall a. Maybe a
Nothing (Seq (Expr s a) -> Expr s a) -> Seq (Expr s a) -> Expr s a
forall a b. (a -> b) -> a -> b
$ [Item (Seq (Expr s a))] -> Seq (Expr s a)
forall l. IsList l => [Item l] -> l
fromList [Item (Seq (Expr s a))
Expr s a
v]),
              (Text
"nixpkgs", Expr s a -> Expr s a -> Expr s a
forall s a. Expr s a -> Expr s a -> Expr s a
Dhall.App Expr s a
forall s a. Expr s a
Dhall.None Expr s a
forall s a. Expr s a
Dhall.Text)
            ]
        mkRuntime :: Text -> Expr Void Void -> Expr Void Void
mkRuntime Text
field Expr Void Void
v =
          Expr Void Void -> Expr Void Void -> Expr Void Void
forall s a. Expr s a -> Expr s a -> Expr s a
Dhall.App (Expr Void Void -> FieldSelection Void -> Expr Void Void
forall s a. Expr s a -> FieldSelection s -> Expr s a
Dhall.Field Expr Void Void
runtimeType (Maybe Void -> Text -> Maybe Void -> FieldSelection Void
forall s. Maybe s -> Text -> Maybe s -> FieldSelection s
Dhall.FieldSelection Maybe Void
forall a. Maybe a
Nothing Text
field Maybe Void
forall a. Maybe a
Nothing)) Expr Void Void
v

    extract' :: DM.Map Text (Dhall.RecordField s Void) -> Dhall.Expr Void Void -> DhallExtractor Application
    extract' :: Map Text (RecordField s Void)
-> Expr Void Void -> Extractor Src Void Application
extract' Map Text (RecordField s Void)
kv Expr Void Void
runtimeExpr =
      let capsExpr :: Expr Void Void
capsExpr = case Text -> Map Text (RecordField s Void) -> Maybe (RecordField s Void)
forall k v. Ord k => k -> Map k v -> Maybe v
DM.lookup Text
"capabilities" Map Text (RecordField s Void)
kv of
            Just (Dhall.RecordField Maybe s
_ Expr s Void
v Maybe s
_ Maybe s
_) -> Expr Void Void -> Expr Void Void -> Expr Void Void
forall s a. Expr s a -> Expr s a -> Expr s a
pref Expr Void Void
capsDefault (Expr s Void -> Expr Void Void
forall s a t. Expr s a -> Expr t a
Dhall.denote Expr s Void
v)
            Maybe (RecordField s Void)
_ -> Expr Void Void
capsDefault

          -- capabilities and runtime are always added since they are nested schemas
          nestedSchemas :: [(Text, Expr Void Void)]
nestedSchemas = [(Text
"capabilities", Expr Void Void
capsExpr), (Text
"runtime", Expr Void Void
runtimeExpr)]

          baseExpr :: Expr Void Void
baseExpr = Expr Void Void -> Expr Void Void -> Expr Void Void
forall s a. Expr s a -> Expr s a -> Expr s a
pref (Expr s Void -> Expr Void Void
forall s a t. Expr s a -> Expr t a
Dhall.denote (Expr s Void -> Expr Void Void) -> Expr s Void -> Expr Void Void
forall a b. (a -> b) -> a -> b
$ Map Text (RecordField s Void) -> Expr s Void
forall s a. Map Text (RecordField s a) -> Expr s a
Dhall.RecordLit Map Text (RecordField s Void)
kv) ([(Text, Expr Void Void)] -> Expr Void Void
forall s a. [(Text, Expr s a)] -> Expr s a
mkRecord [(Text, Expr Void Void)]
nestedSchemas)
          expr :: Expr Void Void
expr = Expr Void Void -> Expr Void Void -> Expr Void Void
forall s a. Expr s a -> Expr s a -> Expr s a
pref Expr Void Void
appDefault Expr Void Void
baseExpr

          -- The generic Application decoder
          Dhall.Decoder DhallExpr -> Extractor Src Void Application
appDecoder Expector DhallExpr
_ = Decoder Application
forall a. (Generic a, GenericFromDhall a (Rep a)) => Decoder a
Dhall.genericAuto
       in DhallExpr -> Extractor Src Void Application
appDecoder (Expr Void Void -> DhallExpr
forall a s. Expr Void a -> Expr s a
Dhall.renote (Expr Void Void -> Expr Void Void
forall a s t. Eq a => Expr s a -> Expr t a
Dhall.normalize Expr Void Void
expr))

    expected :: Validation e (Expr s Void)
expected = Expr s Void -> Validation e (Expr s Void)
forall e a. a -> Validation e a
Success (Expr Void Void -> Expr s Void
forall a s. Expr Void a -> Expr s a
Dhall.renote Expr Void Void
appType)

-- | Parse and tag a DhallExpr with an Atom constructor
loadApp :: DhallExpr -> DhallParser Atom
loadApp :: DhallExpr -> Validation (ExtractErrors Src Void) Atom
loadApp DhallExpr
expr = case DhallExpr
expr of
  Dhall.Lam Maybe CharacterSet
_ FunctionBinding Src Void
fb1 (Dhall.Lam Maybe CharacterSet
_ FunctionBinding Src Void
fb2 DhallExpr
_) -> ArgName -> ArgName -> (Text -> Text -> ApplicationRecord) -> Atom
LamArg2 (FunctionBinding Src Void -> ArgName
forall s a. FunctionBinding s a -> ArgName
getArgName FunctionBinding Src Void
fb1) (FunctionBinding Src Void -> ArgName
forall s a. FunctionBinding s a -> ArgName
getArgName FunctionBinding Src Void
fb2) ((Text -> Text -> ApplicationRecord) -> Atom)
-> Validation
     (ExtractErrors Src Void) (Text -> Text -> ApplicationRecord)
-> Validation (ExtractErrors Src Void) Atom
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder (Text -> Text -> ApplicationRecord)
-> DhallExpr
-> Validation
     (ExtractErrors Src Void) (Text -> Text -> ApplicationRecord)
forall a. Decoder a -> DhallExpr -> Extractor Src Void a
Dhall.extract Decoder (Text -> Text -> ApplicationRecord)
forall a. FromDhall a => Decoder a
Dhall.auto DhallExpr
expr
  Dhall.Lam Maybe CharacterSet
_ FunctionBinding Src Void
fb DhallExpr
_
    | DhallExpr -> Expr Void Void
forall s a t. Expr s a -> Expr t a
Dhall.denote (FunctionBinding Src Void -> DhallExpr
forall s a. FunctionBinding s a -> Expr s a
Dhall.functionBindingAnnotation FunctionBinding Src Void
fb) Expr Void Void -> Expr Void Void -> Bool
forall a. Eq a => a -> a -> Bool
== Expr Void Void
appType ->
        (Application -> ApplicationRecord) -> Atom
LamApp ((Application -> ApplicationRecord) -> Atom)
-> Validation
     (ExtractErrors Src Void) (Application -> ApplicationRecord)
-> Validation (ExtractErrors Src Void) Atom
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder (Application -> ApplicationRecord)
-> DhallExpr
-> Validation
     (ExtractErrors Src Void) (Application -> ApplicationRecord)
forall a. Decoder a -> DhallExpr -> Extractor Src Void a
Dhall.extract Decoder (Application -> ApplicationRecord)
forall a. FromDhall a => Decoder a
Dhall.auto DhallExpr
expr
    | Bool
otherwise -> ArgName -> (Text -> ApplicationRecord) -> Atom
LamArg (FunctionBinding Src Void -> ArgName
forall s a. FunctionBinding s a -> ArgName
getArgName FunctionBinding Src Void
fb) ((Text -> ApplicationRecord) -> Atom)
-> Validation (ExtractErrors Src Void) (Text -> ApplicationRecord)
-> Validation (ExtractErrors Src Void) Atom
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder (Text -> ApplicationRecord)
-> DhallExpr
-> Validation (ExtractErrors Src Void) (Text -> ApplicationRecord)
forall a. Decoder a -> DhallExpr -> Extractor Src Void a
Dhall.extract Decoder (Text -> ApplicationRecord)
forall a. FromDhall a => Decoder a
Dhall.auto DhallExpr
expr
  DhallExpr
_ -> ApplicationRecord -> Atom
Lit (ApplicationRecord -> Atom)
-> Validation (ExtractErrors Src Void) ApplicationRecord
-> Validation (ExtractErrors Src Void) Atom
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder ApplicationRecord
-> DhallExpr
-> Validation (ExtractErrors Src Void) ApplicationRecord
forall a. Decoder a -> DhallExpr -> Extractor Src Void a
Dhall.extract Decoder ApplicationRecord
forall a. FromDhall a => Decoder a
Dhall.auto DhallExpr
expr
  where
    getArgName :: FunctionBinding s a -> ArgName
getArgName = Text -> ArgName
ArgName (Text -> ArgName)
-> (FunctionBinding s a -> Text) -> FunctionBinding s a -> ArgName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FunctionBinding s a -> Text
forall s a. FunctionBinding s a -> Text
Dhall.functionBindingVariable

loadSystem :: IO SystemConfig
loadSystem :: IO SystemConfig
loadSystem = do
  String
confDir <- XdgDirectory -> String -> IO String
getXdgDirectory XdgDirectory
XdgConfig String
"podenv"
  let fp :: String
fp = String
confDir String -> ShowS
</> String
"system.dhall"
  Bool
exist <- String -> IO Bool
doesFileExist String
fp
  if Bool
exist
    then Decoder SystemConfig -> Text -> IO SystemConfig
forall a. Decoder a -> Text -> IO a
Dhall.input Decoder SystemConfig
forall a. FromDhall a => Decoder a
Dhall.auto (String -> Text
forall a. ToText a => a -> Text
toText String
fp)
    else SystemConfig -> IO SystemConfig
forall (f :: * -> *) a. Applicative f => a -> f a
pure SystemConfig
defaultSystemConfig

-- | The default system config
defaultSystemConfig :: SystemConfig
defaultSystemConfig :: SystemConfig
defaultSystemConfig = case Decoder SystemConfig
-> DhallExpr -> Extractor Src Void SystemConfig
forall a. Decoder a -> DhallExpr -> Extractor Src Void a
Dhall.extract Decoder SystemConfig
forall a. FromDhall a => Decoder a
Dhall.auto (Expr Void Void -> DhallExpr
forall a s. Expr Void a -> Expr s a
Dhall.renote Expr Void Void
systemConfigDefault) of
  Success SystemConfig
x -> SystemConfig
x
  Failure ExtractErrors Src Void
v -> Text -> SystemConfig
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> SystemConfig) -> Text -> SystemConfig
forall a b. (a -> b) -> a -> b
$ Text
"Invalid default system config: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ExtractErrors Src Void -> Text
forall b a. (Show a, IsString b) => a -> b
show ExtractErrors Src Void
v