module Testlib.App where

import Control.Applicative ((<|>))
import Control.Monad.Reader
import Control.Monad.Trans.Maybe (MaybeT (MaybeT), runMaybeT)
import qualified Control.Retry as Retry
import Data.Aeson hiding ((.=))
import Data.Bool (bool)
import Data.IORef
import Data.Maybe (isJust)
import qualified Data.Text as T
import qualified Data.Yaml as Yaml
import GHC.Exception
import GHC.Generics (Generic)
import GHC.Stack (HasCallStack)
import System.FilePath
import Testlib.JSON
import Testlib.Types
import Prelude

failApp :: (HasCallStack) => String -> App a
failApp :: forall a. HasCallStack => String -> App a
failApp String
msg = AppFailure -> App a
forall a e. Exception e => e -> a
throw (String -> AppFailure
AppFailure String
msg)

getPrekey :: App Value
getPrekey :: App Value
getPrekey = ReaderT Env IO Value -> App Value
forall a. ReaderT Env IO a -> App a
App (ReaderT Env IO Value -> App Value)
-> ReaderT Env IO Value -> App Value
forall a b. (a -> b) -> a -> b
$ do
  IORef [(Int, String)]
pks <- (Env -> IORef [(Int, String)])
-> ReaderT Env IO (IORef [(Int, String)])
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.prekeys)
  (Int
i, String
pk) <- IO (Int, String) -> ReaderT Env IO (Int, String)
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Int, String) -> ReaderT Env IO (Int, String))
-> IO (Int, String) -> ReaderT Env IO (Int, String)
forall a b. (a -> b) -> a -> b
$ IORef [(Int, String)]
-> ([(Int, String)] -> ([(Int, String)], (Int, String)))
-> IO (Int, String)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef [(Int, String)]
pks [(Int, String)] -> ([(Int, String)], (Int, String))
forall {b}. [b] -> ([b], b)
getPK
  Value -> ReaderT Env IO Value
forall a. a -> ReaderT Env IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> ReaderT Env IO Value) -> Value -> ReaderT Env IO Value
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [String
"id" String -> Int -> Pair
forall a. ToJSON a => String -> a -> Pair
.= Int
i, String
"key" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
pk]
  where
    getPK :: [b] -> ([b], b)
getPK [] = String -> ([b], b)
forall a. HasCallStack => String -> a
error String
"Out of prekeys"
    getPK (b
k : [b]
ks) = ([b]
ks, b
k)

getLastPrekey :: App Value
getLastPrekey :: App Value
getLastPrekey = ReaderT Env IO Value -> App Value
forall a. ReaderT Env IO a -> App a
App (ReaderT Env IO Value -> App Value)
-> ReaderT Env IO Value -> App Value
forall a b. (a -> b) -> a -> b
$ do
  IORef [String]
pks <- (Env -> IORef [String]) -> ReaderT Env IO (IORef [String])
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (.lastPrekeys)
  String
lpk <- IO String -> ReaderT Env IO String
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> ReaderT Env IO String)
-> IO String -> ReaderT Env IO String
forall a b. (a -> b) -> a -> b
$ IORef [String] -> ([String] -> ([String], String)) -> IO String
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef [String]
pks [String] -> ([String], String)
forall {b}. [b] -> ([b], b)
getPK
  Value -> ReaderT Env IO Value
forall a. a -> ReaderT Env IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> ReaderT Env IO Value) -> Value -> ReaderT Env IO Value
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [String
"id" String -> Int -> Pair
forall a. ToJSON a => String -> a -> Pair
.= Int
lastPrekeyId, String
"key" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
lpk]
  where
    getPK :: [b] -> ([b], b)
getPK [] = String -> ([b], b)
forall a. HasCallStack => String -> a
error String
"No last prekey left"
    getPK (b
k : [b]
ks) = ([b]
ks, b
k)

    lastPrekeyId :: Int
    lastPrekeyId :: Int
lastPrekeyId = Int
65535

readServiceConfig :: Service -> App Value
readServiceConfig :: Service -> App Value
readServiceConfig = String -> App Value
readServiceConfig' (String -> App Value)
-> (Service -> String) -> Service -> App Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Service -> String
configName

readServiceConfig' :: String -> App Value
readServiceConfig' :: String -> App Value
readServiceConfig' String
srvName = do
  String
cfgFile <- (Env -> String) -> App String
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks \Env
env -> case Env
env.servicesCwdBase of
    Maybe String
Nothing -> String
"/etc/wire" String -> String -> String
</> String
srvName String -> String -> String
</> String
"conf" String -> String -> String
</> (String
srvName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
".yaml")
    Just String
p -> String
p String -> String -> String
</> String
srvName String -> String -> String
</> (String
srvName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
".integration.yaml")

  Either ParseException Value
eith <- IO (Either ParseException Value)
-> App (Either ParseException Value)
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO (Either ParseException Value)
forall a. FromJSON a => String -> IO (Either ParseException a)
Yaml.decodeFileEither String
cfgFile)
  case Either ParseException Value
eith of
    Left ParseException
err -> String -> App Value
forall a. HasCallStack => String -> App a
failApp (String
"Error while parsing " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
cfgFile String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ParseException -> String
Yaml.prettyPrintParseException ParseException
err)
    Right Value
value -> Value -> App Value
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
value

