{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Urbit.API
(
Ship (..),
Session,
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
data Ship = Ship
{
Ship -> Text
uid :: Text,
Ship -> Text
name :: Text,
Ship -> Int
lastEventId :: Int,
Ship -> Text
url :: Text,
Ship -> Text
code :: Text
}
deriving (Int -> Ship -> ShowS
[Ship] -> ShowS
Ship -> String
(Int -> Ship -> ShowS)
-> (Ship -> String) -> ([Ship] -> ShowS) -> Show Ship
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Ship] -> ShowS
$cshowList :: [Ship] -> ShowS
show :: Ship -> String
$cshow :: Ship -> String
showsPrec :: Int -> Ship -> ShowS
$cshowsPrec :: Int -> Ship -> ShowS
Show)
channelUrl :: Ship -> Text
channelUrl :: Ship -> Text
channelUrl Ship {Text
url :: Text
url :: Ship -> Text
url, Text
uid :: Text
uid :: Ship -> Text
uid} = Text
url Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "/~/channel/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
uid
nextEventId :: Ship -> Int
nextEventId :: Ship -> Int
nextEventId Ship {Int
lastEventId :: Int
lastEventId :: Ship -> Int
lastEventId} = Int
lastEventId Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
type Session = HTTP.CookieJar
connect :: Ship -> IO Session
connect :: Ship -> IO Session
connect ship :: Ship
ship =
URI
-> Maybe
(Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https))
forall (scheme0 :: Scheme) (scheme1 :: Scheme).
URI
-> Maybe
(Either (Url 'Http, Option scheme0) (Url 'Https, Option scheme1))
Req.useURI (URI
-> Maybe
(Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)))
-> IO URI
-> IO
(Maybe
(Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> IO URI
forall (m :: * -> *). MonadThrow m => Text -> m URI
URI.mkURI (Text -> IO URI) -> Text -> IO URI
forall a b. (a -> b) -> a -> b
$ Ship -> Text
url Ship
ship Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "/~/login") IO
(Maybe
(Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)))
-> (Maybe
(Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https))
-> IO Session)
-> IO Session
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Nothing -> String -> IO Session
forall a. HasCallStack => String -> a
error "could not parse ship url"
Just uri :: Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)
uri ->
HttpConfig -> Req Session -> IO Session
forall (m :: * -> *) a. MonadIO m => HttpConfig -> Req a -> m a
Req.runReq HttpConfig
Req.defaultHttpConfig (Req Session -> IO Session) -> Req Session -> IO Session
forall a b. (a -> b) -> a -> b
$
BsResponse -> Session
forall response. HttpResponse response => response -> Session
Req.responseCookieJar (BsResponse -> Session) -> Req BsResponse -> Req Session
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Url 'Http, Option 'Http) -> Req BsResponse)
-> ((Url 'Https, Option 'Https) -> Req BsResponse)
-> Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)
-> Req BsResponse
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Url 'Http, Option 'Http) -> Req BsResponse
forall (m :: * -> *) (scheme :: Scheme).
MonadHttp m =>
(Url scheme, Option scheme) -> m BsResponse
con (Url 'Https, Option 'Https) -> Req BsResponse
forall (m :: * -> *) (scheme :: Scheme).
MonadHttp m =>
(Url scheme, Option scheme) -> m BsResponse
con Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)
uri
where
body :: FormUrlEncodedParam
body = "password" Text -> Text -> FormUrlEncodedParam
forall param a.
(QueryParam param, ToHttpApiData a) =>
Text -> a -> param
=: (Ship -> Text
code Ship
ship)
con :: (Url scheme, Option scheme) -> m BsResponse
con (url :: Url scheme
url, opts :: Option scheme
opts) =
POST
-> Url scheme
-> ReqBodyUrlEnc
-> Proxy BsResponse
-> Option scheme
-> m BsResponse
forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
HttpResponse response,
HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
Req.req POST
Req.POST Url scheme
url (FormUrlEncodedParam -> ReqBodyUrlEnc
Req.ReqBodyUrlEnc FormUrlEncodedParam
body) Proxy BsResponse
Req.bsResponse (Option scheme -> m BsResponse) -> Option scheme -> m BsResponse
forall a b. (a -> b) -> a -> b
$
Option scheme
opts
poke ::
Aeson.ToJSON a =>
Session ->
Ship ->
Text ->
Text ->
Text ->
a ->
IO Req.BsResponse
poke :: Session -> Ship -> Text -> Text -> Text -> a -> IO BsResponse
poke sess :: Session
sess ship :: Ship
ship shipName :: Text
shipName app :: Text
app mark :: Text
mark json :: a
json =
URI
-> Maybe
(Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https))
forall (scheme0 :: Scheme) (scheme1 :: Scheme).
URI
-> Maybe
(Either (Url 'Http, Option scheme0) (Url 'Https, Option scheme1))
Req.useURI (URI
-> Maybe
(Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)))
-> IO URI
-> IO
(Maybe
(Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> IO URI
forall (m :: * -> *). MonadThrow m => Text -> m URI
URI.mkURI (Text -> IO URI) -> Text -> IO URI
forall a b. (a -> b) -> a -> b
$ Ship -> Text
channelUrl Ship
ship) IO
(Maybe
(Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)))
-> (Maybe
(Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https))
-> IO BsResponse)
-> IO BsResponse
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Nothing -> String -> IO BsResponse
forall a. HasCallStack => String -> a
error "could not parse ship url"
Just uri :: Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)
uri ->
HttpConfig -> Req BsResponse -> IO BsResponse
forall (m :: * -> *) a. MonadIO m => HttpConfig -> Req a -> m a
Req.runReq HttpConfig
Req.defaultHttpConfig (Req BsResponse -> IO BsResponse)
-> Req BsResponse -> IO BsResponse
forall a b. (a -> b) -> a -> b
$
((Url 'Http, Option 'Http) -> Req BsResponse)
-> ((Url 'Https, Option 'Https) -> Req BsResponse)
-> Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)
-> Req BsResponse
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Url 'Http, Option 'Http) -> Req BsResponse
forall (m :: * -> *) (scheme :: Scheme).
MonadHttp m =>
(Url scheme, Option scheme) -> m BsResponse
con (Url 'Https, Option 'Https) -> Req BsResponse
forall (m :: * -> *) (scheme :: Scheme).
MonadHttp m =>
(Url scheme, Option scheme) -> m BsResponse
con Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)
uri
where
con :: (Url scheme, Option scheme) -> m BsResponse
con (url :: Url scheme
url, opts :: Option scheme
opts) =
POST
-> Url scheme
-> ReqBodyJson [Value]
-> Proxy BsResponse
-> Option scheme
-> m BsResponse
forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
HttpResponse response,
HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
Req.req
POST
Req.POST
Url scheme
url
([Value] -> ReqBodyJson [Value]
forall a. a -> ReqBodyJson a
Req.ReqBodyJson [Value]
body)
Proxy BsResponse
Req.bsResponse
(Option scheme -> m BsResponse) -> Option scheme -> m BsResponse
forall a b. (a -> b) -> a -> b
$ Option scheme
opts Option scheme -> Option scheme -> Option scheme
forall a. Semigroup a => a -> a -> a
<> Session -> Option scheme
forall (scheme :: Scheme). Session -> Option scheme
Req.cookieJar Session
sess
body :: [Value]
body =
[ [Pair] -> Value
Aeson.object
[ "id" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Ship -> Int
nextEventId Ship
ship,
"action" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= String -> Text
Text.pack "poke",
"ship" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
shipName,
"app" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
app,
"mark" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
mark,
"json" Text -> a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= a
json
]
]
ack ::
Session ->
Ship ->
Int ->
IO Req.BsResponse
ack :: Session -> Ship -> Int -> IO BsResponse
ack sess :: Session
sess ship :: Ship
ship eventId :: Int
eventId =
URI
-> Maybe
(Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https))
forall (scheme0 :: Scheme) (scheme1 :: Scheme).
URI
-> Maybe
(Either (Url 'Http, Option scheme0) (Url 'Https, Option scheme1))
Req.useURI (URI
-> Maybe
(Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)))
-> IO URI
-> IO
(Maybe
(Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> IO URI
forall (m :: * -> *). MonadThrow m => Text -> m URI
URI.mkURI (Text -> IO URI) -> Text -> IO URI
forall a b. (a -> b) -> a -> b
$ Ship -> Text
channelUrl Ship
ship) IO
(Maybe
(Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)))
-> (Maybe
(Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https))
-> IO BsResponse)
-> IO BsResponse
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Nothing -> String -> IO BsResponse
forall a. HasCallStack => String -> a
error "could not parse ship url"
Just uri :: Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)
uri ->
HttpConfig -> Req BsResponse -> IO BsResponse
forall (m :: * -> *) a. MonadIO m => HttpConfig -> Req a -> m a
Req.runReq HttpConfig
Req.defaultHttpConfig (Req BsResponse -> IO BsResponse)
-> Req BsResponse -> IO BsResponse
forall a b. (a -> b) -> a -> b
$
((Url 'Http, Option 'Http) -> Req BsResponse)
-> ((Url 'Https, Option 'Https) -> Req BsResponse)
-> Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)
-> Req BsResponse
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Url 'Http, Option 'Http) -> Req BsResponse
forall (m :: * -> *) (scheme :: Scheme).
MonadHttp m =>
(Url scheme, Option scheme) -> m BsResponse
con (Url 'Https, Option 'Https) -> Req BsResponse
forall (m :: * -> *) (scheme :: Scheme).
MonadHttp m =>
(Url scheme, Option scheme) -> m BsResponse
con Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)
uri
where
con :: (Url scheme, Option scheme) -> m BsResponse
con (url :: Url scheme
url, opts :: Option scheme
opts) =
POST
-> Url scheme
-> ReqBodyJson [Value]
-> Proxy BsResponse
-> Option scheme
-> m BsResponse
forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
HttpResponse response,
HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
Req.req
POST
Req.POST
Url scheme
url
([Value] -> ReqBodyJson [Value]
forall a. a -> ReqBodyJson a
Req.ReqBodyJson [Value]
body)
Proxy BsResponse
Req.bsResponse
(Option scheme -> m BsResponse) -> Option scheme -> m BsResponse
forall a b. (a -> b) -> a -> b
$ Option scheme
opts Option scheme -> Option scheme -> Option scheme
forall a. Semigroup a => a -> a -> a
<> Session -> Option scheme
forall (scheme :: Scheme). Session -> Option scheme
Req.cookieJar Session
sess
body :: [Value]
body =
[ [Pair] -> Value
Aeson.object
[ "action" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= String -> Text
Text.pack "ack",
"event-id" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Int
eventId
]
]
instance Req.MonadHttp (ConduitM i o (Conduit.ResourceT IO)) where
handleHttpException :: HttpException -> ConduitM i o (ResourceT IO) a
handleHttpException = IO a -> ConduitM i o (ResourceT IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
Conduit.liftIO (IO a -> ConduitM i o (ResourceT IO) a)
-> (HttpException -> IO a)
-> HttpException
-> ConduitM i o (ResourceT IO) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HttpException -> IO a
forall e a. Exception e => e -> IO a
Exception.throwIO
subscribe ::
Session ->
Ship ->
Text ->
ConduitM ByteString Conduit.Void (Conduit.ResourceT IO) a ->
IO a
subscribe :: Session
-> Ship
-> Text
-> ConduitM ByteString Void (ResourceT IO) a
-> IO a
subscribe sess :: Session
sess ship :: Ship
ship path :: Text
path fn :: ConduitM ByteString Void (ResourceT IO) a
fn =
URI
-> Maybe
(Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https))
forall (scheme0 :: Scheme) (scheme1 :: Scheme).
URI
-> Maybe
(Either (Url 'Http, Option scheme0) (Url 'Https, Option scheme1))
Req.useURI (URI
-> Maybe
(Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)))
-> IO URI
-> IO
(Maybe
(Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> IO URI
forall (m :: * -> *). MonadThrow m => Text -> m URI
URI.mkURI (Text -> IO URI) -> Text -> IO URI
forall a b. (a -> b) -> a -> b
$ Ship -> Text
url Ship
ship Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path) IO
(Maybe
(Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)))
-> (Maybe
(Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https))
-> IO a)
-> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Nothing -> String -> IO a
forall a. HasCallStack => String -> a
error "could not parse ship url"
Just uri :: Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)
uri -> ConduitT () Void (ResourceT IO) a -> IO a
forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes (ConduitT () Void (ResourceT IO) a -> IO a)
-> ConduitT () Void (ResourceT IO) a -> IO a
forall a b. (a -> b) -> a -> b
$ do
((Url 'Http, Option 'Http)
-> (Request -> Manager -> ConduitT () Void (ResourceT IO) a)
-> ConduitT () Void (ResourceT IO) a)
-> ((Url 'Https, Option 'Https)
-> (Request -> Manager -> ConduitT () Void (ResourceT IO) a)
-> ConduitT () Void (ResourceT IO) a)
-> Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)
-> (Request -> Manager -> ConduitT () Void (ResourceT IO) a)
-> ConduitT () Void (ResourceT IO) a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Url 'Http, Option 'Http)
-> (Request -> Manager -> ConduitT () Void (ResourceT IO) a)
-> ConduitT () Void (ResourceT IO) a
forall (m :: * -> *) (scheme :: Scheme) a.
MonadHttp m =>
(Url scheme, Option scheme) -> (Request -> Manager -> m a) -> m a
con (Url 'Https, Option 'Https)
-> (Request -> Manager -> ConduitT () Void (ResourceT IO) a)
-> ConduitT () Void (ResourceT IO) a
forall (m :: * -> *) (scheme :: Scheme) a.
MonadHttp m =>
(Url scheme, Option scheme) -> (Request -> Manager -> m a) -> m a
con Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https)
uri ((Request -> Manager -> ConduitT () Void (ResourceT IO) a)
-> ConduitT () Void (ResourceT IO) a)
-> (Request -> Manager -> ConduitT () Void (ResourceT IO) a)
-> ConduitT () Void (ResourceT IO) a
forall a b. (a -> b) -> a -> b
$ \request :: Request
request manager :: Manager
manager ->
IO (Response BodyReader)
-> (Response BodyReader -> IO ())
-> (Response BodyReader
-> ConduitT () ByteString (ResourceT IO) ())
-> ConduitT () ByteString (ResourceT IO) ()
forall (m :: * -> *) a i o r.
MonadResource m =>
IO a -> (a -> IO ()) -> (a -> ConduitT i o m r) -> ConduitT i o m r
Conduit.bracketP
(Request -> Manager -> IO (Response BodyReader)
HTTP.responseOpen Request
request Manager
manager)
Response BodyReader -> IO ()
forall a. Response a -> IO ()
HTTP.responseClose
Response BodyReader -> ConduitT () ByteString (ResourceT IO) ()
forall (m :: * -> *).
MonadIO m =>
Response BodyReader -> Producer m ByteString
Req.responseBodySource
ConduitT () ByteString (ResourceT IO) ()
-> ConduitM ByteString Void (ResourceT IO) a
-> ConduitT () Void (ResourceT IO) a
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM ByteString Void (ResourceT IO) a
fn
where
con :: (Url scheme, Option scheme) -> (Request -> Manager -> m a) -> m a
con (url :: Url scheme
url, opts :: Option scheme
opts) =
POST
-> Url scheme
-> NoReqBody
-> Option scheme
-> (Request -> Manager -> m a)
-> m a
forall (m :: * -> *) method body (scheme :: Scheme) a.
(MonadHttp m, HttpMethod method, HttpBody body,
HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Option scheme
-> (Request -> Manager -> m a)
-> m a
Req.req'
POST
Req.POST
Url scheme
url
NoReqBody
Req.NoReqBody
(Option scheme -> (Request -> Manager -> m a) -> m a)
-> Option scheme -> (Request -> Manager -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ Option scheme
opts Option scheme -> Option scheme -> Option scheme
forall a. Semigroup a => a -> a -> a
<> Session -> Option scheme
forall (scheme :: Scheme). Session -> Option scheme
Req.cookieJar Session
sess