simple post fetch worker thread

src/Hash2Pub/PostService.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DataKinds             #-}
+{-# laNGUAGE DataKinds             #-}
 {-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE InstanceSigs          #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
@@ -15,7 +15,7 @@ import           Control.Concurrent.STM.TChan
 import           Control.Concurrent.STM.TChan
 import           Control.Concurrent.STM.TQueue
 import           Control.Concurrent.STM.TVar
-import           Control.Exception             (Exception (..))
+import           Control.Exception             (Exception (..), try)
 import           Control.Monad                 (foldM, forM, forM_, forever)
 import           Control.Monad.IO.Class        (liftIO)
 import           Control.Monad.STM
@@ -31,6 +31,7 @@ import           Data.Text.Normalize           (NormalizationMode (NFC),
 import           Data.Time.Clock.POSIX
 import           Data.Typeable                 (Typeable)
 import qualified Network.HTTP.Client           as HTTP
+import qualified Network.HTTP.Types            as HTTPT
 import           System.Random
 import           Text.Read                     (readEither)
 
@@ -341,7 +342,7 @@ clientDeliverSubscriptions serv fromTag toTag (toHost, toPort) = do
       Right _ -> do
           atomically $
               modifyTVar' (subscribers serv) $ \tagMap ->
-                  foldr deleteRMapEntry tagMap ((\(_, _, t) -> genKeyID . Txt.unpack $ t) <$> intervalTags) 
+                  foldr deleteRMapEntry tagMap ((\(_, _, t) -> genKeyID . Txt.unpack $ t) <$> intervalTags)
           pure . Right $ ()
   where
       channelGetAll :: TChan a -> STM [a]
@@ -479,3 +480,28 @@ processIncomingPosts serv = forever $ do
               _ <- forceLookupKey (baseDHT serv) (Txt.unpack tag)
               atomically . writeTQueue (relayInQueue serv) $ (tag, pID, pContent)
           Right yay -> putStrLn $ "Yay! " <> show yay
+
+
+-- | process the pending fetch jobs of delivered post IDs: Delivered posts are tried to be fetched from their URI-ID
+fetchTagPosts :: DHT d => PostService d -> IO ()
+fetchTagPosts serv = forever $ do
+    -- blocks until available
+    -- TODO: batching, retry
+    -- TODO: process multiple in parallel
+    pIdUri <- atomically . readTQueue $ postFetchQueue serv
+    httpMan <- HTTP.newManager HTTP.defaultManagerSettings
+    fetchReq <- HTTP.parseRequest . Txt.unpack $pIdUri
+    resp <- try $ HTTP.httpLbs fetchReq httpMan :: IO (Either HTTP.HttpException (HTTP.Response BSUL.ByteString))
+    case resp of
+      Right response ->
+          if HTTPT.statusCode (HTTP.responseStatus response) == 200
+             then
+             -- success, TODO: statistics
+             putStrLn "post fetch success"
+             else
+             -- TODO error handling, retry
+             pure ()
+      Left _ ->
+             -- TODO error handling, retry
+             pure ()
+