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-10-23 17:07:02 +03:00
|
|
|
|
-- |
|
2020-11-29 17:57:46 +03:00
|
|
|
|
-- Module: Urbit.API
|
2020-10-23 17:07:02 +03:00
|
|
|
|
-- Copyright: © 2020–present Ben Sima
|
|
|
|
|
-- License: MIT
|
|
|
|
|
--
|
|
|
|
|
-- Maintainer: Ben Sima <ben@bsima.me>
|
|
|
|
|
-- Stability: experimental
|
|
|
|
|
-- Portability: non-portableo
|
|
|
|
|
--
|
|
|
|
|
-- === About the Urbit API
|
|
|
|
|
--
|
2020-11-29 17:57:46 +03:00
|
|
|
|
-- The Urbit API is a command-query API that lets you hook into apps running on
|
|
|
|
|
-- your Urbit. You can submit commands and subscribe to responses.
|
2020-10-23 17:07:02 +03:00
|
|
|
|
--
|
|
|
|
|
-- The Urbit vane @eyre@ is responsible for defining the API interface. The HTTP
|
|
|
|
|
-- path to the API is @\/~\/channel\/...@, where we send messages to the global
|
|
|
|
|
-- log (called @poke@s) which are then dispatched to the appropriate apps. To
|
|
|
|
|
-- receive responses, we stream messages from a path associated with the app,
|
|
|
|
|
-- such as @\/mailbox\/~\/~zod\/mc@. Internally, I believe Urbit calls these
|
|
|
|
|
-- @wire@s.
|
|
|
|
|
--
|
|
|
|
|
-- === About this library
|
|
|
|
|
--
|
|
|
|
|
-- This library helps you talk to your Urbit from Haskell, via HTTP. It handles
|
|
|
|
|
-- most of the path, session, and HTTP request stuff automatically. You'll need
|
|
|
|
|
-- to know what app and mark (data type) to send to, which path/wire listen to,
|
|
|
|
|
-- and the shape of the message. The latter can be found in the Hoon source
|
|
|
|
|
-- code, called the @vase@ on the poke arm.
|
|
|
|
|
--
|
|
|
|
|
-- This library is built on req, conduit, and aeson, all of which are very
|
|
|
|
|
-- stable and usable libraries for working with HTTP requests and web data.
|
|
|
|
|
-- Released under the MIT License, same as Urbit.
|
2020-11-29 17:57:46 +03:00
|
|
|
|
module Urbit.API
|
2020-10-23 17:07:02 +03:00
|
|
|
|
( -- * Types
|
|
|
|
|
Ship (..),
|
|
|
|
|
Session,
|
|
|
|
|
|
|
|
|
|
-- * Functions
|
2020-09-23 15:10:40 +03:00
|
|
|
|
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 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
|
|
|
|
|
2020-10-23 01:27:13 +03:00
|
|
|
|
-- | Some information about your ship needed to establish connection.
|
2020-08-27 15:34:41 +03:00
|
|
|
|
data Ship = Ship
|
2020-10-23 17:07:02 +03:00
|
|
|
|
{ -- | A random string for your channel
|
2020-10-10 16:06:11 +03:00
|
|
|
|
uid :: Text,
|
2020-10-23 17:07:02 +03:00
|
|
|
|
-- | The @\@p@ of your ship
|
|
|
|
|
name :: Text,
|
|
|
|
|
-- | Track the latest event we saw (needed for poking)
|
2020-08-27 15:34:41 +03:00
|
|
|
|
lastEventId :: Int,
|
2020-10-23 17:07:02 +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-10-23 17:07:02 +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
|
|
|
|
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-23 17:07:02 +03:00
|
|
|
|
-- | A wrapper type for the session cookies.
|
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) =
|
2020-10-23 17:07:02 +03:00
|
|
|
|
Req.req Req.POST url (Req.ReqBodyUrlEnc body) Req.bsResponse $
|
2020-10-22 00:30:00 +03:00
|
|
|
|
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-23 17:07:02 +03:00
|
|
|
|
-- | Session cookie from 'connect'
|
2020-10-22 00:30:00 +03:00
|
|
|
|
Session ->
|
2020-10-23 17:07:02 +03:00
|
|
|
|
-- | Your ship
|
2020-09-23 15:10:40 +03:00
|
|
|
|
Ship ->
|
2020-10-23 17:07:02 +03:00
|
|
|
|
-- | Name of the ship to poke
|
|
|
|
|
Text ->
|
|
|
|
|
-- | Name of the gall application you want to poke
|
|
|
|
|
Text ->
|
|
|
|
|
-- | The mark of the message you are sending
|
|
|
|
|
Text ->
|
2020-10-23 20:21:19 +03:00
|
|
|
|
-- | The actual JSON message, serialized via aeson
|
2020-10-04 16:27:49 +03:00
|
|
|
|
a ->
|
2020-10-23 17:07:02 +03:00
|
|
|
|
IO Req.BsResponse
|
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)
|
2020-10-23 17:07:02 +03:00
|
|
|
|
Req.bsResponse
|
2020-10-22 00:30:00 +03:00
|
|
|
|
$ 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-23 17:07:02 +03:00
|
|
|
|
ack ::
|
|
|
|
|
-- | Session cookie from 'connect'
|
|
|
|
|
Session ->
|
|
|
|
|
-- | Your ship
|
|
|
|
|
Ship ->
|
|
|
|
|
-- | The event number
|
|
|
|
|
Int ->
|
|
|
|
|
IO Req.BsResponse
|
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)
|
2020-10-23 17:07:02 +03:00
|
|
|
|
Req.bsResponse
|
2020-10-22 00:30:00 +03:00
|
|
|
|
$ 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-23 17:07:02 +03:00
|
|
|
|
-- | Session cookie from 'connect'
|
2020-10-22 00:30:00 +03:00
|
|
|
|
Session ->
|
2020-10-23 17:07:02 +03:00
|
|
|
|
-- | Your ship
|
2020-10-21 00:27:13 +03:00
|
|
|
|
Ship ->
|
2020-10-23 17:07:02 +03:00
|
|
|
|
-- | The path to subscribe to.
|
|
|
|
|
Text ->
|
2020-10-22 16:56:39 +03:00
|
|
|
|
-- | A handler conduit to receive the response from the server, e.g.
|
2020-10-23 17:07:02 +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
|