data Domain = OwnDomain | OtherDomain
  deriving stock (Domain -> Domain -> Bool
(Domain -> Domain -> Bool)
-> (Domain -> Domain -> Bool) -> Eq Domain
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Domain -> Domain -> Bool
== :: Domain -> Domain -> Bool
$c/= :: Domain -> Domain -> Bool
/= :: Domain -> Domain -> Bool
Eq, Int -> Domain -> String -> String
[Domain] -> String -> String
Domain -> String
(Int -> Domain -> String -> String)
-> (Domain -> String)
-> ([Domain] -> String -> String)
-> Show Domain
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Domain -> String -> String
showsPrec :: Int -> Domain -> String -> String
$cshow :: Domain -> String
show :: Domain -> String
$cshowList :: [Domain] -> String -> String
showList :: [Domain] -> String -> String
Show, (forall x. Domain -> Rep Domain x)
-> (forall x. Rep Domain x -> Domain) -> Generic Domain
forall x. Rep Domain x -> Domain
forall x. Domain -> Rep Domain x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Domain -> Rep Domain x
from :: forall x. Domain -> Rep Domain x
$cto :: forall x. Rep Domain x -> Domain
to :: forall x. Rep Domain x -> Domain
Generic)

instance MakesValue Domain where
  make :: HasCallStack => Domain -> App Value
make Domain
OwnDomain = (Env -> Value) -> App Value
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Text -> Value
String (Text -> Value) -> (Env -> Text) -> Env -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (Env -> String) -> Env -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.domain1))
  make Domain
OtherDomain = (Env -> Value) -> App Value
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Text -> Value
String (Text -> Value) -> (Env -> Text) -> Env -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (Env -> String) -> Env -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.domain2))

-- | Run an action, `recoverAll`ing with exponential backoff (min step 8ms, total timeout
-- ~15s).  Search this package for examples how to use it.
--
-- Ideally, this will be the only thing you'll ever need from the retry package when writing
-- integration tests.  If you are unhappy with it, please consider making it more general in a
-- backwards-compatible way so everybody can benefit.
retryT :: App a -> App a
retryT :: forall a. App a -> App a
retryT App a
action = RetryPolicyM App -> (RetryStatus -> App a) -> App a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RetryPolicyM m -> (RetryStatus -> m a) -> m a
Retry.recoverAll (Int -> RetryPolicyM App
forall (m :: * -> *). Monad m => Int -> RetryPolicyM m
Retry.exponentialBackoff Int
8000 RetryPolicyM App -> RetryPolicyM App -> RetryPolicyM App
forall a. Semigroup a => a -> a -> a
<> Int -> RetryPolicy
Retry.limitRetries Int
10) (App a -> RetryStatus -> App a
forall a b. a -> b -> a
const App a
action)

-- | make Bool lazy
liftBool :: (Functor f) => f Bool -> BoolT f
liftBool :: forall (f :: * -> *). Functor f => f Bool -> BoolT f
liftBool = f (Maybe ()) -> MaybeT f ()
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (f (Maybe ()) -> MaybeT f ())
-> (f Bool -> f (Maybe ())) -> f Bool -> MaybeT f ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Maybe ()) -> f Bool -> f (Maybe ())
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe () -> Maybe () -> Bool -> Maybe ()
forall a. a -> a -> Bool -> a
bool Maybe ()
forall a. Maybe a
Nothing (() -> Maybe ()
forall a. a -> Maybe a
Just ()))

-- | make Bool strict
unliftBool :: (Functor f) => BoolT f -> f Bool
unliftBool :: forall (f :: * -> *). Functor f => BoolT f -> f Bool
unliftBool = (Maybe () -> Bool) -> f (Maybe ()) -> f Bool
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe () -> Bool
forall a. Maybe a -> Bool
isJust (f (Maybe ()) -> f Bool)
-> (BoolT f -> f (Maybe ())) -> BoolT f -> f Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BoolT f -> f (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT

-- | lazy (&&)
(&&~) :: App Bool -> App Bool -> App Bool
App Bool
b1 &&~ :: App Bool -> App Bool -> App Bool
&&~ App Bool
b2 = BoolT App -> App Bool
forall (f :: * -> *). Functor f => BoolT f -> f Bool
unliftBool (BoolT App -> App Bool) -> BoolT App -> App Bool
forall a b. (a -> b) -> a -> b
$ App Bool -> BoolT App
forall (f :: * -> *). Functor f => f Bool -> BoolT f
liftBool App Bool
b1 BoolT App -> BoolT App -> BoolT App
forall a b. MaybeT App a -> MaybeT App b -> MaybeT App b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> App Bool -> BoolT App
forall (f :: * -> *). Functor f => f Bool -> BoolT f
liftBool App Bool
b2

infixr 3 &&~

-- | lazy (||)
(||~) :: App Bool -> App Bool -> App Bool
App Bool
b1 ||~ :: App Bool -> App Bool -> App Bool
||~ App Bool
b2 = BoolT App -> App Bool
forall (f :: * -> *). Functor f => BoolT f -> f Bool
unliftBool (BoolT App -> App Bool) -> BoolT App -> App Bool
forall a b. (a -> b) -> a -> b
$ App Bool -> BoolT App
forall (f :: * -> *). Functor f => f Bool -> BoolT f
liftBool App Bool
b1 BoolT App -> BoolT App -> BoolT App
forall a. MaybeT App a -> MaybeT App a -> MaybeT App a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> App Bool -> BoolT App
forall (f :: * -> *). Functor f => f Bool -> BoolT f
liftBool App Bool
b2

infixr 2 ||~

-- | lazy (&&): (*>)
--   lazy (||): (<|>)
type BoolT f = MaybeT f ()