From d3e5eac5c5b62c84a8e18989d39ad873a51cf95a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?H=C3=A9cate?= Date: Sat, 5 Sep 2020 12:41:18 +0200 Subject: [PATCH 1/2] Unsused imports and syntax error --- src/Hash2Pub/PostService.hs | 7 +++---- src/Hash2Pub/RingMap.hs | 4 ++-- 2 files changed, 5 insertions(+), 6 deletions(-) diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs index 81cf552..7bf0c3c 100644 --- a/src/Hash2Pub/PostService.hs +++ b/src/Hash2Pub/PostService.hs @@ -12,15 +12,14 @@ import Control.Concurrent import Control.Concurrent.Async import Control.Concurrent.STM import Control.Exception (Exception (..), try) -import Control.Monad (foldM, forM, forM_, forever, void, - when) +import Control.Monad (foldM, forM_, forever, void, when) import Control.Monad.IO.Class (liftIO) import Data.Bifunctor import qualified Data.ByteString.Lazy.UTF8 as BSUL import qualified Data.ByteString.UTF8 as BSU import qualified Data.HashMap.Strict as HMap import qualified Data.HashSet as HSet -import Data.Maybe (fromMaybe, isJust) +import Data.Maybe (isJust) import Data.String (fromString) import qualified Data.Text.Lazy as Txt import Data.Text.Normalize (NormalizationMode (NFC), normalize) @@ -601,7 +600,7 @@ fetchTagPosts serv = forever $ do -- TODO: batching, retry -- TODO: process multiple in parallel pIdUri <- atomically . readTQueue $ postFetchQueue serv - fetchReq <- HTTP.parseRequest . Txt.unpack $pIdUri + fetchReq <- HTTP.parseRequest . Txt.unpack $ pIdUri resp <- try $ HTTP.httpLbs fetchReq (httpMan serv) :: IO (Either HTTP.HttpException (HTTP.Response BSUL.ByteString)) case resp of Right response -> diff --git a/src/Hash2Pub/RingMap.hs b/src/Hash2Pub/RingMap.hs index e99f8b2..ae1ec15 100644 --- a/src/Hash2Pub/RingMap.hs +++ b/src/Hash2Pub/RingMap.hs @@ -23,7 +23,7 @@ instance (Bounded k, Ord k, Eq a) => Eq (RingMap k a) where a == b = getRingMap a == getRingMap b instance (Bounded k, Ord k, Show k, Show a) => Show (RingMap k a) where - show rmap = shows "RingMap " (show $ getRingMap rmap) + show rmap = shows ("RingMap " :: String) (show $ getRingMap rmap) -- | entry of a 'RingMap' that holds a value and can also -- wrap around the lookup direction at the edges of the name space. @@ -207,7 +207,7 @@ takeEntriesUntil_ :: (Integral i, Bounded k, Ord k) -> Maybe i -- possible number limit -> [a] -> [a] -takeEntriesUntil_ rmap' getterFunc' havingReached previousEntry (Just remaining) takeAcc +takeEntriesUntil_ _rmap' _getterFunc' _havingReached _previousEntry (Just remaining) takeAcc -- length limit reached | remaining <= 0 = takeAcc takeEntriesUntil_ rmap' getterFunc' havingReached previousEntry numLimit takeAcc = -- 2.44.1 From 7d833e064ba414b47f92a89cbd16227e50485c45 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?H=C3=A9cate?= Date: Sat, 5 Sep 2020 13:10:15 +0200 Subject: [PATCH 2/2] Improve readability --- src/Hash2Pub/PostService.hs | 70 +++++++++++++-------------------- src/Hash2Pub/PostService/API.hs | 37 +++++++++++++++++ src/Hash2Pub/ProtocolTypes.hs | 2 - 3 files changed, 64 insertions(+), 45 deletions(-) create mode 100644 src/Hash2Pub/PostService/API.hs diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs index 7bf0c3c..89c14d2 100644 --- a/src/Hash2Pub/PostService.hs +++ b/src/Hash2Pub/PostService.hs @@ -21,6 +21,7 @@ import qualified Data.HashMap.Strict as HMap import qualified Data.HashSet as HSet import Data.Maybe (isJust) import Data.String (fromString) +import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as Txt import Data.Text.Normalize (NormalizationMode (NFC), normalize) import Data.Time.Clock.POSIX @@ -35,6 +36,7 @@ import Servant import Servant.Client import Hash2Pub.FediChordTypes +import Hash2Pub.PostService.API import Hash2Pub.RingMap @@ -47,7 +49,7 @@ data PostService d = PostService -- ^ for each tag store the subscribers + their queue , ownSubscriptions :: TVar (HMap.HashMap NodeID POSIXTime) -- ^ tags subscribed by the own node have an assigned lease time - , ownPosts :: TVar (HSet.HashSet Txt.Text) + , ownPosts :: TVar (HSet.HashSet Text) -- ^ just store the existence of posts for saving memory, , relayInQueue :: TQueue (Hashtag, PostID, PostContent) -- ^ Queue for processing incoming posts of own instance asynchronously @@ -57,9 +59,9 @@ data PostService d = PostService } deriving (Typeable) -type Hashtag = Txt.Text -type PostID = Txt.Text -type PostContent = Txt.Text +type Hashtag = Text +type PostID = Text +type PostContent = Text -- | For each handled tag, store its subscribers and provide a -- broadcast 'TChan' for enqueuing posts type RelayTags = RingMap NodeID (TagSubscribersSTM, TChan PostID, Hashtag) @@ -130,38 +132,13 @@ postServiceApplication :: DHT d => PostService d -> Application postServiceApplication serv = serve exposedPostServiceAPI $ postServer serv --- | needed for guiding type inference -exposedPostServiceAPI :: Proxy PostServiceAPI -exposedPostServiceAPI = Proxy - -- ========= constants =========== -placeholderPost :: Txt.Text +placeholderPost :: Text placeholderPost = Txt.take 5120 . Txt.repeat $ 'O' -- size 5KiB -- ========= HTTP API and handlers ============= -type PostServiceAPI = "relay" :> "inbox" :> Capture "hashtag" Txt.Text :> ReqBody '[PlainText] Txt.Text :> PutCreated '[PlainText] NoContent - -- delivery endpoint at responsible relay for delivering posts of $tag for distribution - :<|> "relay" :> "subscribers" :> Capture "senderID" Integer :> ReqBody '[PlainText] Txt.Text :> PostNoContent '[PlainText] Txt.Text - -- endpoint for delivering the subscriptions and outstanding queue - :<|> "post" :> Capture "postid" Txt.Text :> Get '[PlainText] Txt.Text - -- fetch endpoint for posts, full post ID is http://$domain/post/$postid - :<|> "posts" :> ReqBody '[PlainText] Txt.Text :> Post '[PlainText] Txt.Text - -- endpoint for fetching multiple posts at once - :<|> "posts" :> "inbox" :> ReqBody '[PlainText] Txt.Text :> PutCreated '[PlainText] NoContent - -- delivery endpoint of newly published posts of the relay's instance - :<|> "tags" :> Capture "hashtag" Txt.Text :> ReqBody '[PlainText] Txt.Text :> PostCreated '[PlainText] Txt.Text - -- delivery endpoint for posts of $tag at subscribing instance - :<|> "tags" :> Capture "hashtag" Txt.Text :> "subscribe" :> Header "Origin" Txt.Text :> Get '[PlainText] Integer - -- endpoint for subscribing the instance specified in - -- the Origin header to $hashtag. - -- Returns subscription lease time in seconds. - :<|> "tags" :> Capture "hashtag" Txt.Text :> "unsubscribe" :> Header "Origin" Txt.Text :> Get '[PlainText] Txt.Text - -- endpoint for unsubscribing the instance specified in - -- the Origin header to $hashtag - - postServer :: DHT d => PostService d -> Server PostServiceAPI postServer service = relayInbox service :<|> subscriptionDelivery service @@ -173,7 +150,7 @@ postServer service = relayInbox service :<|> tagUnsubscribe service -relayInbox :: DHT d => PostService d -> Hashtag -> Txt.Text -> Handler NoContent +relayInbox :: DHT d => PostService d -> Hashtag -> Text -> Handler NoContent relayInbox serv tag posts = do let -- skip checking whether the post actually contains the tag, just drop full post @@ -201,7 +178,7 @@ newtype UnhandledTagException = UnhandledTagException String instance Exception UnhandledTagException -subscriptionDelivery :: DHT d => PostService d -> Integer -> Txt.Text -> Handler Txt.Text +subscriptionDelivery :: DHT d => PostService d -> Integer -> Text -> Handler Text subscriptionDelivery serv senderID subList = do let tagSubs = Txt.lines subList @@ -235,7 +212,7 @@ subscriptionDelivery serv senderID subList = do Right _ -> pure "" -- TODO: check and only accept tags in own (future?) responsibility where - processTag :: TVar RelayTags -> Txt.Text -> STM () + processTag :: TVar RelayTags -> Text -> STM () processTag subscriberSTM tagData = do let tag:subText:lease:posts:_ = Txt.splitOn "," tagData @@ -246,7 +223,7 @@ subscriptionDelivery serv senderID subList = do enqueueSubscription subscriberSTM (normaliseTag tag) sub postList leaseTime -postFetch :: PostService d -> Txt.Text -> Handler Txt.Text +postFetch :: PostService d -> Text -> Handler Text postFetch serv postID = do postSet <- liftIO . readTVarIO . ownPosts $ serv if HSet.member postID postSet @@ -255,7 +232,7 @@ postFetch serv postID = do else throwError $ err404 { errBody = "No post found with this ID" } -postMultiFetch :: PostService d -> Txt.Text -> Handler Txt.Text +postMultiFetch :: PostService d -> Text -> Handler Text postMultiFetch serv postIDs = do let idList = Txt.lines postIDs postSet <- liftIO . readTVarIO . ownPosts $ serv @@ -267,7 +244,7 @@ postMultiFetch serv postIDs = do ) "" idList -postInbox :: PostService d -> Txt.Text -> Handler NoContent +postInbox :: PostService d -> Text -> Handler NoContent postInbox serv post = do -- extract contained hashtags let @@ -277,13 +254,13 @@ postInbox serv post = do -- add ID to own posts liftIO . atomically $ modifyTVar' (ownPosts serv) (HSet.insert postId) -- enqueue a relay job for each tag - liftIO $ forM_ (containedTags :: [Txt.Text]) (\tag -> + liftIO $ forM_ (containedTags :: [Text]) (\tag -> atomically $ writeTQueue (relayInQueue serv) (tag, postId, post) ) pure NoContent -tagDelivery :: PostService d -> Txt.Text -> Txt.Text -> Handler Txt.Text +tagDelivery :: PostService d -> Text -> Text -> Handler Text tagDelivery serv hashtag posts = do let postIDs = Txt.lines posts subscriptions <- liftIO . readTVarIO . ownSubscriptions $ serv @@ -294,7 +271,7 @@ tagDelivery serv hashtag posts = do pure () pure $ "Received a postID for tag " <> hashtag -tagSubscribe :: DHT d => PostService d -> Txt.Text -> Maybe Txt.Text -> Handler Integer +tagSubscribe :: DHT d => PostService d -> Text -> Maybe Text -> Handler Integer tagSubscribe serv hashtag origin = do responsible <- liftIO $ isResponsibleFor (baseDHT serv) (hashtagToId hashtag) if not responsible @@ -313,7 +290,7 @@ tagSubscribe serv hashtag origin = do pure $ round leaseTime -tagUnsubscribe :: DHT d => PostService d -> Txt.Text -> Maybe Txt.Text -> Handler Txt.Text +tagUnsubscribe :: DHT d => PostService d -> Text -> Maybe Text -> Handler Text tagUnsubscribe serv hashtag origin = do responsible <- liftIO $ isResponsibleFor (baseDHT serv) (hashtagToId hashtag) if not responsible @@ -333,8 +310,15 @@ tagUnsubscribe serv hashtag origin = do clientAPI :: Proxy PostServiceAPI clientAPI = Proxy - -relayInboxClient :<|> subscriptionDeliveryClient :<|> postFetchClient :<|> postMultiFetchClient :<|> postInboxClient :<|> tagDeliveryClient :<|> tagSubscribeClient :<|> tagUnsubscribeClient = client clientAPI +relayInboxClient :: Text -> Text -> ClientM NoContent +relayInboxClient :<|> subscriptionDeliveryClient + :<|> postFetchClient + :<|> postMultiFetchClient + :<|> postInboxClient + :<|> tagDeliveryClient + :<|> tagSubscribeClient + :<|> tagUnsubscribeClient + = client clientAPI -- | Deliver the subscriber list of all hashtags in the interval [fromTag, toTag] @@ -542,7 +526,7 @@ lookupTagSubscriptions tag = rMapLookup (hashtagToId tag) -- normalise the unicode representation of a string to NFC -normaliseTag :: Txt.Text -> Txt.Text +normaliseTag :: Text -> Text normaliseTag = Txt.fromStrict . normalize NFC . Txt.toStrict diff --git a/src/Hash2Pub/PostService/API.hs b/src/Hash2Pub/PostService/API.hs new file mode 100644 index 0000000..1484631 --- /dev/null +++ b/src/Hash2Pub/PostService/API.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} +module Hash2Pub.PostService.API where + +import Data.Text.Lazy (Text) + +import Servant + +type PostServiceAPI = "relay" :> "inbox" :> Capture "hashtag" Text :> ReqBody '[PlainText] Text :> PutCreated '[PlainText] NoContent + -- delivery endpoint at responsible relay for delivering posts of $tag for distribution + :<|> "relay" :> "subscribers" :> Capture "senderID" Integer :> ReqBody '[PlainText] Text :> PostNoContent '[PlainText] Text + -- endpoint for delivering the subscriptions and outstanding queue + :<|> "post" :> Capture "postid" Text :> Get '[PlainText] Text + -- fetch endpoint for posts, full post ID is http://$domain/post/$postid + :<|> "posts" :> ReqBody '[PlainText] Text :> Post '[PlainText] Text + -- endpoint for fetching multiple posts at once + :<|> "posts" :> "inbox" :> ReqBody '[PlainText] Text :> PutCreated '[PlainText] NoContent + -- delivery endpoint of newly published posts of the relay's instance + :<|> "tags" :> Capture "hashtag" Text :> ReqBody '[PlainText] Text :> PostCreated '[PlainText] Text + -- delivery endpoint for posts of $tag at subscribing instance + :<|> "tags" :> Capture "hashtag" Text :> "subscribe" :> Header "Origin" Text :> Get '[PlainText] Integer + -- endpoint for subscribing the instance specified in + -- the Origin header to $hashtag. + -- Returns subscription lease time in seconds. + :<|> "tags" :> Capture "hashtag" Text :> "unsubscribe" :> Header "Origin" Text :> Get '[PlainText] Text + -- endpoint for unsubscribing the instance specified in + -- the Origin header to $hashtag + +-- | needed for guiding type inference +exposedPostServiceAPI :: Proxy PostServiceAPI +exposedPostServiceAPI = Proxy + diff --git a/src/Hash2Pub/ProtocolTypes.hs b/src/Hash2Pub/ProtocolTypes.hs index 86825a7..a5af10c 100644 --- a/src/Hash2Pub/ProtocolTypes.hs +++ b/src/Hash2Pub/ProtocolTypes.hs @@ -1,7 +1,5 @@ module Hash2Pub.ProtocolTypes where -import qualified Data.Map as Map -import Data.Maybe (mapMaybe) import qualified Data.Set as Set import Data.Time.Clock.POSIX (POSIXTime) -- 2.44.1