2020-10-04 16:27:38 +03:00
|
|
|
{-# LANGUAGE LambdaCase #-}
|
2020-09-17 04:05:14 +03:00
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
2020-10-04 16:27:38 +03:00
|
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
2020-09-17 04:05:14 +03:00
|
|
|
|
2020-09-17 03:49:49 +03:00
|
|
|
module Main where
|
|
|
|
|
2020-10-04 16:27:38 +03:00
|
|
|
import Control.Exception (SomeException (..), try)
|
|
|
|
import Data.Aeson (KeyValue ((.=)))
|
|
|
|
import qualified Data.Aeson as Aeson
|
2020-11-13 22:52:15 +03:00
|
|
|
import qualified Data.Conduit.Binary
|
2020-10-04 16:27:38 +03:00
|
|
|
import Data.Text (Text)
|
|
|
|
import qualified Data.Text as Text
|
|
|
|
import qualified Data.Text.IO as Text.IO
|
2020-10-10 16:06:11 +03:00
|
|
|
import qualified Data.UUID as UUID
|
|
|
|
import qualified Data.UUID.V4 as UUID
|
2020-10-12 18:53:52 +03:00
|
|
|
import qualified System.Environment as Env
|
2020-10-12 18:58:34 +03:00
|
|
|
import qualified System.Exit as Exit
|
2020-11-29 17:57:46 +03:00
|
|
|
import Urbit.API
|
2020-09-17 03:49:49 +03:00
|
|
|
|
2020-10-04 16:27:38 +03:00
|
|
|
main :: IO ()
|
2020-09-17 03:49:49 +03:00
|
|
|
main = do
|
2020-10-22 00:30:00 +03:00
|
|
|
port <- Text.pack <$> Env.getEnv "PORT"
|
2020-10-12 18:53:52 +03:00
|
|
|
let ship = fakezod port
|
2020-10-22 00:30:00 +03:00
|
|
|
sess <- connect ship
|
2020-10-06 04:21:48 +03:00
|
|
|
testing "ship connection" $
|
2020-10-22 00:30:00 +03:00
|
|
|
connect ship >> return True
|
2020-10-05 23:17:59 +03:00
|
|
|
|
2020-10-06 04:21:48 +03:00
|
|
|
testing "poke ship" $
|
2020-10-22 00:30:00 +03:00
|
|
|
do
|
2020-10-12 18:59:20 +03:00
|
|
|
uuid <- UUID.nextRandom
|
2020-10-22 00:30:00 +03:00
|
|
|
_ <-
|
2020-10-10 16:06:11 +03:00
|
|
|
poke sess ship "zod" "chat-hook" "json" $
|
2020-10-06 04:21:48 +03:00
|
|
|
Aeson.object
|
|
|
|
[ "message"
|
|
|
|
.= Aeson.object
|
|
|
|
[ "path" .= Text.pack "/~/~zod/mc",
|
|
|
|
"envelope"
|
|
|
|
.= Aeson.object
|
2020-10-12 18:59:20 +03:00
|
|
|
[ "uid" .= UUID.toText uuid,
|
2020-10-12 17:11:33 +03:00
|
|
|
"number" .= (1 :: Int), -- FIXME: should this be lastEventId?
|
2020-10-06 04:21:48 +03:00
|
|
|
"author" .= Text.pack "~zod",
|
2020-10-12 17:11:33 +03:00
|
|
|
"when" .= (1602118786225 :: Int),
|
2020-10-20 23:56:15 +03:00
|
|
|
"letter" .= Aeson.object ["text" .= Text.pack "hello world from haskell!"]
|
2020-10-06 04:21:48 +03:00
|
|
|
]
|
|
|
|
]
|
|
|
|
]
|
2020-10-22 00:30:00 +03:00
|
|
|
return $ True
|
2020-10-06 04:21:48 +03:00
|
|
|
|
|
|
|
testing "ack" $
|
2020-10-22 00:30:00 +03:00
|
|
|
ack sess ship 1 >> return True
|
2020-10-05 23:17:59 +03:00
|
|
|
|
2020-10-23 01:15:14 +03:00
|
|
|
-- These tests are basically just checking that a connection happens and
|
|
|
|
-- doesn't throw, I need to pull in async in order to check for more
|
|
|
|
-- correctness. Ideally: subscribe, send a message, then read the message to
|
|
|
|
-- ensure its the same as the one sent. But maybe this is already tested in
|
|
|
|
-- urbit core?
|
|
|
|
|
2020-10-22 16:56:39 +03:00
|
|
|
testing "subscribe" $ do
|
2020-10-23 01:15:14 +03:00
|
|
|
_ <- subscribe sess ship "/mailbox/~/~zod/mc" Data.Conduit.Binary.sinkLbs
|
2020-10-22 16:56:39 +03:00
|
|
|
return True
|
|
|
|
|
2020-10-22 00:30:00 +03:00
|
|
|
fakezod :: Text -> Ship
|
2020-10-12 18:53:52 +03:00
|
|
|
fakezod port =
|
2020-10-05 23:17:59 +03:00
|
|
|
Ship
|
2020-10-10 16:06:11 +03:00
|
|
|
{ uid = "0123456789abcdef",
|
2020-10-05 23:52:58 +03:00
|
|
|
name = "zod",
|
2020-10-12 17:11:33 +03:00
|
|
|
lastEventId = 1,
|
2020-10-22 00:30:00 +03:00
|
|
|
url = "http://localhost:" <> port,
|
2020-10-21 00:12:52 +03:00
|
|
|
code = "lidlut-tabwed-pillex-ridrup"
|
2020-10-05 23:17:59 +03:00
|
|
|
}
|
2020-10-04 16:27:38 +03:00
|
|
|
|
|
|
|
-- | Poor man's testing framework
|
2020-10-05 23:17:59 +03:00
|
|
|
testing :: Text -> IO Bool -> IO ()
|
2020-10-04 16:27:38 +03:00
|
|
|
testing description f =
|
|
|
|
(putStrLn $ replicate 80 '-') >> try f >>= \case
|
|
|
|
Left (err :: SomeException) -> do
|
|
|
|
Text.IO.putStrLn $ "FAIL: " <> description
|
2020-10-12 18:58:34 +03:00
|
|
|
Exit.die $ show err
|
2020-10-05 23:17:59 +03:00
|
|
|
Right False -> do
|
|
|
|
Text.IO.putStrLn $ "FAIL: " <> description
|
2020-10-12 18:58:34 +03:00
|
|
|
Exit.die "expected True, got False"
|
2020-10-05 23:17:59 +03:00
|
|
|
Right True ->
|
2020-10-04 16:27:38 +03:00
|
|
|
Text.IO.putStrLn $ "PASS: " <> description
|