mirror of
https://github.com/bsima/haskell-urbit-api.git
synced 2024-09-11 18:27:08 +03:00
209 lines
6.0 KiB
Haskell
209 lines
6.0 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
||
{-# LANGUAGE FlexibleInstances #-}
|
||
{-# LANGUAGE LambdaCase #-}
|
||
{-# LANGUAGE NamedFieldPuns #-}
|
||
{-# LANGUAGE OverloadedStrings #-}
|
||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||
|
||
-- |
|
||
-- Module: Urbit.API
|
||
-- Copyright: © 2020–present Ben Sima
|
||
-- License: MIT
|
||
--
|
||
-- Maintainer: Ben Sima <ben@bsima.me>
|
||
-- Stability: experimental
|
||
-- Portability: non-portableo
|
||
--
|
||
-- === About the Urbit API
|
||
--
|
||
-- 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.
|
||
--
|
||
-- 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.
|
||
module Urbit.API
|
||
( -- * Types
|
||
Ship (..),
|
||
Session,
|
||
|
||
-- * Functions
|
||
connect,
|
||
poke,
|
||
ack,
|
||
subscribe,
|
||
)
|
||
where
|
||
|
||
import Conduit (ConduitM, runConduitRes, (.|))
|
||
import qualified Conduit
|
||
import qualified Control.Exception as Exception
|
||
import Data.Aeson ((.=))
|
||
import qualified Data.Aeson as Aeson
|
||
import Data.ByteString (ByteString)
|
||
import Data.Text (Text)
|
||
import qualified Data.Text as Text
|
||
import qualified Network.HTTP.Client as HTTP
|
||
import Network.HTTP.Req ((=:))
|
||
import qualified Network.HTTP.Req as Req
|
||
import qualified Network.HTTP.Req.Conduit as Req
|
||
import qualified Text.URI as URI
|
||
|
||
-- | Some information about your ship needed to establish connection.
|
||
data Ship = Ship
|
||
{ -- | A random string for your channel
|
||
uid :: Text,
|
||
-- | The @\@p@ of your ship
|
||
name :: Text,
|
||
-- | Track the latest event we saw (needed for poking)
|
||
lastEventId :: Int,
|
||
-- | Network access point, with port if necessary, like
|
||
-- @https://sampel-palnet.arvo.network@, or @http://localhost:8080@
|
||
url :: Text,
|
||
-- | Login code, @+code@ in the dojo. Don't share this publically
|
||
code :: Text
|
||
}
|
||
deriving (Show)
|
||
|
||
channelUrl :: Ship -> Text
|
||
channelUrl Ship {url, uid} = url <> "/~/channel/" <> uid
|
||
|
||
nextEventId :: Ship -> Int
|
||
nextEventId Ship {lastEventId} = lastEventId + 1
|
||
|
||
-- | A wrapper type for the session cookies.
|
||
type Session = HTTP.CookieJar
|
||
|
||
-- | Connect and login to the ship.
|
||
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.bsResponse $
|
||
opts
|
||
|
||
-- | Poke a ship.
|
||
poke ::
|
||
Aeson.ToJSON a =>
|
||
-- | Session cookie from 'connect'
|
||
Session ->
|
||
-- | Your ship
|
||
Ship ->
|
||
-- | 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 ->
|
||
-- | The actual JSON message, serialized via aeson
|
||
a ->
|
||
IO Req.BsResponse
|
||
poke sess ship shipName app mark json =
|
||
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.bsResponse
|
||
$ opts <> Req.cookieJar sess
|
||
body =
|
||
[ Aeson.object
|
||
[ "id" .= nextEventId ship,
|
||
"action" .= Text.pack "poke",
|
||
"ship" .= shipName,
|
||
"app" .= app,
|
||
"mark" .= mark,
|
||
"json" .= json
|
||
]
|
||
]
|
||
|
||
-- | Acknowledge receipt of a message. (This clears it from the ship's queue.)
|
||
ack ::
|
||
-- | Session cookie from 'connect'
|
||
Session ->
|
||
-- | Your ship
|
||
Ship ->
|
||
-- | The event number
|
||
Int ->
|
||
IO Req.BsResponse
|
||
ack sess ship eventId =
|
||
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.bsResponse
|
||
$ opts <> Req.cookieJar sess
|
||
body =
|
||
[ Aeson.object
|
||
[ "action" .= Text.pack "ack",
|
||
"event-id" .= eventId
|
||
]
|
||
]
|
||
|
||
instance Req.MonadHttp (ConduitM i o (Conduit.ResourceT IO)) where
|
||
handleHttpException = Conduit.liftIO . Exception.throwIO
|
||
|
||
-- | Subscribe to ship events on some path.
|
||
subscribe ::
|
||
-- | Session cookie from 'connect'
|
||
Session ->
|
||
-- | Your ship
|
||
Ship ->
|
||
-- | The path to subscribe to.
|
||
Text ->
|
||
-- | A handler conduit to receive the response from the server, e.g.
|
||
-- @Data.Conduit.Binary.sinkFile "my-file.out"@
|
||
ConduitM ByteString Conduit.Void (Conduit.ResourceT IO) a ->
|
||
IO a
|
||
subscribe sess ship path fn =
|
||
Req.useURI <$> (URI.mkURI $ url ship <> "/" <> path) >>= \case
|
||
Nothing -> error "could not parse ship url"
|
||
Just uri -> runConduitRes $ do
|
||
either con con uri $ \request manager ->
|
||
Conduit.bracketP
|
||
(HTTP.responseOpen request manager)
|
||
HTTP.responseClose
|
||
Req.responseBodySource
|
||
.| fn
|
||
where
|
||
con (url, opts) =
|
||
Req.req'
|
||
Req.POST
|
||
url
|
||
Req.NoReqBody
|
||
$ opts <> Req.cookieJar sess
|