Client.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}

module Speechmatics.Client(
  transcribeBytes,
  transcribe,
  AuthToken,
  UserID,
  ModelName,
  LazyByteFile(..),
  Error(..),
  Format(..)
) where

import Network.HTTP.Types.URI
import           Control.Concurrent         (threadDelay)
import OpenSSL.Session (context)
import Control.Lens
import Control.Monad
import Control.Applicative

import Data.Aeson(Value, eitherDecode, FromJSON(parseJSON))
import Network.HTTP.Client (defaultManagerSettings, managerResponseTimeout,  responseTimeoutMicro)

import Network.Wreq
import Network.Mime(MimeType)
import qualified Network.Wreq.Session as Sess
import Network.HTTP.Client.OpenSSL
import Data.Bifunctor

import qualified Data.ByteString.Char8 as C8BS
import qualified Data.ByteString.Lazy.Char8 as C8LBS
import qualified Data.ByteString.Lazy as LBS
import qualified Network.Wreq.Session as Sess
import Data.Text
import Data.Monoid
import qualified Speechmatics.JSON.PostJob as Post
import qualified Speechmatics.JSON.PeekJob as Peek
import Data.Maybe

-- | Authorization token obtained from speechmatics
type AuthToken = Maybe Text
-- | UserID obtained from speechmatics
type UserID = Integer
-- | Which langauge model to use
type ModelName = String
type JobID = Integer

data LazyByteFile = LazyByteFile {
  content :: LBS.ByteString,
  filename :: String,
  mimetype :: MimeType -- to get this Jappie used defaultMimeLookup "f.mp3"
  }
data Error = UnkownResponse | ParseError String
  deriving(Show)

makeOpts :: Options
makeOpts = withAuthorization defaults

timeout = responseTimeoutMicro 10000

inputName :: Text
inputName = pack "data_file"

modelName :: Text
modelName = pack "model"

data Format = JsonV1 | JsonV2

-- | Transcribe a file that is already loaded in memory
--   Does not catch exeptions
transcribeBytes :: Format -> String -> UserID -> AuthToken -> ModelName -> LazyByteFile -> IO(Either Error Value)
transcribeBytes format url userID bearerToken model (LazyByteFile content filename mimetype) = do
  transcribe format url userID bearerToken defaults parts
  where
    parts = [
        partLBS inputName content 
          & partContentType .~ Just mimetype 
          & partFileName .~ Just filename,
        partString modelName model
      ]

withAuthorization :: Options -> Options
withAuthorization options = options 
  & manager .~ Left (opensslManagerSettings context) 
  & manager .~ Left (defaultManagerSettings { managerResponseTimeout = timeout} )

formatQuery :: Format -> QueryText
formatQuery JsonV1 = []
formatQuery JsonV2 = [("format", Just "json-v2")]

authQuery :: AuthToken -> QueryText
authQuery auth = maybeToList $ (\x -> (pack "auth_token", Just x)) <$> auth

slash = mappend . (flip mappend "/") -- play around to much with ghci
jobsUri :: String -> UserID -> String -> String
jobsUri url userID x = url <> (show userID) `slash` "jobs" `slash` x

printQuery :: QueryText -> String
printQuery = C8BS.unpack . (renderQuery True) . queryTextToQuery 

-- | More general transcription interface, allows custom parts to be inserted 
--   with whatever the user wants.
--   Does not catch exeptions
transcribe :: Format -> String -> UserID -> AuthToken -> Options -> [Part] -> IO(Either Error Value)
transcribe format uri userID token options parts = do
  session <- Sess.newSession
  print "begin"
  response <- Sess.postWith auth session postUri parts
  print $ response ^. responseBody
  print uri
  case Post.parse (response ^. responseBody) of
    Left message -> return $ Left $ ParseError message
    Right parsed -> do
      let jobID = Post.postId parsed
      pollStatus uri userID token session jobID >>= \case
        Just error -> return $ Left $ error
        Nothing -> do 
          let transcriptUri = (url userID ((show jobID) `slash` "transcript")) <> (printQuery $ formatQuery format <> authQuery token)
          result <- Sess.getWith makeOpts session transcriptUri
          return $ first ParseError $ eitherDecode (result ^. responseBody)
  where 
    auth = (withAuthorization options)
    postUri =  url userID (printQuery $ authQuery token ) 
    url = jobsUri uri

pollStatus :: String -> UserID -> AuthToken -> Sess.Session -> JobID -> IO(Maybe Error)
pollStatus = pollStatus' Nothing

waitFor :: Int -> IO()
waitFor x = threadDelay (1000000*x)

pollStatus' :: Maybe Integer -> String -> UserID -> AuthToken -> Sess.Session -> JobID -> IO(Maybe Error)
pollStatus' (Just wait) url user auth sess jobid = 
  waitFor (fromIntegral wait) >> (pollStatus' Nothing) url user auth sess jobid
pollStatus' Nothing url userID token session jobID = do 
  let statusUri = (jobsUri url userID $ show $ jobID) <> (printQuery $ authQuery token)
  statusResponse <- Sess.getWith makeOpts session statusUri
  -- print statusResponse
  let body = statusResponse ^. responseBody
  case second Peek.jobCheckWait (Peek.parse body) of 
    Left error -> return $ Just $ ParseError error 
    Right Nothing -> return $ Nothing -- done
    Right maybe -> pollStatus' maybe url userID token session jobID