Hecate/Hash2Pub
2
0
Fork 0
forked from schmittlauch/Hash2Pub
Code Issues Pull requests Releases Wiki Activity

implemented first Servant client query

Browse source
This commit is contained in:
Trolli Schmittlauch 2020-08-03 22:50:48 +02:00
parent 20e51ecca4
commit 7036867ae0
1 changed files with 19 additions and 4 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

23
src/Hash2Pub/PostService.hs
View file

@ -271,6 +271,18 @@ clientAPI = Proxy
relayInboxClient :<|> subscriptionDeliveryClient :<|> postFetchClient :<|> postMultiFetchClient :<|> postInboxClient :<|> tagDeliveryClient :<|> tagSubscribeClient :<|> tagUnsubscribeClient = client clientAPI relayInboxClient :<|> subscriptionDeliveryClient :<|> postFetchClient :<|> postMultiFetchClient :<|> postInboxClient :<|> tagDeliveryClient :<|> tagSubscribeClient :<|> tagUnsubscribeClient = client clientAPI
-- currently this is unused code
getClients :: String -> Int -> HTTP.Manager -> Client IO PostServiceAPI
getClients hostname' port' httpMan = hoistClient clientAPI
(fmap (either (error . show) id)
. flip runClientM clientEnv
)
(client clientAPI)
where
clientEnv = mkClientEnv httpMan (BaseUrl Http hostname' port' "")
-- ======= data structure manipulations ========= -- ======= data structure manipulations =========
-- | Write all pending posts of a subscriber-tag-combination to its queue. -- | Write all pending posts of a subscriber-tag-combination to its queue.
@ -372,11 +384,14 @@ processIncomingPosts :: DHT d => PostService d -> IO ()
processIncomingPosts serv = forever $ do processIncomingPosts serv = forever $ do
-- blocks until available -- blocks until available
-- TODO: process multiple in parallel -- TODO: process multiple in parallel
(t, pID, pC) <- atomically . readTQueue $ relayInQueue serv (tag, pID, pContent) <- atomically . readTQueue $ relayInQueue serv
lookupRes <- lookupKey (baseDHT serv) (Txt.unpack t) lookupRes <- lookupKey (baseDHT serv) (Txt.unpack tag)
case lookupRes of case lookupRes of
-- no vserver active => wait and retry -- no vserver active => wait and retry
Nothing -> threadDelay $ 10 * 10^6 Nothing -> threadDelay $ 10 * 10^6
Just (responsibleHost, responsiblePort) -> do Just (responsibleHost, responsiblePort) -> do
-- TODO: do actual HTTP requests httpMan <- HTTP.newManager HTTP.defaultManagerSettings
pure () resp <- runClientM (relayInboxClient tag (pID <> "," <> pContent)) (mkClientEnv httpMan (BaseUrl Http responsibleHost (fromIntegral responsiblePort) ""))
case resp of
Left err -> putStrLn $ "Error: " <> show err
Right yay -> putStrLn $ "Yay! " <> show yay