module Testlib.MockIntegrationService
( withMockServer,
lhMockAppWithPrekeys,
lhMockApp,
mkLegalHoldSettings,
CreateMock (..),
LiftedApplication,
MockServerSettings (..),
)
where
import Control.Monad.Catch
import Control.Monad.Reader
import qualified Data.Aeson
import qualified Data.ByteString.Lazy as LBS
import Data.Streaming.Network
import Data.String.Conversions (cs)
import Network.HTTP.Types
import Network.Socket
import qualified Network.Socket as Socket
import Network.Wai as Wai
import qualified Network.Wai.Handler.Warp as Warp
import qualified Network.Wai.Handler.Warp.Internal as Warp
import qualified Network.Wai.Handler.WarpTLS as Warp
import Testlib.Prelude hiding (IntegrationConfig (integrationTestHostName))
import UnliftIO (MonadUnliftIO (withRunInIO))
import UnliftIO.Async
import UnliftIO.Chan
import UnliftIO.MVar
import UnliftIO.Timeout (timeout)
withFreePortAnyAddr :: (MonadMask m, MonadIO m) => ((Warp.Port, Socket) -> m a) -> m a
withFreePortAnyAddr :: forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
((Port, Socket) -> m a) -> m a
withFreePortAnyAddr = m (Port, Socket)
-> ((Port, Socket) -> m ()) -> ((Port, Socket) -> m a) -> m a
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket m (Port, Socket)
forall (m :: * -> *). MonadIO m => m (Port, Socket)
openFreePortAnyAddr (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ())
-> ((Port, Socket) -> IO ()) -> (Port, Socket) -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Socket -> IO ()
Socket.close (Socket -> IO ())
-> ((Port, Socket) -> Socket) -> (Port, Socket) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Port, Socket) -> Socket
forall a b. (a, b) -> b
snd)
openFreePortAnyAddr :: (MonadIO m) => m (Warp.Port, Socket)
openFreePortAnyAddr :: forall (m :: * -> *). MonadIO m => m (Port, Socket)
openFreePortAnyAddr = IO (Port, Socket) -> m (Port, Socket)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Port, Socket) -> m (Port, Socket))
-> IO (Port, Socket) -> m (Port, Socket)
forall a b. (a -> b) -> a -> b
$ HostPreference -> IO (Port, Socket)
bindRandomPortTCP (String -> HostPreference
forall a. IsString a => String -> a
fromString String
"*6")
type LiftedApplication = Request -> (Wai.Response -> App ResponseReceived) -> App ResponseReceived
type Host = String
withMockServer ::
(HasCallStack) =>
MockServerSettings ->
(Chan e -> LiftedApplication) ->
((Host, Warp.Port) -> Chan e -> App a) ->
App a
withMockServer :: forall e a.
HasCallStack =>
MockServerSettings
-> (Chan e -> LiftedApplication)
-> ((String, Port) -> Chan e -> App a)
-> App a
withMockServer MockServerSettings
settings Chan e -> LiftedApplication
mkApp (String, Port) -> Chan e -> App a
go = ((Port, Socket) -> App a) -> App a
forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
((Port, Socket) -> m a) -> m a
withFreePortAnyAddr \(Port
sPort, Socket
sock) -> do
MVar ()
serverStarted <- App (MVar ())
forall (m :: * -> *) a. MonadIO m => m (MVar a)
newEmptyMVar
String
host <- (Env -> String) -> App String
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> String
integrationTestHostName
let tlss :: TLSSettings
tlss = ByteString -> ByteString -> TLSSettings
Warp.tlsSettingsMemory (String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs MockServerSettings
settings.certificate) (String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs MockServerSettings
settings.privateKey)
let defs :: Settings
defs = Settings
Warp.defaultSettings {Warp.settingsPort = sPort, Warp.settingsBeforeMainLoop = putMVar serverStarted ()}
Chan e
buf <- App (Chan e)
forall (m :: * -> *) a. MonadIO m => m (Chan a)
newChan
Async ()
srv <- App () -> App (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (App () -> App (Async ())) -> App () -> App (Async ())
forall a b. (a -> b) -> a -> b
$ ((forall a. App a -> IO a) -> IO ()) -> App ()
forall b. ((forall a. App a -> IO a) -> IO b) -> App b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO \forall a. App a -> IO a
inIO -> do
TLSSettings -> Settings -> Socket -> Application -> IO ()
Warp.runTLSSocket TLSSettings
tlss Settings
defs Socket
sock \Request
req Response -> IO ResponseReceived
respond -> do
App ResponseReceived -> IO ResponseReceived
forall a. App a -> IO a
inIO (App ResponseReceived -> IO ResponseReceived)
-> App ResponseReceived -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Chan e -> LiftedApplication
mkApp Chan e
buf Request
req (IO ResponseReceived -> App ResponseReceived
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ResponseReceived -> App ResponseReceived)
-> (Response -> IO ResponseReceived)
-> Response
-> App ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> IO ResponseReceived
respond)
Maybe ()
srvMVar <- Port -> App () -> App (Maybe ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
Port -> m a -> m (Maybe a)
UnliftIO.Timeout.timeout Port
5_000_000 (MVar () -> App ()
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
takeMVar MVar ()
serverStarted)
case Maybe ()
srvMVar of
Just () -> (String, Port) -> Chan e -> App a
go (String
host, Port
sPort) Chan e
buf App a -> App () -> App a
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
`finally` Async () -> App ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
cancel Async ()
srv
Maybe ()
Nothing -> String -> App a
forall a. HasCallStack => String -> a
error (String -> App a)
-> (Maybe (Either SomeException ()) -> String)
-> Maybe (Either SomeException ())
-> App a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Either SomeException ()) -> String
forall a. Show a => a -> String
show (Maybe (Either SomeException ()) -> App a)
-> App (Maybe (Either SomeException ())) -> App a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Async () -> App (Maybe (Either SomeException ()))
forall (m :: * -> *) a.
MonadIO m =>
Async a -> m (Maybe (Either SomeException a))
poll Async ()
srv
lhMockApp :: Chan (Wai.Request, LBS.ByteString) -> LiftedApplication
lhMockApp :: Chan (Request, ByteString) -> LiftedApplication
lhMockApp = CreateMock App -> Chan (Request, ByteString) -> LiftedApplication
lhMockAppWithPrekeys CreateMock App
forall a. Default a => a
def
data MockServerSettings = MkMockServerSettings
{
MockServerSettings -> String
certificate :: String,
MockServerSettings -> String
privateKey :: String,
MockServerSettings -> String
publicKey :: String
}
instance Default MockServerSettings where
def :: MockServerSettings
def =
MkMockServerSettings
{ $sel:certificate:MkMockServerSettings :: String
certificate = String
mockServerCert,
$sel:privateKey:MkMockServerSettings :: String
privateKey = String
mockServerPrivKey,
$sel:publicKey:MkMockServerSettings :: String
publicKey = String
mockServerPubKey
}
data CreateMock f = MkCreateMock
{
forall (f :: * -> *). CreateMock f -> f Value
nextLastPrey :: f Value,
forall (f :: * -> *). CreateMock f -> f [Value]
somePrekeys :: f [Value]
}
instance (App ~ f) => Default (CreateMock f) where
def :: CreateMock f
def =
MkCreateMock
{ $sel:nextLastPrey:MkCreateMock :: App Value
nextLastPrey = App Value
getLastPrekey,
$sel:somePrekeys:MkCreateMock :: App [Value]
somePrekeys = Port -> App Value -> App [Value]
forall (m :: * -> *) a. Applicative m => Port -> m a -> m [a]
replicateM Port
3 App Value
getPrekey
}
lhMockAppWithPrekeys ::
CreateMock App -> Chan (Wai.Request, LBS.ByteString) -> LiftedApplication
lhMockAppWithPrekeys :: CreateMock App -> Chan (Request, ByteString) -> LiftedApplication
lhMockAppWithPrekeys CreateMock App
mks Chan (Request, ByteString)
ch Request
req Response -> App ResponseReceived
cont = ((forall a. App a -> IO a) -> IO ResponseReceived)
-> App ResponseReceived
forall b. ((forall a. App a -> IO a) -> IO b) -> App b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO \forall a. App a -> IO a
inIO -> do
ByteString
reqBody <- Request -> IO ByteString
Wai.strictRequestBody Request
req
Chan (Request, ByteString) -> (Request, ByteString) -> IO ()
forall (m :: * -> *) a. MonadIO m => Chan a -> a -> m ()
writeChan Chan (Request, ByteString)
ch (Request
req, ByteString
reqBody)
App ResponseReceived -> IO ResponseReceived
forall a. App a -> IO a
inIO do
(Value
nextLastPrekey, [Value]
threePrekeys) <-
(,)
(Value -> [Value] -> (Value, [Value]))
-> App Value -> App ([Value] -> (Value, [Value]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CreateMock App
mks.nextLastPrey
App ([Value] -> (Value, [Value]))
-> App [Value] -> App (Value, [Value])
forall a b. App (a -> b) -> App a -> App b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CreateMock App
mks.somePrekeys
case (Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> String) -> [Text] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request -> [Text]
pathInfo Request
req, ByteString -> String
forall a b. ConvertibleStrings a b => a -> b
cs (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
requestMethod Request
req, forall a b. ConvertibleStrings a b => a -> b
cs @_ @String (ByteString -> String) -> Maybe ByteString -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Request -> Maybe ByteString
getRequestHeader String
"Authorization" Request
req) of
([String
"legalhold", String
"status"], String
"GET", Maybe String
_) -> Response -> App ResponseReceived
cont Response
respondOk
([String]
_, String
_, Maybe String
Nothing) -> Response -> App ResponseReceived
cont Response
missingAuth
([String
"legalhold", String
"initiate"], String
"POST", Just String
_) -> Response -> App ResponseReceived
cont (Value -> [Value] -> Response
initiateResp Value
nextLastPrekey [Value]
threePrekeys)
([String
"legalhold", String
"confirm"], String
"POST", Just String
_) -> Response -> App ResponseReceived
cont Response
respondOk
([String
"legalhold", String
"remove"], String
"POST", Just String
_) -> Response -> App ResponseReceived
cont Response
respondOk
([String], String, Maybe String)
_ -> Response -> App ResponseReceived
cont Response
respondBad
where
initiateResp :: Value -> [Value] -> Wai.Response
initiateResp :: Value -> [Value] -> Response
initiateResp Value
npk [Value]
pks =
Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status200 [(HeaderName
hContentType, String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs String
"application/json")]
(ByteString -> Response)
-> ([Pair] -> ByteString) -> [Pair] -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode
(Value -> ByteString) -> ([Pair] -> Value) -> [Pair] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pair] -> Value
Data.Aeson.object
([Pair] -> Response) -> [Pair] -> Response
forall a b. (a -> b) -> a -> b
$ [ String
"prekeys" String -> [Value] -> Pair
forall a. ToJSON a => String -> a -> Pair
.= [Value]
pks,
String
"last_prekey" String -> Value -> Pair
forall a. ToJSON a => String -> a -> Pair
.= Value
npk
]
respondOk :: Wai.Response
respondOk :: Response
respondOk = Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status200 ResponseHeaders
forall a. Monoid a => a
mempty ByteString
forall a. Monoid a => a
mempty
respondBad :: Wai.Response
respondBad :: Response
respondBad = Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status404 ResponseHeaders
forall a. Monoid a => a
mempty ByteString
forall a. Monoid a => a
mempty
missingAuth :: Wai.Response
missingAuth :: Response
missingAuth = Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
status400 ResponseHeaders
forall a. Monoid a => a
mempty (String -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs String
"no authorization header")
getRequestHeader :: String -> Wai.Request -> Maybe ByteString
getRequestHeader :: String -> Request -> Maybe ByteString
getRequestHeader String
name = HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (String -> HeaderName
forall a. IsString a => String -> a
fromString String
name) (ResponseHeaders -> Maybe ByteString)
-> (Request -> ResponseHeaders) -> Request -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> ResponseHeaders
requestHeaders
mkLegalHoldSettings :: (String, Warp.Port) -> Value
mkLegalHoldSettings :: (String, Port) -> Value
mkLegalHoldSettings (String
botHost, Port
lhPort) =
[Pair] -> Value
object
[ String
"base_url" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= (String
"https://" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
botHost String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
":" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Port -> String
forall a. Show a => a -> String
show Port
lhPort String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/legalhold"),
String
"public_key" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
mockServerPubKey,
String
"auth_token" String -> String -> Pair
forall a. ToJSON a => String -> a -> Pair
.= String
"tok"
]
mockServerPubKey :: String
mockServerPubKey :: String
mockServerPubKey =
String
"-----BEGIN PUBLIC KEY-----\n\
\MIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEAu+Kg/PHHU3atXrUbKnw0\n\
\G06FliXcNt3lMwl2os5twEDcPPFw/feGiAKymxp+7JqZDrseS5D9THGrW+OQRIPH\n\
\WvUBdiLfGrZqJO223DB6D8K2Su/odmnjZJ2z23rhXoEArTplu+Dg9K+c2LVeXTKV\n\
\VPOaOzgtAB21XKRiQ4ermqgi3/njr03rXyq/qNkuNd6tNcg+HAfGxfGvvCSYBfiS\n\
\bUKr/BeArYRcjzr/h5m1In6fG/if9GEI6m8dxHT9JbY53wiksowy6ajCuqskIFg8\n\
\7X883H+LA/d6X5CTiPv1VMxXdBUiGPuC9IT/6CNQ1/LFt0P37ax58+LGYlaFo7la\n\
\nQIDAQAB\n\
\-----END PUBLIC KEY-----"
mockServerPrivKey :: String
mockServerPrivKey :: String
mockServerPrivKey =
String
"-----BEGIN RSA PRIVATE KEY-----\n\
\MIIEpAIBAAKCAQEAu+Kg/PHHU3atXrUbKnw0G06FliXcNt3lMwl2os5twEDcPPFw\n\
\/feGiAKymxp+7JqZDrseS5D9THGrW+OQRIPHWvUBdiLfGrZqJO223DB6D8K2Su/o\n\
\dmnjZJ2z23rhXoEArTplu+Dg9K+c2LVeXTKVVPOaOzgtAB21XKRiQ4ermqgi3/nj\n\
\r03rXyq/qNkuNd6tNcg+HAfGxfGvvCSYBfiSbUKr/BeArYRcjzr/h5m1In6fG/if\n\
\9GEI6m8dxHT9JbY53wiksowy6ajCuqskIFg87X883H+LA/d6X5CTiPv1VMxXdBUi\n\
\GPuC9IT/6CNQ1/LFt0P37ax58+LGYlaFo7lanQIDAQABAoIBAQC0doVy7zgpLsBv\n\
\Sz0AnbPe1pjxEwRlntRbJSfSULySALqJvs5s4adSVGUBHX3z/LousAP1SRpCppuU\n\
\8wrLBFgjQVlaAzyQB84EEl+lNtrG8Jrvd2es9R/4sJDkqy50+yuPN5wnzWPFIjhg\n\
\3jP5CHDu29y0LMzsY5yjkzDe9B0bueXEZVU+guRjhpwHHKOFeAr9J9bugFUwgeAr\n\
\jF0TztzFAb0fsUNPiQAho1J5PyjSVgItaPfAPv/p30ROG+rz+Rd5NSSvBC5F+yOo\n\
\azb84zzwCg/knAfIz7SOMRrmBh2qhGZFZ8gXdq65UaYv+cpT/qo28mpAT2vOkyeD\n\
\aPZp0ysBAoGBAOQROoDipe/5BTHBcXYuUE1qa4RIj3wgql5I8igXr4K6ppYBmaOg\n\
\DL2rrnqD86chv0P4l/XOomKFwYhVGXtqRkeYnk6mQXwNVkgqcGbY5PSNyMg5+ekq\n\
\jSOOPHGzzTWKzYuUDUpB/Lf6jbTv8fq2GYW3ZYiqQ/xiugOvglZrTE7NAoGBANLl\n\
\irjByfxAWGhzCrDx0x5MBpsetadI9wUA8u1BDdymsRg73FDn3z7NipVUAMDXMGVj\n\
\lqbCRlHESO2yP4GaPEA4FM+MbTZSuhAYV+SY07mEPLHF64/nJas83Zp91r5rhaqJ\n\
\L9rWCl3KJ5OUnr3YizCnHIW72FxjwtpjxHJLupsRAoGAGIbhy8qUHeKh9F/hW9xP\n\
\NoQjW+6Rv7+jktA1eqpRbbW1BJzXcQldVWiJMxPNuEOg1iZ98SlvvTi1P3wnaWZc\n\
\eIapP7wRfs3QYaJuxCC/Pq2g0ieqALFazGAXkALOJtvujvw1Ea9XBlIjuzmyxEuh\n\
\Iwg+Gxx0g0f6yTquwax4YGECgYEAnpAK3qKFNO1ECzQDo8oNy0ep59MNDPtlDhQK\n\
\katJus5xdCD9oq7TQKrVOTTxZAvmzTQ1PqfuqueDVYOhD9Zg2n/P1cRlEGTek99Z\n\
\pfvppB/yak6+r3FA9yBKFS/r1zuMQg3nNweav62QV/tz5pT7AdeDMGFtaPlwtTYx\n\
\qyWY5aECgYBPySbPccNj+xxQzxcti2y/UXjC04RgOA/Hm1D0exa0vBqS9uxlOdG8\n\
\F47rKenpBrslvdfTVsCDB1xyP2ebWVzp6EqMycw6OLPxgo3fBfZ4pi6P+rByh0Cc\n\
\Lhfh+ET0CPnKCxtop3lUrn4ZvqchS0j3J+M0pDuqoWF5hfKxFhkEIw==\n\
\-----END RSA PRIVATE KEY-----"
mockServerCert :: String
mockServerCert :: String
mockServerCert =
String
"-----BEGIN CERTIFICATE-----\n\
\MIIDdjCCAl4CCQCm0AiwERR/qjANBgkqhkiG9w0BAQsFADB9MQswCQYDVQQGEwJE\n\
\RTEPMA0GA1UECAwGQmVybGluMQ8wDQYDVQQHDAZCZXJsaW4xGDAWBgNVBAoMD1dp\n\
\cmUgU3dpc3MgR21iSDERMA8GA1UEAwwId2lyZS5jb20xHzAdBgkqhkiG9w0BCQEW\n\
\EGJhY2tlbmRAd2lyZS5jb20wHhcNMTYwODA0MTMxNDQyWhcNMzYwNzMwMTMxNDQy\n\
\WjB9MQswCQYDVQQGEwJERTEPMA0GA1UECAwGQmVybGluMQ8wDQYDVQQHDAZCZXJs\n\
\aW4xGDAWBgNVBAoMD1dpcmUgU3dpc3MgR21iSDERMA8GA1UEAwwId2lyZS5jb20x\n\
\HzAdBgkqhkiG9w0BCQEWEGJhY2tlbmRAd2lyZS5jb20wggEiMA0GCSqGSIb3DQEB\n\
\AQUAA4IBDwAwggEKAoIBAQC74qD88cdTdq1etRsqfDQbToWWJdw23eUzCXaizm3A\n\
\QNw88XD994aIArKbGn7smpkOux5LkP1Mcatb45BEg8da9QF2It8atmok7bbcMHoP\n\
\wrZK7+h2aeNknbPbeuFegQCtOmW74OD0r5zYtV5dMpVU85o7OC0AHbVcpGJDh6ua\n\
\qCLf+eOvTetfKr+o2S413q01yD4cB8bF8a+8JJgF+JJtQqv8F4CthFyPOv+HmbUi\n\
\fp8b+J/0YQjqbx3EdP0ltjnfCKSyjDLpqMK6qyQgWDztfzzcf4sD93pfkJOI+/VU\n\
\zFd0FSIY+4L0hP/oI1DX8sW3Q/ftrHnz4sZiVoWjuVqdAgMBAAEwDQYJKoZIhvcN\n\
\AQELBQADggEBAEuwlHElIGR56KVC1dJiw238mDGjMfQzSP76Wi4zWS6/zZwJUuog\n\
\BkC+vacfju8UAMvL+vdqkjOVUHor84/2wuq0qn91AjOITD7tRAZB+XLXxsikKv/v\n\
\OXE3A/lCiNi882NegPyXAfFPp/71CIiTQZps1eQkAvhD5t5WiFYPESxDlvEJrHFY\n\
\XP4+pp8fL8YPS7iZNIq+z+P8yVIw+B/Hs0ht7wFIYN0xACbU8m9+Rs08JMoT16c+\n\
\hZMuK3BWD3fzkQVfW0yMwz6fWRXB483ZmekGkgndOTDoJQMdJXZxHpI3t2FcxQYj\n\
\T45GXxRd18neXtuYa/OoAw9UQFDN5XfXN0g=\n\
\-----END CERTIFICATE-----"