{-# 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
<> Text
"/~/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
+ Int
1


type Session = HTTP.CookieJar


connect :: Ship -> IO Session
connect :: Ship -> IO Session
connect 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
<> Text
"/~/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
    Maybe
  (Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https))
Nothing -> String -> IO Session
forall a. HasCallStack => String -> a
error String
"could not parse ship url"
    Just 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 = Text
"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 scheme
url, 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 Session
sess Ship
ship Text
shipName Text
app Text
mark 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
    Maybe
  (Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https))
Nothing -> String -> IO BsResponse
forall a. HasCallStack => String -> a
error String
"could not parse ship url"
    Just 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 scheme
url, 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
          [ Text
"id" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Ship -> Int
nextEventId Ship
ship,
            Text
"action" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= String -> Text
Text.pack String
"poke",
            Text
"ship" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
shipName,
            Text
"app" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
app,
            Text
"mark" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
mark,
            Text
"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 Session
sess Ship
ship 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
    Maybe
  (Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https))
Nothing -> String -> IO BsResponse
forall a. HasCallStack => String -> a
error String
"could not parse ship url"
    Just 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 scheme
url, 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
          [ Text
"action" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= String -> Text
Text.pack String
"ack",
            Text
"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 Session
sess Ship
ship Text
path 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 -> 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
    Maybe
  (Either (Url 'Http, Option 'Http) (Url 'Https, Option 'Https))
Nothing -> String -> IO a
forall a. HasCallStack => String -> a
error String
"could not parse ship url"
    Just 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 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 scheme
url, 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