Client.hs

{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}

module Network.Skylark.Client
  ( runSkylark
  ) where

import Control.Concurrent.Async.Lifted
import Control.Concurrent.STM
import Control.Monad.Trans.Resource
import Data.Conduit
import Data.Conduit.TQueue
import Network.HTTP.Conduit
import Network.HTTP.Types
import Network.HTTP.Types.Header
import Preamble


{-# ANN module ("HLint: ignore Redundant flip"::String) #-}

-- | Device-Uid Header
--
hDevice :: HeaderName
hDevice = "Device-Uid"

-- | SBPv2 Content-Type
--
sbpContentType :: ByteString
sbpContentType = "application/vnd.swiftnav.broker.v1+sbp2"

-- | Download data from Skylark to sink.
--
download :: MonadResource m => ByteString -> Manager -> Request -> Sink ByteString m () -> m ()
download device manager request sink = do
  response <- flip http manager request
    { method = methodGet
    , requestHeaders =
        [ (hAccept, sbpContentType)
        , (hDevice, device)
        , (hPragma, "proxy")
        ]
    }
  responseBody response $$+- sink

-- | Upload data to Skylark from source.
--
upload :: MonadIO m => ByteString -> Manager -> Request -> TBQueue ByteString -> m ()
upload device manager request queue =
  void $ flip httpLbs manager request
    { method      = methodPut
    , requestHeaders =
        [ (hContentType, sbpContentType)
        , (hDevice, device)
        ]
    , requestBody = requestBodySourceChunked $ sourceTBQueue queue
    }

-- | Run Skylark client.
--
runSkylark :: MonadMain m => String -> ByteString -> Source m ByteString -> Sink ByteString m () -> m ()
runSkylark url device source sink = do
  manager <- liftIO $ newManager tlsManagerSettings
  request <- parseRequest url
  queue   <- liftIO $ atomically $ newTBQueue 8192
  void $ concurrently (download device manager request sink) $
    concurrently (source $$ sinkTBQueue queue) (upload device manager request queue)