mirror of
https://github.com/bsima/haskell-urbit-api.git
synced 2024-08-17 22:10:55 +03:00
somewhat-working subscribe function
I still need to test for actual messages etc, but for now this is at least establishing a connection to the ship without throwing errors.
This commit is contained in:
parent
e12ff5f6c5
commit
809cf8cbb0
@ -1,7 +1,9 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Urbit.Airlock
|
||||
( Ship (..),
|
||||
@ -14,17 +16,19 @@ module Urbit.Airlock
|
||||
)
|
||||
where
|
||||
|
||||
import Conduit (ConduitM, runConduitRes, (.|))
|
||||
import qualified Conduit
|
||||
import qualified Control.Exception as Exception
|
||||
import Control.Lens ()
|
||||
import Data.Aeson ((.=))
|
||||
import qualified Data.Aeson as Aeson
|
||||
import Data.ByteString (ByteString)
|
||||
import Conduit ((.|), runConduitRes, Void, ConduitM, ResourceT)
|
||||
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 Network.HTTP.Req.Conduit as Conduit
|
||||
import qualified Network.HTTP.Req.Conduit as Req
|
||||
import qualified Text.URI as URI
|
||||
|
||||
data Ship = Ship
|
||||
@ -135,25 +139,31 @@ ack sess ship 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 ->
|
||||
Ship ->
|
||||
Path ->
|
||||
-- | A handler function to receive the response from the server, e.g.
|
||||
-- | A handler conduit to receive the response from the server, e.g.
|
||||
-- 'Data.Conduit.Binary.sinkFile "my-file.out"'.
|
||||
ConduitM ByteString Void (ResourceT IO) a ->
|
||||
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 -> Req.runReq Req.defaultHttpConfig $ do
|
||||
either con con uri $ \r ->
|
||||
runConduitRes $
|
||||
responseBodySource r .| fn
|
||||
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.reqBr
|
||||
Req.req'
|
||||
Req.POST
|
||||
url
|
||||
Req.NoReqBody
|
||||
|
5
test.hs
5
test.hs
@ -5,6 +5,7 @@
|
||||
module Main where
|
||||
|
||||
import Control.Exception (SomeException (..), try)
|
||||
import qualified Data.Conduit.Binary
|
||||
import Data.Aeson (KeyValue ((.=)))
|
||||
import qualified Data.Aeson as Aeson
|
||||
import Data.Text (Text)
|
||||
@ -48,6 +49,10 @@ main = do
|
||||
testing "ack" $
|
||||
ack sess ship 1 >> return True
|
||||
|
||||
testing "subscribe" $ do
|
||||
s <- subscribe sess ship "/mailbox/~/~zod/mc" Data.Conduit.Binary.sinkLbs
|
||||
return True
|
||||
|
||||
fakezod :: Text -> Ship
|
||||
fakezod port =
|
||||
Ship
|
||||
|
Loading…
Reference in New Issue
Block a user