diff --git a/Hash2Pub.cabal b/Hash2Pub.cabal index 54cb29d..251c60d 100644 --- a/Hash2Pub.cabal +++ b/Hash2Pub.cabal @@ -46,7 +46,7 @@ category: Network extra-source-files: CHANGELOG.md common deps - build-depends: base ^>=4.12.0.0, containers ^>=0.6.0.1, bytestring, utf8-string ^>=1.0.1.1, network ^>=2.8.0.1, time ^>=1.8.0.2, cmdargs ^>= 0.10, cryptonite ^>= 0.25, memory, async, stm, asn1-encoding, asn1-types, asn1-parse, publicsuffix, network-byte-order, safe, iproute, mtl, random, servant, servant-server, servant-client, warp, text, unordered-containers, hashable, unicode-transforms + build-depends: base ^>=4.12.0.0, containers ^>=0.6.0.1, bytestring, utf8-string ^>=1.0.1.1, network ^>=2.8.0.1, time ^>=1.8.0.2, cmdargs ^>= 0.10, cryptonite ^>= 0.25, memory, async, stm, asn1-encoding, asn1-types, asn1-parse, publicsuffix, network-byte-order, safe, iproute, mtl, random, servant, servant-server, servant-client, warp, text, unordered-containers, hashable, unicode-transforms, http-client ghc-options: -Wall diff --git a/app/Main.hs b/app/Main.hs index 98961c0..3bdb4d4 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -57,7 +57,7 @@ readConfig = do , confMaxLookupCacheAge = 300 } sConf = ServiceConf { - confSubscriptionExpiryTime = 2*3600 `div` read speedup + confSubscriptionExpiryTime = fromIntegral $ 2*3600 `div` (read speedup :: Integer) , confServicePort = read servicePortString , confServiceHost = confDomainString } diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index e73e7f5..91b3822 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/src/Hash2Pub/FediChordTypes.hs @@ -430,7 +430,7 @@ instance Hashable.Hashable NodeID where hash = Hashable.hash . getNodeID data ServiceConf = ServiceConf - { confSubscriptionExpiryTime :: Integer + { confSubscriptionExpiryTime :: POSIXTime -- ^ subscription lease expiration in seconds , confServicePort :: Int -- ^ listening port for service diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs index dc2164a..d56eb4c 100644 --- a/src/Hash2Pub/PostService.hs +++ b/src/Hash2Pub/PostService.hs @@ -16,7 +16,8 @@ import Control.Concurrent.STM.TQueue import Control.Concurrent.STM.TVar import Control.Monad (foldM, forM_, forever) import Control.Monad.IO.Class (liftIO) -import qualified Data.ByteString.Lazy.UTF8 as BSU +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) @@ -26,6 +27,7 @@ import Data.Text.Normalize (NormalizationMode (NFC), normalize) import Data.Time.Clock.POSIX import Data.Typeable (Typeable) +import qualified Network.HTTP.Client as HTTP import System.Random import qualified Network.Wai.Handler.Warp as Warp @@ -235,7 +237,18 @@ tagDelivery serv hashtag posts = do pure $ "Received a postID for tag " <> hashtag tagSubscribe :: PostService d -> Txt.Text -> Maybe Txt.Text -> Handler Integer -tagSubscribe serv hashtag origin = pure 42 +tagSubscribe serv hashtag origin = do + originURL <- maybe + (throwError $ err400 { errBody = "Missing Origin header" }) + pure + origin + req <- HTTP.parseUrlThrow (Txt.unpack originURL) + now <- liftIO getPOSIXTime + let leaseTime = now + confSubscriptionExpiryTime (serviceConf serv) + -- setup subscription entry + _ <- liftIO . atomically $ setupSubscriberChannel (subscribers serv) hashtag (BSU.toString $ HTTP.host req, HTTP.port req) leaseTime + pure $ round leaseTime + tagUnsubscribe :: PostService d -> Txt.Text -> Maybe Txt.Text -> Handler Txt.Text tagUnsubscribe serv hashtag origin = pure $ "Here be a dragon unsubscription from " <> fromMaybe "Nothing" origin <> " to " <> hashtag @@ -310,7 +323,7 @@ normaliseTag = Txt.fromStrict . normalize NFC . Txt.toStrict -- No idea what I'm doing with these overlappable instances though ¯\_(ツ)_/¯ -- TODO: figure out how this overlapping stuff actually works https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#instance-overlap instance {-# OVERLAPPABLE #-} Show a => MimeRender PlainText a where - mimeRender _ = BSU.fromString . show + mimeRender _ = BSUL.fromString . show -- ====== worker threads ======