2020-10-22 00:30:00 +03:00
|
|
|
{-# LANGUAGE DataKinds #-}
|
2020-10-22 16:56:39 +03:00
|
|
|
{-# LANGUAGE FlexibleInstances #-}
|
2020-10-22 00:30:00 +03:00
|
|
|
{-# LANGUAGE LambdaCase #-}
|
2020-08-27 15:34:41 +03:00
|
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
2020-10-22 16:56:39 +03:00
|
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
2020-08-27 15:34:41 +03:00
|
|
|
|
2020-09-23 15:10:40 +03:00
|
|
|
module Urbit.Airlock
|
2020-10-04 16:27:49 +03:00
|
|
|
( Ship (..),
|
2020-09-23 15:10:40 +03:00
|
|
|
App,
|
|
|
|
Mark,
|
|
|
|
connect,
|
|
|
|
poke,
|
2020-10-06 04:21:48 +03:00
|
|
|
ack,
|
2020-10-19 20:41:34 +03:00
|
|
|
subscribe,
|
2020-10-04 16:27:49 +03:00
|
|
|
)
|
|
|
|
where
|
2020-08-27 15:34:41 +03:00
|
|
|
|
2020-10-22 16:56:39 +03:00
|
|
|
import Conduit (ConduitM, runConduitRes, (.|))
|
|
|
|
import qualified Conduit
|
|
|
|
import qualified Control.Exception as Exception
|
2020-10-10 16:06:11 +03:00
|
|
|
import Control.Lens ()
|
|
|
|
import Data.Aeson ((.=))
|
2020-08-27 15:34:41 +03:00
|
|
|
import qualified Data.Aeson as Aeson
|
2020-10-05 23:17:59 +03:00
|
|
|
import Data.ByteString (ByteString)
|
2020-08-27 15:34:41 +03:00
|
|
|
import Data.Text (Text)
|
2020-10-10 16:06:11 +03:00
|
|
|
import qualified Data.Text as Text
|
2020-10-22 00:30:00 +03:00
|
|
|
import qualified Network.HTTP.Client as HTTP
|
|
|
|
import Network.HTTP.Req ((=:))
|
|
|
|
import qualified Network.HTTP.Req as Req
|
2020-10-22 16:56:39 +03:00
|
|
|
import qualified Network.HTTP.Req.Conduit as Req
|
2020-10-22 00:30:00 +03:00
|
|
|
import qualified Text.URI as URI
|
2020-08-27 15:34:41 +03:00
|
|
|
|
|
|
|
data Ship = Ship
|
2020-10-10 16:06:11 +03:00
|
|
|
{ -- | A random string for your channel.
|
|
|
|
uid :: Text,
|
|
|
|
-- | The `@p` of your ship.
|
2020-10-05 23:52:58 +03:00
|
|
|
name :: ShipName,
|
2020-09-23 15:10:40 +03:00
|
|
|
-- | Track the latest event we saw (needed for poking).
|
2020-08-27 15:34:41 +03:00
|
|
|
lastEventId :: Int,
|
2020-10-21 00:12:52 +03:00
|
|
|
-- | Network access point, with port if necessary. Like
|
|
|
|
-- 'https://sampel-palnet.arvo.network', or 'http://localhost:8080'.
|
2020-10-22 00:30:00 +03:00
|
|
|
url :: Text,
|
2020-09-23 15:10:40 +03:00
|
|
|
-- | Login code, `+code` in the dojo. Don't share this publically.
|
2020-10-21 00:12:52 +03:00
|
|
|
code :: Text
|
2020-08-27 15:34:41 +03:00
|
|
|
}
|
|
|
|
deriving (Show)
|
|
|
|
|
2020-10-22 00:30:00 +03:00
|
|
|
channelUrl :: Ship -> Text
|
|
|
|
channelUrl Ship {url, uid} = url <> "/~/channel/" <> uid
|
2020-10-04 16:27:49 +03:00
|
|
|
|
2020-08-27 15:34:41 +03:00
|
|
|
type App = Text
|
2020-10-04 16:27:49 +03:00
|
|
|
|
2020-08-27 15:34:41 +03:00
|
|
|
type Path = Text
|
2020-10-04 16:27:49 +03:00
|
|
|
|
2020-08-27 15:34:41 +03:00
|
|
|
type Mark = Text
|
2020-10-04 16:27:49 +03:00
|
|
|
|
2020-10-05 23:52:58 +03:00
|
|
|
-- | The `@p` for the ship (no leading ~).
|
2020-10-04 16:27:49 +03:00
|
|
|
type ShipName = Text
|
2020-08-27 15:34:41 +03:00
|
|
|
|
|
|
|
-- |
|
|
|
|
nextEventId :: Ship -> Int
|
2020-10-04 16:27:49 +03:00
|
|
|
nextEventId Ship {lastEventId} = lastEventId + 1
|
2020-08-27 15:34:41 +03:00
|
|
|
|
2020-10-22 00:30:00 +03:00
|
|
|
type Session = HTTP.CookieJar
|
|
|
|
|
2020-10-06 04:19:08 +03:00
|
|
|
-- | Connect and login to the ship.
|
2020-10-22 00:30:00 +03:00
|
|
|
connect :: Ship -> IO Session
|
|
|
|
connect ship =
|
|
|
|
Req.useURI <$> (URI.mkURI $ url ship <> "/~/login") >>= \case
|
|
|
|
Nothing -> error "could not parse ship url"
|
|
|
|
Just uri ->
|
|
|
|
Req.runReq Req.defaultHttpConfig $
|
|
|
|
Req.responseCookieJar <$> either con con uri
|
|
|
|
where
|
|
|
|
body = "password" =: (code ship)
|
|
|
|
con (url, opts) =
|
|
|
|
Req.req Req.POST url (Req.ReqBodyUrlEnc body) Req.ignoreResponse $
|
|
|
|
opts
|
2020-08-27 15:34:41 +03:00
|
|
|
|
2020-09-23 15:10:40 +03:00
|
|
|
-- | Poke a ship.
|
|
|
|
poke ::
|
2020-10-04 16:27:49 +03:00
|
|
|
Aeson.ToJSON a =>
|
2020-10-22 00:30:00 +03:00
|
|
|
Session ->
|
2020-09-23 15:10:40 +03:00
|
|
|
Ship ->
|
2020-10-04 16:27:49 +03:00
|
|
|
-- | To what ship will you send the poke?
|
|
|
|
ShipName ->
|
2020-09-23 15:10:40 +03:00
|
|
|
-- | Which gall application are you trying to poke?
|
|
|
|
App ->
|
|
|
|
-- | What mark should be applied to the data you are sending?
|
|
|
|
Mark ->
|
2020-10-04 16:27:49 +03:00
|
|
|
a ->
|
2020-10-22 00:30:00 +03:00
|
|
|
IO Req.IgnoreResponse
|
2020-10-10 16:06:11 +03:00
|
|
|
poke sess ship shipName app mark json =
|
2020-10-22 00:30:00 +03:00
|
|
|
Req.useURI <$> (URI.mkURI $ channelUrl ship) >>= \case
|
|
|
|
Nothing -> error "could not parse ship url"
|
|
|
|
Just uri ->
|
|
|
|
Req.runReq Req.defaultHttpConfig $
|
|
|
|
either con con uri
|
|
|
|
where
|
|
|
|
con (url, opts) =
|
|
|
|
Req.req
|
|
|
|
Req.POST
|
|
|
|
url
|
|
|
|
(Req.ReqBodyJson body)
|
|
|
|
Req.ignoreResponse
|
|
|
|
$ opts <> Req.cookieJar sess
|
|
|
|
body =
|
2020-10-20 23:56:15 +03:00
|
|
|
[ Aeson.object
|
|
|
|
[ "id" .= nextEventId ship,
|
|
|
|
"action" .= Text.pack "poke",
|
|
|
|
"ship" .= shipName,
|
|
|
|
"app" .= app,
|
|
|
|
"mark" .= mark,
|
|
|
|
"json" .= json
|
|
|
|
]
|
|
|
|
]
|
2020-08-27 15:34:41 +03:00
|
|
|
|
2020-09-23 15:10:40 +03:00
|
|
|
-- | Acknowledge receipt of a message. (This clears it from the ship's queue.)
|
2020-10-22 00:30:00 +03:00
|
|
|
ack :: Session -> Ship -> Int -> IO Req.IgnoreResponse
|
2020-10-10 16:06:11 +03:00
|
|
|
ack sess ship eventId =
|
2020-10-22 00:30:00 +03:00
|
|
|
Req.useURI <$> (URI.mkURI $ channelUrl ship) >>= \case
|
|
|
|
Nothing -> error "could not parse ship url"
|
|
|
|
Just uri ->
|
|
|
|
Req.runReq Req.defaultHttpConfig $
|
|
|
|
either con con uri
|
|
|
|
where
|
|
|
|
con (url, opts) =
|
|
|
|
Req.req
|
|
|
|
Req.POST
|
|
|
|
url
|
|
|
|
(Req.ReqBodyJson body)
|
|
|
|
Req.ignoreResponse
|
|
|
|
$ opts <> Req.cookieJar sess
|
|
|
|
body =
|
2020-10-20 23:56:15 +03:00
|
|
|
[ Aeson.object
|
|
|
|
[ "action" .= Text.pack "ack",
|
|
|
|
"event-id" .= eventId
|
|
|
|
]
|
|
|
|
]
|
2020-08-27 15:34:41 +03:00
|
|
|
|
2020-10-22 16:56:39 +03:00
|
|
|
instance Req.MonadHttp (ConduitM i o (Conduit.ResourceT IO)) where
|
|
|
|
handleHttpException = Conduit.liftIO . Exception.throwIO
|
|
|
|
|
2020-10-22 00:30:00 +03:00
|
|
|
-- | Subscribe to ship events on some path.
|
2020-10-21 00:27:13 +03:00
|
|
|
subscribe ::
|
2020-10-22 00:30:00 +03:00
|
|
|
Session ->
|
2020-10-21 00:27:13 +03:00
|
|
|
Ship ->
|
|
|
|
Path ->
|
2020-10-22 16:56:39 +03:00
|
|
|
-- | A handler conduit to receive the response from the server, e.g.
|
2020-10-22 00:30:00 +03:00
|
|
|
-- 'Data.Conduit.Binary.sinkFile "my-file.out"'.
|
2020-10-22 16:56:39 +03:00
|
|
|
ConduitM ByteString Conduit.Void (Conduit.ResourceT IO) a ->
|
2020-10-22 00:30:00 +03:00
|
|
|
IO a
|
|
|
|
subscribe sess ship path fn =
|
|
|
|
Req.useURI <$> (URI.mkURI $ url ship <> "/" <> path) >>= \case
|
|
|
|
Nothing -> error "could not parse ship url"
|
2020-10-22 16:56:39 +03:00
|
|
|
Just uri -> runConduitRes $ do
|
|
|
|
either con con uri $ \request manager ->
|
|
|
|
Conduit.bracketP
|
|
|
|
(HTTP.responseOpen request manager)
|
|
|
|
HTTP.responseClose
|
|
|
|
Req.responseBodySource
|
|
|
|
.| fn
|
2020-10-19 20:41:34 +03:00
|
|
|
where
|
2020-10-22 00:30:00 +03:00
|
|
|
con (url, opts) =
|
2020-10-22 16:56:39 +03:00
|
|
|
Req.req'
|
2020-10-22 00:30:00 +03:00
|
|
|
Req.POST
|
|
|
|
url
|
|
|
|
Req.NoReqBody
|
|
|
|
$ opts <> Req.cookieJar sess
|