Client.hs

-- | Voicebase V2Beta API
--
-- Simpler, faster, more productive! This new API has a 'runVB'for
-- connection reuse.
--
-- Comes with command line submitTranscriptionr executable: "voicebase"
--
-- example:
--
-- @
-- import Voicebase.V2Beta.Client
--
-- main = do
--   runVB (defaultConfig token) (transcribe $ Bytes mempty "audio/wav" mempty)
--   >>= print
-- @
--
-- > voicebase: HttpExceptionRequest Request {
-- >   host                 = "apis.voicebase.com"
-- >   port                 = 443
-- >   secure               = True
-- >   requestHeaders       = [("Content-Type","multipart/form-data; boundary=----We
-- >   path                 = "/v2-beta/media/"
-- >   queryString          = ""
-- >   method               = "POST"
-- >   proxy                = Nothing
-- >   rawBody              = False
-- >   redirectCount        = 10
-- >   responseTimeout      = ResponseTimeoutDefault
-- >   requestVersion       = HTTP/1.1
-- > }
-- >  (StatusCodeException (Response {responseStatus = Status {statusCode = 401, sta070EFD2A2E0D5A2D;path=/;Secure;HttpOnly"),("Set-Cookie","SERVERID=; Expires=Thuntials","true"),("Access-Control-Allow-Methods","DELETE, GET, HEAD, OPTIONS, PO "{\"status\":401,\"errors\":{\"error\":\"The Authorization header you provided
-- >
-- >
--
-- <http://voicebase.readthedocs.io/en/v2-beta/>

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE ViewPatterns               #-}


module Voicebase.V2Beta.Client
    (
      -- * Running
      runVB,

      -- * Actions
      transcribe,
      transcribeAndFetchMedia,
      submitTranscription,
      fetchTranscript,
      fetchMedia,

      -- * General helpers
      vbPost,
      vbGet,

      -- * Data
      defaultConfig,
      withRedaction,
      BearerToken,
      VBUpload(..),
      VBConfig(..),
  Configuration(..), channels, language, detections, ChannelSpeakers(..), left,
  right, Speaker(..), Detection(..), Language(..), JSONInvertible(..),
  ) where

import           Control.Applicative
import           Control.Lens
import           Control.Lens.TH
import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.Reader
import           Data.Coerce
import           Data.String

import           Data.Bifunctor
import           Data.Maybe
import           Data.Monoid
import qualified Data.Text                      as Text
import           Data.Text.Encoding             as TE

import qualified Data.ByteString.Char8          as BS
import qualified Data.ByteString.Lazy           as LBS
import qualified Data.ByteString.Lazy.Char8     as C8LBS
import           Data.Text                      (Text, unpack)

import           Data.Aeson                     (FromJSON (parseJSON),
                                                 ToJSON (..), Value,
                                                 eitherDecode, encode, object,
                                                 (.=))
import           Data.Aeson.Lens
import           Data.Aeson.Roundtrip
import           Data.Aeson.Types               (parseEither)
import           Network.HTTP.Client            (defaultManagerSettings,
                                                 managerResponseTimeout,
                                                 responseTimeoutMicro)
import           Network.HTTP.Client.OpenSSL
import           Network.Mime                   (MimeType)
import           Network.Wreq                   (asJSON, defaults,
                                                 partFileSource, partLBS)
import           Network.Wreq.Lens
import           Network.Wreq.Session
import           Network.Wreq.Types             (Postable (..))
import           OpenSSL.Session                (context)

import           GHC.Generics

import           System.IO                      (fixIO)

import           Voicebase.V2Beta.Configuration

-- | get your bearer token at http://voicebase.readthedocs.io/en/v2-beta/how-to-guides/hello-world.html#token
newtype BearerToken = BearerToken BS.ByteString
  deriving IsString

v2beta :: String
v2beta = "https://apis.voicebase.com/v2-beta/media"

-- | Data for our 'VB' ReaderT
-- | Comes with lenses
data VBConfig = VBConfig {
    _apiConfig :: Configuration
  , _token     :: BearerToken
  , _baseURI   :: String
  , _session   :: Session
}

makeLenses ''VBConfig

defaultConfig :: BearerToken -> Session -> VBConfig
defaultConfig _token _session =
    VBConfig {
        _apiConfig = Configuration {
            _channels = Just ChannelSpeakers {
                _left = Speaker "Agent"
              , _right = Speaker "Caller"
            }
          , _language = EnglishAus
          , _detections = [RedactingPCI]
        }
      , _baseURI = v2beta
      , ..
    }

-- | Turn on PCI redaction, you may want to fetch the media with 'fetchMedia
withRedaction :: VBConfig -> VBConfig
withRedaction = apiConfig . detections <>~ [RedactingPCI]

type VB a = ReaderT VBConfig IO a

-- | Run a VB action with a tls connection.
runVB :: (Session -> VBConfig) -> VB a -> IO a
runVB ck k =
  -- Creates one TLS connection for performance, without cookie tracking.
  runReaderT k =<< (ck <$> liftIO newAPISession)

authOptions :: VB Options
authOptions = do
  token <- asks _token
  pure $ defaults
    &  manager
    .~ Left (opensslManagerSettings context)
    &  manager
    .~ Left (defaultManagerSettings { managerResponseTimeout = responseTimeoutMicro 10000 })
    &  header "Authorization"
    .~ ["Bearer " <> coerce token]

partConfiguration :: Configuration -> Part
partConfiguration config =
  partLBS "configuration" $ either error encode $ runBuilder syntax config

data VBUpload = Bytes { audio :: LBS.ByteString , mimetype :: MimeType, filename :: FilePath}
              | File { path :: FilePath }

-- | Put an API config and voicebase upload config together
uploadParts
  :: VBUpload
  -> VB [Part]
uploadParts upload = do
    config <- asks (partConfiguration . _apiConfig)
    pure [toMediaPart upload, config]

toMediaPart :: VBUpload -> Part
toMediaPart Bytes{..} = partLBS "media" audio & partContentType ?~ mimetype & partFileName ?~ filename
toMediaPart File{..} = partFileSource "media" path

-- @ transcribe upload = submitTranscription upload >>= waitFinish >>= fetchTranscript @
-- What you might want to do for a polling workflow. If interrupted, just upload
-- again.
transcribe :: VBUpload -> VB Value
transcribe upload = submitTranscription upload >>= waitFinish >>= fetchTranscript

-- | Same as 'transcribe' but also sequentially fetch the media (which may be different if PCI redacted)
transcribeAndFetchMedia :: VBUpload -> VB (Value, C8LBS.ByteString)
transcribeAndFetchMedia upload = do
  mid <- submitTranscription upload >>= waitFinish
  (,) <$> fetchTranscript mid <*> fetchMedia mid

-- | @ submitTranscription upload >>= waitFinish >>= fetchTranscript @
--
-- Uploads a file and waits for completion of the job by polling
submitTranscription :: VBUpload -> VB MediaID
submitTranscription upload = do
  parts <- uploadParts upload
  auth <- authOptions

  r <- asJSON =<< vbPost mempty parts
  case r ^? responseBody . key @Value "mediaId" . _String of
    Nothing -> error $ "expected mediaId in voicebase response: " <> show r
    Just (MediaID -> mid) -> pure mid

-- | Keep polling media until state is finished or failed
-- if it failed, explode with an error.
--
-- This error handling is terrible, but the API doesn't document errors so...
waitFinish :: MediaID -> VB MediaID
waitFinish mid = do
  st <- getProgress mid
  case st of
    "finished" -> return mid
    "failed" -> error $ "VoiceBase transcription failed for media id: " <> show mid
    _ -> waitFinish mid

newtype MediaID = MediaID { unMediaID :: Text }
  deriving Show

makeURL :: String -> VB String
makeURL p = (\b -> b <> "/" <> p) <$> asks _baseURI

vbGet :: String -> VB (Response LBS.ByteString)
vbGet = wrapwreq getWith

wrapwreq k path = do
  o <- authOptions
  s <- asks _session
  u <- makeURL path
  liftIO $ k o s u

vbPost :: Postable a => String -> a -> VB (Response LBS.ByteString)
vbPost p a = wrapwreq (\o s u -> postWith o s u a) p

-- | Fetch the current state of the media
getProgress :: MediaID -> VB Text
getProgress (unpack . unMediaID -> mid) = do
    aopts <- authOptions
    r <- asJSON =<< vbGet (mid <> "/progress")
    case r ^? responseBody . key @Value "status" . _String of
      Just st -> return st
      Nothing -> error "unexpected voicebase response"

-- | Fetch e.g. redacted media
fetchMedia :: MediaID -> VB LBS.ByteString
fetchMedia (unpack . unMediaID -> mid) = do
    r <- asJSON =<< vbGet (mid <> "/streams")
    case r ^? responseBody . key @Value "streams" . key "original" . _String of
      Just uri -> do
        s <- asks _session
        view responseBody <$> liftIO (get s $ Text.unpack uri)
      Nothing -> error "Coudn't find a link to meda in :mid/streams response"
--
-- | Fetch a transcript. You should be sure the transcript is ready first weth
-- e.g. waitFinish.
fetchTranscript :: MediaID -> VB Value
fetchTranscript (unpack . unMediaID -> mid) = do
  r <- asJSON =<< vbGet mid
  return $ r ^. responseBody