Http2MastodonStream.hs

{-# LANGUAGE PackageImports, OverloadedStrings, LambdaCase #-}
module Http2MastodonStream where

import "http2-client" Network.HTTP2.Client
import "data-default-class" Data.Default.Class
import "tls" Network.TLS
import "tls" Network.TLS.Extra.Cipher
import "http2" Network.HTTP2
import "bytestring" Data.ByteString.Char8 (pack)
import qualified "bytestring" Data.ByteString.Char8 as B
import "base" Control.Monad (unless, void)

host = "qdon.space"
path = "/api/v1/streaming/public"
port = 443

clientParams = (defaultParamsClient "127.0.0.1" "") {
      clientHooks = def {
          onServerCertificate = \_ _ _ _ -> putStrLn "Certificate accepting..." >> return []
        , onSuggestALPN = return alpns
        }
    , clientSupported = def { supportedCiphers = ciphersuite_default }
    }
    where alpns = Just ["h2"]

main = newHttp2FrameConnection host port (Just clientParams)
    >>= \c -> runHttp2Client c 8192 8192 [(SettingsEnablePush, 0)] defaultGoAwayHandler ignoreFallbackHandler $ \conn -> do
                let requestHeaders =
                        [ (":method", "GET")
                        , (":scheme", "https")
                        , (":path", path)
                        , (":authority", pack host)
                        , ("accept", "text/event-stream")
                        ]
                withHttp2Stream conn $ \stream ->
                    StreamDefinition (headers stream requestHeaders (setEndHeader . setEndStream)) $ \ing _ -> do
                        putStrLn "Connecting stream..."
                        (header, isEnd) <- _waitEvent stream >>= \case
                            StreamHeadersEvent frameHeader hdrs -> return (hdrs, testEndStream (flags frameHeader))
                            StreamPushPromiseEvent{} -> do
                                _rst stream RefusedStream
                                return ([], True)
                            ev -> error $ "wat: " ++ show ev

                        let loop :: (a -> Bool) -> a -> (a -> IO a) -> IO a
                            loop breakcheck ret f = f ret >>= \case
                                  x | breakcheck x -> return x
                                    | otherwise -> loop breakcheck x f
                            isSuccessful = maybe False ((== '2') . B.head) $ lookup ":status" header

                        print header

                        unless (isEnd || not isSuccessful) . void . loop not False $ \_ ->
                            _waitEvent stream >>= \case
                                StreamDataEvent frameHeader x
                                    | testEndStream (flags frameHeader) -> processData >> return True
                                    | otherwise -> do
                                        _consumeCredit ing (payloadLength frameHeader)
                                        _addCredit ing (payloadLength frameHeader)
                                        _updateWindow ing
                                        processData
                                        return True
                                    where processData = do
                                            print x
                                StreamPushPromiseEvent{} -> do
                                    _rst stream RefusedStream
                                    return False
                                StreamHeadersEvent{} -> return False
                                ev -> error $ "wat: " ++ show ev

                putStrLn "done"
                _gtfo conn NoError "wat is this"