{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE OverloadedStrings #-}

module Hercules.Secrets
  ( SecretContext (..),
    evalCondition,
    evalConditionTrace,
  )
where

import qualified Control.Monad.Writer
import Data.Binary (Binary)
import Data.Tagged
import qualified Data.Text 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. 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
$cto :: forall x. Rep SecretContext x -> SecretContext
$cfrom :: forall x. SecretContext -> Rep SecretContext x
Generic, Get SecretContext
[SecretContext] -> Put
SecretContext -> Put
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [SecretContext] -> Put
$cputList :: [SecretContext] -> Put
get :: Get SecretContext
$cget :: Get SecretContext
put :: SecretContext -> Put
$cput :: SecretContext -> Put
Binary, Int -> SecretContext -> ShowS
[SecretContext] -> ShowS
SecretContext -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SecretContext] -> ShowS
$cshowList :: [SecretContext] -> ShowS
show :: SecretContext -> String
$cshow :: SecretContext -> String
showsPrec :: Int -> SecretContext -> ShowS
$cshowsPrec :: Int -> SecretContext -> ShowS
Show, SecretContext -> SecretContext -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SecretContext -> SecretContext -> Bool
$c/= :: SecretContext -> SecretContext -> Bool
== :: SecretContext -> SecretContext -> Bool
$c== :: 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 = forall {a} {m :: * -> *}.
(MonadMiniWriter [a] m, IsString a, Semigroup a,
 StringConv String a, Monad m) =>
Condition -> m Bool
eval
  where
    eval :: Condition -> m Bool
eval (Or [Condition]
cs) = do
      forall w (m :: * -> *). MonadMiniWriter w m => w -> m ()
tell [a
"or: Entering"]
      let go :: [Condition] -> m Bool
go [] = do
            forall w (m :: * -> *). MonadMiniWriter w m => w -> m ()
tell [a
"or: Leaving (false)"]
            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
                forall w (m :: * -> *). MonadMiniWriter w m => w -> m ()
tell [a
"or: Leaving (true)"]
                forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
              else do
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Condition]
as) (forall w (m :: * -> *). MonadMiniWriter w m => w -> m ()
tell [a
"or: Backtracking"])
                [Condition] -> m Bool
go [Condition]
as
      forall {a}.
(MonadMiniWriter [a] m, IsString a) =>
[Condition] -> m Bool
go [Condition]
cs
    eval (And [Condition]
cs) = do
      forall w (m :: * -> *). MonadMiniWriter w m => w -> m ()
tell [a
"and: Entering"]
      let go :: [Condition] -> m Bool
go [] = do
            forall w (m :: * -> *). MonadMiniWriter w m => w -> m ()
tell [a
"and: Leaving (true)"]
            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
                forall w (m :: * -> *). MonadMiniWriter w m => w -> m ()
tell [a
"and: Leaving (false)"]
                forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      forall {a}.
(MonadMiniWriter [a] m, IsString a) =>
[Condition] -> m Bool
go [Condition]
cs
    eval Condition
IsDefaultBranch =
      if SecretContext -> Bool
isDefaultBranch SecretContext
ctx
        then forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
        else Bool
False forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall w (m :: * -> *). MonadMiniWriter w m => w -> m ()
tell [a
"isDefaultBranch: ref " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show (SecretContext -> Text
ref SecretContext
ctx) 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 forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
        else Bool
False forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall w (m :: * -> *). MonadMiniWriter w m => w -> m ()
tell [a
"isTag: ref " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show (SecretContext -> Text
ref SecretContext
ctx) forall a. Semigroup a => a -> a -> a
<> a
" is not a tag"]
    eval (IsBranch Text
b) = do
      let expect :: Text
expect = Text
"refs/heads/" forall a. Semigroup a => a -> a -> a
<> Text
b
          actual :: Text
actual = SecretContext -> Text
ref SecretContext
ctx
      if Text
expect forall a. Eq a => a -> a -> Bool
== Text
actual
        then forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
        else Bool
False forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall w (m :: * -> *). MonadMiniWriter w m => w -> m ()
tell [a
"isBranch: ref " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Text
actual forall a. Semigroup a => a -> a -> a
<> a
" is not the desired " forall a. Semigroup a => a -> a -> 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 forall a. Eq a => a -> a -> Bool
== Text
expect
        then forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
        else Bool
False forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall w (m :: * -> *). MonadMiniWriter w m => w -> m ()
tell [a
"isRepo: repo " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Text
actual forall a. Semigroup a => a -> a -> a
<> a
" is not the desired " forall a. Semigroup a => a -> a -> 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 forall a. Eq a => a -> a -> Bool
== Text
expect
        then forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
        else Bool
False forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall w (m :: * -> *). MonadMiniWriter w m => w -> m ()
tell [a
"isOwner: owner " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Text
actual forall a. Semigroup a => a -> a -> a
<> a
" is not the desired " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Text
expect]

-- This uses tagless final to derive both an efficient and a tracing function.

evalCondition :: SecretContext -> Condition -> Bool
evalCondition :: SecretContext -> Condition -> Bool
evalCondition SecretContext
ctx Condition
c = forall {k} (s :: k) b. Tagged s b -> b
unTagged (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 = forall (m :: * -> *).
(Monad m, MonadMiniWriter [Text] m) =>
SecretContext -> Condition -> m Bool
evalCondition'

-- | Like 'Control.Monad.Class.Writer.MonadWriter' but simpler.
class MonadMiniWriter w m | m -> w where
  tell :: w -> m ()

instance Monoid w => MonadMiniWriter w ((,) w) where
  tell :: w -> (w, ())
tell = forall w (m :: * -> *). MonadWriter w m => w -> m ()
Control.Monad.Writer.tell

instance MonadMiniWriter w (Tagged w) where
  tell :: w -> Tagged w ()
tell w
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()