Http2.hs

{-# LANGUAGE OverloadedStrings, OverloadedLists, FlexibleInstances #-}
module Http2 (request) where

import Prelude hiding (reverse, null, drop, length, foldr)
import "http2-client" Network.HTTP2.Client
    ( StreamEvent(..)
    , Http2Stream(_rst, _waitEvent)
    , IncomingFlowControl(_addCredit, _consumeCredit, _updateWindow)
    , StreamDefinition(StreamDefinition)
    , newHttp2FrameConnection, runHttp2Client, withHttp2Stream
    , _gtfo, headers
    , defaultGoAwayHandler, ignoreFallbackHandler
    )
import "data-default-class" Data.Default.Class (def)
import "tls" Network.TLS
    (ClientParams(clientHooks, clientSupported)
    , ClientHooks(onServerCertificate, onSuggestALPN)
    , Supported(supportedCiphers)
    , defaultParamsClient
    )
import "tls" Network.TLS.Extra.Cipher (ciphersuite_strong)
import "http2" Network.HTTP2
    ( ErrorCodeId(NoError, RefusedStream)
    , toErrorCodeId, SettingsKeyId(SettingsEnablePush)
    , FrameHeader(flags, payloadLength)
    , setEndStream, setEndHeader, testEndStream
    )
import "http2" Network.HPACK (HeaderList)
import qualified "bytestring" Data.ByteString.Char8 as C (map)
import "bytestring" Data.ByteString (ByteString, breakSubstring, reverse, null, drop, length, foldr)
import "base" Control.Monad (unless, void)
import "base" Data.Char (ord, toLower)
import "base" Data.Maybe (fromMaybe, isJust, fromJust)
import "network" Network.Socket (PortNumber)
import "text" Data.Text.Encoding (decodeUtf8)
import "text" Data.Text (unpack)
import "base" Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar, tryTakeMVar)
import "base" Control.Concurrent (forkIO)
import "conduit" Conduit (repeatWhileMC, mapC, ConduitT, (.|))
import "unordered-containers" Data.HashMap.Lazy (toList, insert, HashMap)
import "base" Data.List (foldl', sortOn)

split :: ByteString -> ByteString -> (ByteString, ByteString)
split del = second (drop (length del)) . breakSubstring del
    where second :: (b -> c) -> (a, b) -> (a, c)
          second f (a, b) = (a, f b)

getPort :: ByteString -> Maybe (ByteString, PortNumber)
getPort h = fmap (\p -> (reverse revHost, fromIntegral p)) mayPort
    where (revPort, revHost) = split ":" (reverse h)
          mayPort :: Maybe Int
          mayPort = foldr (\current state -> do {s <- state; c <- getDigit current; Just (s * 10 + c)} ) (Just 0) revPort
          zero = ord '0'
          getDigit x
            | z < 0 || z > 9 = Nothing
            | otherwise = Just z
            where z = fromIntegral x - zero

schemePort :: ByteString -> PortNumber
schemePort "https" = 443
schemePort "http" = 80
schemePort _ = 80

data Params = Params
    { _host :: String
    , _port :: PortNumber
    , _header :: HashMap ByteString ByteString
    } deriving Show

data HTTPEvent = HTTPEvent
    { onHeader :: HeaderList -> IO ()
    , onData :: ByteString -> IO ()
    , onEnd :: IO ()
    , onError :: ErrorCodeId -> IO ()
    }

parseUrl :: ByteString -> Params
parseUrl x =
    let (mayScheme, x1) = split "://" x
        (method, scheme)
            | null b = ("GET", mayScheme)
            | otherwise = res
            where res@(_, b) = split " " mayScheme
        (x2, path) = breakSubstring "/" x1
        (host, port) = fromMaybe (x2, schemePort scheme) (getPort x2)
     in Params (unpack $ decodeUtf8 host) port [(":method", method), (":scheme", scheme), (":path", path), (":authority", x2)]

clientParams :: ClientParams
clientParams = (defaultParamsClient "127.0.0.1" "") {
      clientHooks = def {
          onServerCertificate = \_ _ _ _ -> return []
        , onSuggestALPN = return alpns
        }
    , clientSupported = def { supportedCiphers = ciphersuite_strong }
    }
    where alpns = Just ["h2"]

requestWithEvent :: HTTPEvent -> Params -> IO ()
requestWithEvent HTTPEvent{onHeader, onData, onEnd, onError} Params{_host, _port, _header} = do
    c <- newHttp2FrameConnection _host _port (Just clientParams)
    runHttp2Client c 8192 8192 [(SettingsEnablePush, 0)] defaultGoAwayHandler ignoreFallbackHandler $ \conn -> do
        withHttp2Stream conn $ \stream ->
            StreamDefinition (headers stream (sortOn fst $ toList _header) (setEndHeader . setEndStream)) $ \ing _ -> do
                (header, isEnd) <- _waitEvent stream >>= \case
                    StreamHeadersEvent frameHeader hdrs -> return (hdrs, testEndStream (flags frameHeader))
                    StreamPushPromiseEvent{} -> do
                        _rst stream RefusedStream
                        return ([], True)
                    StreamErrorEvent _ code -> onError (toErrorCodeId code) >> return ([], True)
                    ev -> error $ "watz: " ++ 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') . C.head) $ lookup ":status" header

                onHeader header

                unless isEnd . void . loop not False $ \_ ->
                    _waitEvent stream >>= \case
                        StreamDataEvent frameHeader x
                            | testEndStream (flags frameHeader) -> processData >> return False
                            | otherwise -> do
                                _consumeCredit ing (payloadLength frameHeader)
                                _addCredit ing (payloadLength frameHeader)
                                _updateWindow ing
                                processData
                                return True
                                    where processData = onData x
                        StreamPushPromiseEvent{} -> do
                            _rst stream RefusedStream
                            return False
                        StreamHeadersEvent{} -> return False
                        StreamErrorEvent _ code -> onError (toErrorCodeId code) >> return True

        _gtfo conn NoError ""
        onEnd

wrapRequest :: Params -> IO (Either ErrorCodeId (HeaderList, ConduitT () ByteString IO ()))
wrapRequest params = do
    headerMVar <- newEmptyMVar
    chunk <- newEmptyMVar
    err <- newEmptyMVar

    let event = HTTPEvent { onHeader = putMVar headerMVar, onData = putMVar chunk . Just, onEnd = putMVar chunk Nothing, onError = putMVar err}
    forkIO $ requestWithEvent event params

    h <- takeMVar headerMVar
    mayError <- tryTakeMVar err
    return $ case mayError of
               Nothing -> Right (h, repeatWhileMC (takeMVar chunk) isJust .| mapC fromJust)
               Just x -> Left x

concatParams :: ByteString -> [(ByteString, ByteString)] -> Params
concatParams url header = p { _header = foldl' (\hm (k, v) -> insert (C.map toLower k) v hm) defaultHeader header }
    where p@(Params _ _ defaultHeader) = parseUrl url

request :: ByteString -> HeaderList -> IO (Either ErrorCodeId (HeaderList, ConduitT () ByteString IO ()))
request u = wrapRequest . concatParams u