Client.hs

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

module Network.Ntrip.Client where

import BasicPrelude                     hiding (intercalate, tail)
import Control.Concurrent.Async.Lifted
import Control.Lens
import Control.Monad.Catch
import Control.Monad.Trans.Control
import Data.Attoparsec.ByteString
import Data.Attoparsec.ByteString.Char8 (decimal, endOfLine, isEndOfLine)
import Data.ByteString
import Data.ByteString.Base64
import Data.CaseInsensitive
import Data.Conduit
import Data.Conduit.Attoparsec
import Data.Conduit.Network
import Network.HTTP.Types
import URI.ByteString

type MonadNtrip m =
  ( MonadBaseControl IO m
  , MonadIO m
  , MonadThrow m
  )

type SourceByteString m = Source m ByteString
type SinkByteString m   = Sink ByteString m ()

tcpClient :: MonadNtrip m => ByteString -> Int -> SourceByteString m -> SinkByteString m -> m ()
tcpClient host port source sink =
  runGeneralTCPClient (clientSettings port host) $ \ad ->
    void $ concurrently (source $$ appSink ad) (appSource ad $$ sink)

sourceNtrip :: MonadNtrip m => ByteString -> ByteString -> ByteString -> SourceByteString m -> SourceByteString m
sourceNtrip path user password source = do
  yield $ intercalate "\r\n"
    [ methodGet <> " " <> path <> " HTTP/1.0"
    , original hUserAgent <> ": NTRIP ntrip-client/0.0"
    , original hAuthorization <> ": " <> encode (user <> ":" <> password)
    , ""
    , ""
    ]
  source

parseNtrip :: Parser (ByteString, Status)
parseNtrip = do
  format  <- parseFormat
  code    <- parseCode
  message <- parseMessage
  return (format, Status code message)
  where
    takeSpace      = takeWhile1 (== 32)
    takeInClass    = takeWhile1 . inClass
    takeEndOfLine1 = takeWhile1 (not . isEndOfLine)
    parseFormat    = takeInClass "a-zA-Z0-9/." <* takeSpace
    parseCode      = decimal <* takeSpace
    parseMessage   = takeEndOfLine1 <* endOfLine

sinkNtrip :: MonadNtrip m => SinkByteString m -> SinkByteString m
sinkNtrip sink = do
  (format, status) <- sinkParser parseNtrip
  unless (format == "ICY") $ throwIO $ userError "Unsupported format"
  unless (status == status200) $ throwIO $ userError "Bad status"
  sink

runNtrip :: MonadNtrip m => ByteString -> SourceByteString m -> SinkByteString m -> m ()
runNtrip url source sink = do
  uri  <- either (throwIO . userError . textToString . show) return $ parseURI strictURIParserOptions url
  auth <- maybe (throwIO $ userError "Bad authority") return $ uri ^. authorityL
  ui   <- maybe (throwIO $ userError "Bad user info") return $ auth ^. authorityUserInfoL
  tcpClient
    (hostBS $ auth ^. authorityHostL)
    (fromMaybe 2101 $ portNumber <$> auth ^. authorityPortL)
    (sourceNtrip
      (tail $ uri ^. pathL)
      (ui ^. uiUsernameL)
      (ui ^. uiPasswordL)
      source)
    (sinkNtrip sink)