{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE OverloadedStrings #-}
module Hercules.Secrets
( SecretContext (..),
evalCondition,
evalConditionTrace,
)
where
import Control.Monad.Writer qualified
import Data.Binary (Binary)
import Data.Tagged
import Data.Text qualified as T
import Hercules.Formats.Secret
import Protolude
data SecretContext = SecretContext
{ SecretContext -> Text
ownerName :: Text,
SecretContext -> Text
repoName :: Text,
SecretContext -> Bool
isDefaultBranch :: Bool,
SecretContext -> Text
ref :: Text
}
deriving ((forall x. SecretContext -> Rep SecretContext x)
-> (forall x. Rep SecretContext x -> SecretContext)
-> Generic SecretContext
forall x. Rep SecretContext x -> SecretContext
forall x. SecretContext -> Rep SecretContext x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SecretContext -> Rep SecretContext x
from :: forall x. SecretContext -> Rep SecretContext x
$cto :: forall x. Rep SecretContext x -> SecretContext
to :: forall x. Rep SecretContext x -> SecretContext
Generic, Get SecretContext
[SecretContext] -> Put
SecretContext -> Put
(SecretContext -> Put)
-> Get SecretContext
-> ([SecretContext] -> Put)
-> Binary SecretContext
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
$cput :: SecretContext -> Put
put :: SecretContext -> Put
$cget :: Get SecretContext
get :: Get SecretContext
$cputList :: [SecretContext] -> Put
putList :: [SecretContext] -> Put
Binary, Int -> SecretContext -> ShowS
[SecretContext] -> ShowS
SecretContext -> String
(Int -> SecretContext -> ShowS)
-> (SecretContext -> String)
-> ([SecretContext] -> ShowS)
-> Show SecretContext
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SecretContext -> ShowS
showsPrec :: Int -> SecretContext -> ShowS
$cshow :: SecretContext -> String
show :: SecretContext -> String
$cshowList :: [SecretContext] -> ShowS
showList :: [SecretContext] -> ShowS
Show, SecretContext -> SecretContext -> Bool
(SecretContext -> SecretContext -> Bool)
-> (SecretContext -> SecretContext -> Bool) -> Eq SecretContext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SecretContext -> SecretContext -> Bool
== :: SecretContext -> SecretContext -> Bool
$c/= :: SecretContext -> SecretContext -> Bool
/= :: SecretContext -> SecretContext -> Bool
Eq)
evalCondition' :: (Monad m, MonadMiniWriter [Text] m) => SecretContext -> Condition -> m Bool
evalCondition' :: forall (m :: * -> *).
(Monad m, MonadMiniWriter [Text] m) =>
SecretContext -> Condition -> m Bool
evalCondition' SecretContext
ctx = Condition -> m Bool
forall {m :: * -> *} {a}.
(Monad m, Semigroup a, StringConv String a, IsString a,
MonadMiniWriter [a] m) =>
Condition -> m Bool
eval
where
eval :: Condition -> m Bool
eval (Or [Condition]
cs) = do
[a] -> m ()
forall w (m :: * -> *). MonadMiniWriter w m => w -> m ()
tell [a
"or: Entering"]
let go :: [Condition] -> m Bool
go [] = do
[a] -> m ()
forall w (m :: * -> *). MonadMiniWriter w m => w -> m ()
tell [a
"or: Leaving (false)"]
Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
go (Condition
a : [Condition]
as) = do
Bool
b <- Condition -> m Bool
eval Condition
a
if Bool
b
then do
[a] -> m ()
forall w (m :: * -> *). MonadMiniWriter w m => w -> m ()
tell [a
"or: Leaving (true)"]
Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
else do
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Condition] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Condition]
as) ([a] -> m ()
forall w (m :: * -> *). MonadMiniWriter w m => w -> m ()
tell [a
"or: Backtracking"])
[Condition] -> m Bool
go [Condition]
as
[Condition] -> m Bool
go [Condition]
cs
eval (And [Condition]
cs) = do
[a] -> m ()
forall w (m :: * -> *). MonadMiniWriter w m => w -> m ()
tell [a
"and: Entering"]
let go :: [Condition] -> m Bool
go [] = do
[a] -> m ()
forall w (m :: * -> *). MonadMiniWriter w m => w -> m ()
tell [a
"and: Leaving (true)"]
Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
go (Condition
a : [Condition]
as) = do
Bool
b <- Condition -> m Bool
eval Condition
a
if Bool
b
then [Condition] -> m Bool
go [Condition]
as
else do
[a] -> m ()
forall w (m :: * -> *). MonadMiniWriter w m => w -> m ()
tell [a
"and: Leaving (false)"]
Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
[Condition] -> m Bool
go [Condition]
cs
eval Condition
IsDefaultBranch =
if SecretContext -> Bool
isDefaultBranch SecretContext
ctx
then Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
else Bool
False Bool -> m () -> m Bool
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [a] -> m ()
forall w (m :: * -> *). MonadMiniWriter w m => w -> m ()
tell [a
"isDefaultBranch: ref " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> Text -> a
forall a b. (Show a, StringConv String b) => a -> b
show (SecretContext -> Text
ref SecretContext
ctx) a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
" is not the default branch"]
eval Condition
IsTag =
if Text
"refs/tags/" Text -> Text -> Bool
`T.isPrefixOf` SecretContext -> Text
ref SecretContext
ctx
then Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
else Bool
False Bool -> m () -> m Bool
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [a] -> m ()
forall w (m :: * -> *). MonadMiniWriter w m => w -> m ()
tell [a
"isTag: ref " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> Text -> a
forall a b. (Show a, StringConv String b) => a -> b
show (SecretContext -> Text
ref SecretContext
ctx) a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
" is not a tag"]
eval (IsBranch Text
b) = do
let expect :: Text
expect = Text
"refs/heads/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b
actual :: Text
actual = SecretContext -> Text
ref SecretContext
ctx
if Text
expect Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
actual
then Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
else Bool
False Bool -> m () -> m Bool
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [a] -> m ()
forall w (m :: * -> *). MonadMiniWriter w m => w -> m ()
tell [a
"isBranch: ref " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> Text -> a
forall a b. (Show a, StringConv String b) => a -> b
show Text
actual a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
" is not the desired " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> Text -> a
forall a b. (Show a, StringConv String b) => a -> b
show Text
expect]
eval (IsRepo Text
expect) = do
let actual :: Text
actual = SecretContext -> Text
repoName SecretContext
ctx
if Text
actual Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
expect
then Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
else Bool
False Bool -> m () -> m Bool
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [a] -> m ()
forall w (m :: * -> *). MonadMiniWriter w m => w -> m ()
tell [a
"isRepo: repo " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> Text -> a
forall a b. (Show a, StringConv String b) => a -> b
show Text
actual a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
" is not the desired " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> Text -> a
forall a b. (Show a, StringConv String b) => a -> b
show Text
expect]
eval (IsOwner Text
expect) = do
let actual :: Text
actual = SecretContext -> Text
ownerName SecretContext
ctx
if Text
actual Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
expect
then Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
else Bool
False Bool -> m () -> m Bool
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [a] -> m ()
forall w (m :: * -> *). MonadMiniWriter w m => w -> m ()
tell [a
"isOwner: owner " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> Text -> a
forall a b. (Show a, StringConv String b) => a -> b
show Text
actual a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
" is not the desired " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> Text -> a
forall a b. (Show a, StringConv String b) => a -> b
show Text
expect]
eval (Hercules.Formats.Secret.Const Bool
b) = do
[a] -> m ()
forall w (m :: * -> *). MonadMiniWriter w m => w -> m ()
tell [a
"const: " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> Bool -> a
forall a b. (Show a, StringConv String b) => a -> b
show Bool
b]
Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
b
evalCondition :: SecretContext -> Condition -> Bool
evalCondition :: SecretContext -> Condition -> Bool
evalCondition SecretContext
ctx Condition
c = Tagged [Text] Bool -> Bool
forall {k} (s :: k) b. Tagged s b -> b
unTagged (SecretContext -> Condition -> Tagged [Text] Bool
forall (m :: * -> *).
(Monad m, MonadMiniWriter [Text] m) =>
SecretContext -> Condition -> m Bool
evalCondition' SecretContext
ctx Condition
c :: Tagged [Text] Bool)
evalConditionTrace :: SecretContext -> Condition -> ([Text], Bool)
evalConditionTrace :: SecretContext -> Condition -> ([Text], Bool)
evalConditionTrace = SecretContext -> Condition -> ([Text], Bool)
forall (m :: * -> *).
(Monad m, MonadMiniWriter [Text] m) =>
SecretContext -> Condition -> m Bool
evalCondition'
class MonadMiniWriter w m | m -> w where
tell :: w -> m ()
instance (Monoid w) => MonadMiniWriter w ((,) w) where
tell :: w -> (w, ())
tell = w -> (w, ())
forall w (m :: * -> *). MonadWriter w m => w -> m ()
Control.Monad.Writer.tell
instance MonadMiniWriter w (Tagged w) where
tell :: w -> Tagged w ()
tell w
_ = () -> Tagged w ()
forall a. a -> Tagged w a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()