voicebase 0.1.1.4 → 0.2.0.0
raw patch · 13 files changed
+518/−668 lines, 13 filesdep +hspecdep +lens-aesondep +mtldep −json-autotypesetup-changed
Dependencies added: hspec, lens-aeson, mtl, roundtrip, roundtrip-aeson
Dependencies removed: json-autotype
Files
- ChangeLog.md +5/−0
- Setup.hs +1/−1
- app/Main.hs +0/−58
- lib/Voicebase/V2Beta/Client.hs +271/−0
- lib/Voicebase/V2Beta/Configuration.hs +93/−0
- src/Json/ProgressTypes.hs +0/−81
- src/Json/SubmitMediaTypes.hs +0/−96
- src/Json/TranscriptTypes.hs +0/−235
- src/Main.hs +46/−0
- src/VoicebaseClient.hs +0/−185
- test/ConfigJSONSpec.hs +86/−0
- test/Spec.hs +1/−2
- voicebase.cabal +15/−10
ChangeLog.md view
@@ -1,3 +1,8 @@ # Changelog for voicebase +0.2.0.0 - Nov 1 2018++* Backwards incompatible rewrite+* PCI redaction supported+ ## Unreleased changes
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple+import Distribution.Simple main = defaultMain
− app/Main.hs
@@ -1,58 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}--module Main where--import Data.Aeson (encode)-import qualified Data.ByteString.Lazy as LBS-import qualified Data.ByteString.Lazy.Char8 as C8LBS-import Data.Monoid ((<>))-import qualified Data.Text as Text-import Network.Mime (defaultMimeLookup)-import Options.Applicative-import System.FilePath (splitFileName)-import VoicebaseClient--data Options = Options- {- bearToken :: BearerToken,- file :: FilePath- }---sample :: Parser Options-sample = Options- <$> strOption- ( long "bearer-token"- <> metavar "TOKEN"- <> help "The bearer token obtained from voicebase" )- <*> strOption- ( long "file"- <> metavar "PATH"- <> help "The file to be posted" )--main :: IO ()-main = execParser opts >>= withBearAndFile- where- opts = info (sample <**> helper)- ( fullDesc- <> progDesc "Transcribe a file with voicebase"- <> header "Voicebase transcriber!" )--defaultConfiguration = Configuration {- channels = Just Channels {- left = Speaker "Agent"- , right = Speaker "Caller"- },- language = EnglishAus-}--withBearAndFile :: Options -> IO()-withBearAndFile Options{..} = do- bytes <- LBS.readFile file- result <- transcribeBytes defaultConfiguration bearToken (LazyByteFile bytes filename)- case result of- Left error -> print error- Right r -> C8LBS.putStrLn $ encode $ r- where- filename = defaultMimeLookup . Text.pack . snd . splitFileName $ file
+ lib/Voicebase/V2Beta/Client.hs view
@@ -0,0 +1,271 @@+-- | 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
+ lib/Voicebase/V2Beta/Configuration.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++-- | JSON syntax and data types for user facing request configuration+module Voicebase.V2Beta.Configuration+ (Configuration(..), channels, language, detections, ChannelSpeakers(..), left, right, Speaker(..), Detection(..), Language(..), JSONInvertible(..))+where++import Control.Isomorphism.Partial hiding (left, right)+import Control.Lens.TH+import Data.Aeson+import Data.Aeson.Roundtrip+import Data.String+import Data.Text (Text)+import Prelude hiding ((*>), (<$>), (<*>))+import Text.Roundtrip.Classes+import Text.Roundtrip.Combinators++class JSONInvertible a where+ syntax :: JSONSyntax s => s a++-- https://voicebase.readthedocs.io/en/v2-beta/how-to-guides/languages.html+data Language =+ Dutch | EnglishUS | EnglishUK | EnglishAus | French | German | Italian | Portuguese | SpanishLatinAmerican | SpanishSpain+ deriving (Eq, Ord, Show, Read)+defineIsomorphisms ''Language++instance JSONInvertible Language where+ syntax =+ dutch <$> jsonString `is` "nl-NL"+ <|> englishUS <$> jsonString `is` "en-US"+ <|> englishUK <$> jsonString `is` "en-UK"+ <|> englishAus <$> jsonString `is` "en-AU"+ <|> french <$> jsonString `is` "fr-FR"+ <|> german <$> jsonString `is` "de-DE"+ <|> italian <$> jsonString `is` "it-IT"+ <|> portuguese <$> jsonString `is` "pt-BR"+ <|> spanishLatinAmerican <$> jsonString `is` "es-LA"+ <|> spanishSpain <$> jsonString `is` "es-ES"++newtype Speaker = Speaker Text deriving (Eq, Ord, Show, Read, IsString)++defineIsomorphisms ''Speaker++instance JSONInvertible Speaker where+ syntax = speaker <$> jsonField "speaker" jsonString++data ChannelSpeakers = ChannelSpeakers {+ _left :: Speaker+ , _right :: Speaker+} deriving (Eq, Ord, Show, Read)++makeLenses ''ChannelSpeakers+defineIsomorphisms ''ChannelSpeakers++instance JSONInvertible ChannelSpeakers where+ syntax = channelSpeakers <$> jsonField "left" syntax <*> jsonField "right" syntax++data Detection = RedactingPCI+ deriving (Eq, Ord, Show, Read)++defineIsomorphisms ''Detection++infixr 7 ##+(##) = jsonField++instance JSONInvertible Detection where+ syntax = redactingPCI <$> "redact" ## redactSyntax+ *> "model" ## (jsonString `is` "PCI")+ where+ redactSyntax = "transcripts" ## (jsonString `is` "[redacted]")+ *> "audio" ## audioSyntax+ audioSyntax = "tone" ## (jsonIntegral `is` 270)+ *> "gain" ## (jsonRealFloat `is` 0.5)++data Configuration = Configuration {+ _channels :: Maybe ChannelSpeakers+ , _language :: Language+ , _detections :: [ Detection ]+} deriving (Eq, Ord, Show, Read)+defineIsomorphisms ''Configuration+makeLenses ''Configuration++instance JSONInvertible Configuration where+ syntax = jsonField "configuration" $ configuration+ <$> optional ("ingest" ## "channels" ## syntax)+ <*> "language" ## syntax+ <*> "detections" ## many syntax
− src/Json/ProgressTypes.hs
@@ -1,81 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeOperators #-}---- | Auto generated module by json-autotype-module Json.ProgressTypes where--import Control.Applicative-import Control.Monad (forM_, join, mzero)-import Data.Aeson (FromJSON (..), ToJSON (..),- Value (..), eitherDecode,- object, pairs, (.:), (.:?),- (.=))-import Data.Aeson.AutoType.Alternative-import Data.ByteString.Lazy-import qualified Data.ByteString.Lazy.Char8 as BSL-import Data.Monoid-import Data.Text (Text)-import qualified GHC.Generics-import System.Environment (getArgs)-import System.Exit (exitFailure, exitSuccess)-import System.IO (hPutStrLn, stderr)---- | Workaround for https://github.com/bos/aeson/issues/287.-o .:?? val = fmap join (o .:? val)---data Tasks = Tasks {-- } deriving (Show,Eq,GHC.Generics.Generic)---instance FromJSON Tasks where- parseJSON (Object v) = return Tasks- parseJSON _ = mzero---instance ToJSON Tasks where- toJSON (Tasks {}) = object []----data Progress = Progress {- progressStatus :: Text,- progressJobId :: Text,- progressTasks :: Tasks- } deriving (Show,Eq,GHC.Generics.Generic)---instance FromJSON Progress where- parseJSON (Object v) = Progress <$> v .: "status" <*> v .: "jobId" <*> v .: "tasks"- parseJSON _ = mzero---instance ToJSON Progress where- toJSON (Progress {..}) = object ["status" .= progressStatus, "jobId" .= progressJobId, "tasks" .= progressTasks]- toEncoding (Progress {..}) = pairs ("status" .= progressStatus<>"jobId" .= progressJobId<>"tasks" .= progressTasks)---data TopLevel = TopLevel {- topLevelStatus :: Text,- topLevelProgress :: Progress,- topLevelMediaId :: Text- } deriving (Show,Eq,GHC.Generics.Generic)---instance FromJSON TopLevel where- parseJSON (Object v) = TopLevel <$> v .: "status" <*> v .: "progress" <*> v .: "mediaId"- parseJSON _ = mzero---instance ToJSON TopLevel where- toJSON (TopLevel {..}) = object ["status" .= topLevelStatus, "progress" .= topLevelProgress, "mediaId" .= topLevelMediaId]- toEncoding (TopLevel {..}) = pairs ("status" .= topLevelStatus<>"progress" .= topLevelProgress<>"mediaId" .= topLevelMediaId)---parse :: ByteString -> Either String TopLevel-parse = eitherDecode
− src/Json/SubmitMediaTypes.hs
@@ -1,96 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeOperators #-}---- | Auto generated module by json-autotype-module Json.SubmitMediaTypes where--import Control.Applicative-import Control.Monad (forM_, join, mzero)-import Data.Aeson (FromJSON (..), ToJSON (..),- Value (..), eitherDecode,- object, pairs, (.:), (.:?),- (.=))-import Data.Aeson.AutoType.Alternative-import Data.ByteString.Lazy-import qualified Data.ByteString.Lazy.Char8 as BSL-import Data.Monoid-import Data.Text (Text)-import qualified GHC.Generics-import System.Environment (getArgs)-import System.Exit (exitFailure, exitSuccess)-import System.IO (hPutStrLn, stderr)---- | Workaround for https://github.com/bos/aeson/issues/287.-o .:?? val = fmap join (o .:? val)---data Self = Self {- selfHref :: Text- } deriving (Show,Eq,GHC.Generics.Generic)---instance FromJSON Self where- parseJSON (Object v) = Self <$> v .: "href"- parseJSON _ = mzero---instance ToJSON Self where- toJSON (Self {..}) = object ["href" .= selfHref]- toEncoding (Self {..}) = pairs ("href" .= selfHref)---data Links = Links {- linksSelf :: Self- } deriving (Show,Eq,GHC.Generics.Generic)---instance FromJSON Links where- parseJSON (Object v) = Links <$> v .: "self"- parseJSON _ = mzero---instance ToJSON Links where- toJSON (Links {..}) = object ["self" .= linksSelf]- toEncoding (Links {..}) = pairs ("self" .= linksSelf)---data Metadata = Metadata {-- } deriving (Show,Eq,GHC.Generics.Generic)---instance FromJSON Metadata where- parseJSON (Object v) = return Metadata- parseJSON _ = mzero---instance ToJSON Metadata where- toJSON (Metadata {}) = object []----data TopLevel = TopLevel {- topLevelStatus :: Text,- topLevelMediaId :: Text,- topLevelLinks :: Links,- topLevelMetadata :: Metadata- } deriving (Show,Eq,GHC.Generics.Generic)---instance FromJSON TopLevel where- parseJSON (Object v) = TopLevel <$> v .: "status" <*> v .: "mediaId" <*> v .: "_links" <*> v .: "metadata"- parseJSON _ = mzero---instance ToJSON TopLevel where- toJSON (TopLevel {..}) = object ["status" .= topLevelStatus, "mediaId" .= topLevelMediaId, "_links" .= topLevelLinks, "metadata" .= topLevelMetadata]- toEncoding (TopLevel {..}) = pairs ("status" .= topLevelStatus<>"mediaId" .= topLevelMediaId<>"_links" .= topLevelLinks<>"metadata" .= topLevelMetadata)----parse :: ByteString -> Either String TopLevel-parse = eitherDecode
− src/Json/TranscriptTypes.hs
@@ -1,235 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeOperators #-}---- | Auto generated module by json-autotype-module Json.TranscriptTypes where--import Control.Applicative-import Control.Monad (forM_, join, mzero)-import Data.Aeson (FromJSON (..), ToJSON (..),- Value (..), eitherDecode,- object, pairs, (.:), (.:?),- (.=))-import Data.Aeson.AutoType.Alternative-import Data.ByteString.Lazy-import qualified Data.ByteString.Lazy.Char8 as BSL-import Data.Monoid-import Data.Text (Text)-import qualified GHC.Generics-import System.Environment (getArgs)-import System.Exit (exitFailure, exitSuccess)-import System.IO (hPutStrLn, stderr)---- | Workaround for https://github.com/bos/aeson/issues/287.-o .:?? val = fmap join (o .:? val)--data LatestTopics = LatestTopics {- latestTopicsTopics :: [(Maybe Value)],- latestTopicsRevision :: Text- } deriving (Show,Eq,GHC.Generics.Generic)---instance FromJSON LatestTopics where- parseJSON (Object v) = LatestTopics <$> v .: "topics" <*> v .: "revision"- parseJSON _ = mzero---data Topics = Topics {- topicsLatestTopics :: LatestTopics- } deriving (Show,Eq,GHC.Generics.Generic)---instance FromJSON Topics where- parseJSON (Object v) = Topics <$> v .: "latest"- parseJSON _ = mzero---data Tasks = Tasks {-} deriving (Show,Eq,GHC.Generics.Generic)---instance FromJSON Tasks where- parseJSON (Object v) = return Tasks- parseJSON _ = mzero--data Progress = Progress {- progressStatus :: Text,- progressJobId :: Text,- progressTasks :: Tasks- } deriving (Show,Eq,GHC.Generics.Generic)---instance FromJSON Progress where- parseJSON (Object v) = Progress <$> v .: "status" <*> v .: "jobId" <*> v .: "tasks"- parseJSON _ = mzero---data Job = Job {- jobProgress :: Progress- } deriving (Show,Eq,GHC.Generics.Generic)---instance FromJSON Job where- parseJSON (Object v) = Job <$> v .: "progress"- parseJSON _ = mzero---data T = T {- tUnknown :: [Text]- } deriving (Show,Eq,GHC.Generics.Generic)---instance FromJSON T where- parseJSON (Object v) = T <$> v .: "unknown"- parseJSON _ = mzero---data WordsKeyElt = WordsKeyElt {- wordsKeyEltRelevance :: Text,- wordsKeyEltT :: T,- wordsKeyEltName :: Text- } deriving (Show,Eq,GHC.Generics.Generic)---instance FromJSON WordsKeyElt where- parseJSON (Object v) = WordsKeyElt <$> v .: "relevance" <*> v .: "t" <*> v .: "name"- parseJSON _ = mzero---data LatestKeywords = LatestKeywords {- latestKeywordsGroups :: [(Maybe Value)],- latestKeywordsWordsKey :: [WordsKeyElt],- latestKeywordsRevision :: Text- } deriving (Show,Eq,GHC.Generics.Generic)---instance FromJSON LatestKeywords where- parseJSON (Object v) = LatestKeywords <$> v .: "groups" <*> v .: "words" <*> v .: "revision"- parseJSON _ = mzero---data Keywords = Keywords {- keywordsLatestKeywords :: LatestKeywords- } deriving (Show,Eq,GHC.Generics.Generic)---instance FromJSON Keywords where- parseJSON (Object v) = Keywords <$> v .: "latest"- parseJSON _ = mzero---data Length = Length {- lengthDescriptive :: Text,- lengthMilliseconds :: Double- } deriving (Show,Eq,GHC.Generics.Generic)---instance FromJSON Length where- parseJSON (Object v) = Length <$> v .: "descriptive" <*> v .: "milliseconds"- parseJSON _ = mzero---data Metadata = Metadata {- metadataLength :: Length,- metadataContentType :: Text- } deriving (Show,Eq,GHC.Generics.Generic)---instance FromJSON Metadata where- parseJSON (Object v) = Metadata <$> v .: "length" <*> v .: "contentType"- parseJSON _ = mzero---data WordsTranscriptsElt = WordsTranscriptsElt {- wordsTranscriptsEltW :: Text,- wordsTranscriptsEltM :: (Maybe (Text:|:[(Maybe Value)])),- wordsTranscriptsEltP :: Double,- wordsTranscriptsEltE :: Double,- wordsTranscriptsEltC :: Double,- wordsTranscriptsEltS :: Double- } deriving (Show,Eq,GHC.Generics.Generic)---instance FromJSON WordsTranscriptsElt where- parseJSON (Object v) = WordsTranscriptsElt <$> v .: "w" <*> v .:?? "m" <*> v .: "p" <*> v .: "e" <*> v .: "c" <*> v .: "s"- parseJSON _ = mzero---data LatestTranscripts = LatestTranscripts {- latestTranscriptsEngine :: Text,- latestTranscriptsConfidence :: Double,- latestTranscriptsName :: Text,- latestTranscriptsWordsTranscripts :: [WordsTranscriptsElt],- latestTranscriptsRevision :: Text- } deriving (Show,Eq,GHC.Generics.Generic)---instance FromJSON LatestTranscripts where- parseJSON (Object v) = LatestTranscripts <$> v .: "engine" <*> v .: "confidence" <*> v .: "name" <*> v .: "words" <*> v .: "revision"- parseJSON _ = mzero---data Transcripts = Transcripts {- transcriptsLatestTranscripts :: LatestTranscripts- } deriving (Show,Eq,GHC.Generics.Generic)---instance FromJSON Transcripts where- parseJSON (Object v) = Transcripts <$> v .: "latest"- parseJSON _ = mzero---data Media = Media {- mediaStatus :: Text,- mediaTopics :: Topics,- mediaMediaId :: Text,- mediaDateCreated :: Text,- mediaJob :: Job,- mediaKeywords :: Keywords,- mediaMetadata :: Metadata,- mediaTranscripts :: Transcripts,- mediaDateFinished :: Text- } deriving (Show,Eq,GHC.Generics.Generic)---instance FromJSON Media where- parseJSON (Object v) = Media <$> v .: "status" <*> v .: "topics" <*> v .: "mediaId" <*> v .: "dateCreated" <*> v .: "job" <*> v .: "keywords" <*> v .: "metadata" <*> v .: "transcripts" <*> v .: "dateFinished"- parseJSON _ = mzero---data Self = Self {- selfHref :: Text- } deriving (Show,Eq,GHC.Generics.Generic)---instance FromJSON Self where- parseJSON (Object v) = Self <$> v .: "href"- parseJSON _ = mzero---data Links = Links {- linksSelf :: Self- } deriving (Show,Eq,GHC.Generics.Generic)---instance FromJSON Links where- parseJSON (Object v) = Links <$> v .: "self"- parseJSON _ = mzero---data Transcript = Transcript {- topLevelMedia :: Media,- topLevelLinks :: Links- } deriving (Show,Eq,GHC.Generics.Generic)---instance FromJSON Transcript where- parseJSON (Object v) = Transcript <$> v .: "media" <*> v .: "_links"- parseJSON _ = mzero--parse :: ByteString -> Either String Transcript-parse = eitherDecode
+ src/Main.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Main where++import Data.Aeson (encode)+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Lazy.Char8 as C8LBS+import Data.Monoid ((<>))+import qualified Data.Text as Text+import Network.Mime (defaultMimeLookup)+import Options.Applicative+import System.FilePath (splitFileName)+import Voicebase.V2Beta.Client++data Options = Options {+ token :: BearerToken,+ file :: FilePath+}+++sample :: Parser Options+sample = Options+ <$> strOption+ ( long "bearer-token"+ <> metavar "TOKEN"+ <> help "The bearer token obtained from voicebase" )+ <*> strOption+ ( long "file"+ <> metavar "PATH"+ <> help "The file to be posted" )++main :: IO ()+main = do+ Options{..} <- execParser opts+ bytes <- LBS.readFile file+ let mime = defaultMimeLookup $ Text.pack file+ ts <- runVB (withRedaction . defaultConfig token) $+ transcribeAndFetchMedia $ Bytes bytes "audio/wav" file+ print ts+ where+ opts = info (sample <**> helper)+ ( fullDesc+ <> progDesc "Transcribe a file with voicebase"+ <> header "Voicebase transcriber" )+
− src/VoicebaseClient.hs
@@ -1,185 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}---- | Main module for doing the requests to the voicebase api: http://voicebase.readthedocs.io/en/v2-beta/-module VoicebaseClient- (- transcribe,- transcribeFile,- transcribeBytes,- transcribeParse,- BearerToken,- Error(..),- LazyByteFile(..),- Configuration(..),- Channels(..),- Speaker(..),- Language(..)- ) where--import Control.Applicative-import Control.Lens hiding ((.=))-import Control.Monad--import Data.Bifunctor-import Data.Maybe-import Data.Monoid-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.Types (parseEither)-import Network.HTTP.Client (defaultManagerSettings,- managerResponseTimeout,- responseTimeoutMicro)-import Network.HTTP.Client.OpenSSL-import Network.Mime (MimeType)-import Network.Wreq-import qualified Network.Wreq.Session as Sess-import OpenSSL.Session (context)--import GHC.Generics-import qualified Json.ProgressTypes as Progress-import qualified Json.SubmitMediaTypes as Submit-import qualified Json.TranscriptTypes as Transcript--import System.IO (fixIO)---- | get your bearer token at http://voicebase.readthedocs.io/en/v2-beta/how-to-guides/hello-world.html#token-type BearerToken = String--data Configuration = Configuration {- channels :: Maybe Channels- , language :: Language-} deriving Generic--data Channels = Channels {- left :: Speaker- , right :: Speaker-} deriving Generic--data Speaker = Speaker {- speaker :: Text-} deriving Generic--instance ToJSON Channels-instance ToJSON Speaker--instance ToJSON Configuration where- toJSON Configuration{..} = let- ingest c = [- "ingest" .= object [- "channels" .= c- ]- ]- in object [- "configuration" .= (object . concat) [- ["language" .= language]- , maybe [] ingest channels- ]- ]---- https://voicebase.readthedocs.io/en/v2-beta/how-to-guides/languages.html-data Language =- Dutch | EnglishUS | EnglishUK | EnglishAus | French | German | Italian | Portuguese | SpanishLatinAmerican | SpanishSpain--instance ToJSON Language where- toJSON Dutch = "nl-NL"- toJSON EnglishUS = "en-US"- toJSON EnglishUK = "en-UK"- toJSON EnglishAus = "en-AU"- toJSON French = "fr-FR"- toJSON German = "de-DE"- toJSON Italian = "it-IT"- toJSON Portuguese = "pt-BR"- toJSON SpanishLatinAmerican = "es-LA"- toJSON SpanishSpain = "es-ES"--data Error = UnkownResponse | ParseError String- deriving(Show)--url :: String-url = "https://apis.voicebase.com/v2-beta/media"--timeout = responseTimeoutMicro 10000--makeOpts :: BearerToken -> Options-makeOpts token = withAuthorization token defaults--withAuthorization :: BearerToken -> Options -> Options-withAuthorization token options = options & manager .~ Left (opensslManagerSettings context)- & manager .~ Left (defaultManagerSettings { managerResponseTimeout = timeout} )- & header "Authorization" .~ [(BS.pack ("Bearer " ++ token))]---- | transcribes the audio file and puts it into a Transcript-transcribeParse :: Configuration -> BearerToken -> FilePath -> IO(Either Error Transcript.Transcript)-transcribeParse config token filepath = fmap (join . second (first ParseError . parseEither parseJSON)) (transcribeFile config token filepath)--inputName = "media"--- | Given a bearer token, and a filepath to an audio file, this function will--- | eventually return a transcript or times out after 10 seconds--- | Throws HttpExceptionRequest, IOException (file not found)-transcribeFile :: Configuration -> BearerToken -> FilePath -> IO(Either Error Value)-transcribeFile config bearerToken filePath = transcribe bearerToken defaults- [- partFileSource inputName filePath,- partLBS "configuration" $ encode $ config- ]---- | In case of a bytestring, we also need to mimetype to decode the send string-data LazyByteFile = LazyByteFile {- content :: LBS.ByteString,- mimetype :: MimeType -- to get this Jappie used defaultMimeLookup "f.mp3"- }--- | Transcribe a bytestring--- | Throws HttpExceptionRequest-transcribeBytes :: Configuration -> BearerToken -> LazyByteFile -> IO(Either Error Value)-transcribeBytes config bearerToken (LazyByteFile content mimetype) =- transcribe bearerToken defaults- [partLBS inputName content &- partContentType ?~ mimetype &- partFileName ?~ "",- partLBS "configuration" $ encode $ config- ]---- | Generic transcribe, agnostic of options, will add ssl,--- | the bearer token and a timeout to the options.--- | Throws HttpExceptionRequest-transcribe :: BearerToken -> Options -> [Part] -> IO(Either Error Value)-transcribe token options parts = do- session <- Sess.newSession- response <- Sess.postWith (withAuthorization token options) session url parts- case Submit.parse (response ^. responseBody) of- Left error -> return $ Left $ ParseError error- Right parsed -> do- -- wait for the service to complete- waitResult <- pollStatus token session (Submit.topLevelMediaId parsed)- case waitResult of- Right _ -> first ParseError . eitherDecode <$> (requestTranscript token session (Submit.topLevelMediaId parsed))- Left error -> return $ Left $ error---pollStatus :: BearerToken -> Sess.Session -> Text -> IO(Either Error ())-pollStatus token session mediaId = pollStatus' token session mediaId "pending"--pollStatus' :: BearerToken -> Sess.Session -> Text -> Text -> IO (Either Error ())-pollStatus' token session mediaId "pending" = do- response <- Sess.getWith (makeOpts token) session (url <> "/" <> (unpack mediaId) <> "/progress")- case Progress.parse (response ^. responseBody) of- Left error -> return $ Left $ ParseError error- Right parsed -> pollStatus' token session mediaId ((Progress.progressStatus . Progress.topLevelProgress) $ parsed)-pollStatus' token session mediaId "started" = pollStatus' token session mediaId "pending"-pollStatus' token session mediaId "completed" = return $ Right ()-pollStatus' _ _ _ _ = return $ Left UnkownResponse--requestTranscript :: BearerToken -> Sess.Session -> Text -> IO (C8LBS.ByteString)-requestTranscript token session mediaId = do- response <- Sess.getWith (makeOpts token) session (url <> "/" <> (unpack mediaId))- return $ response ^. responseBody
+ test/ConfigJSONSpec.hs view
@@ -0,0 +1,86 @@+--+-- Copyright © 2018 Daisee Pty Ltd - All Rights Reserved+--++{-# LANGUAGE CPP #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}++module ConfigJSONSpec(spec) where++import Data.Aeson+import Data.Aeson.Roundtrip+import Data.Traversable+import Test.Hspec+import Voicebase.V2Beta.Client+#if MIN_VERSION_base(4,8,0)+import Data.Foldable+import Data.Monoid+#endif++expectedDefault = Object []++configPCI =+ Configuration {+ _channels = Just ChannelSpeakers {+ _left = Speaker "Agent"+ , _right = Speaker "Caller"+ }+ , _language = EnglishAus+ , _detections = [RedactingPCI]+ }+expectedPCI = Object+ [ ( "configuration"+ , Object+ ( [ ( "detections"+ , Array+ [ Object+ ( [ ( "redact"+ , Object+ ( [ ("transcripts", String "[redacted]")+ , ( "audio"+ , Object+ ([("tone", Number 270.0), ("gain", Number 0.5)])+ )+ ]+ )+ )+ , ("model", String "PCI")+ ]+ )+ ]+ )+ , ( "ingest"+ , Object+ ( [ ( "channels"+ , Object+ ( [ ("left" , Object ([("speaker", String "Agent")]))+ , ("right", Object ([("speaker", String "Caller")]))+ ]+ )+ )+ ]+ )+ )+ , ("language", String "en-AU")+ ]+ )+ )+ ]++data ConfigSpec = ConfigSpec {+ label :: String+ , config :: Configuration+ , expectation :: Value+}++specs :: [ConfigSpec]+specs = [ ConfigSpec "PCI redaction" configPCI expectedPCI ]++spec :: Spec+spec =+ describe "JSON marshalling" $+ for_ specs $ \s@ConfigSpec{label, config, expectation} ->+ it ("meets spec for " <> label) $+ runBuilder syntax config `shouldBe` Right expectation
test/Spec.hs view
@@ -1,2 +1,1 @@-main :: IO ()-main = putStrLn "Test suite not yet implemented"+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
voicebase.cabal view
@@ -1,11 +1,11 @@--- This file has been generated from package.yaml by hpack version 0.28.2.+-- This file has been generated from package.yaml by hpack version 0.21.2. -- -- see: https://github.com/sol/hpack ----- hash: 931f389a517b1d56a5962d455ff38b27b298901c62861c779be02806b956bb53+-- hash: 4c84adf704c5787aa8f8076d2468fe226afaac6c70f75ae0e5e263e9f80727aa name: voicebase-version: 0.1.1.4+version: 0.2.0.0 synopsis: Upload audio files to voicebase to get a transcription description: voicebase bindings for <http://voicebase.readthedocs.io/en/v2-beta/> category: API@@ -17,20 +17,19 @@ license-file: LICENSE build-type: Simple cabal-version: >= 1.10+ extra-source-files: ChangeLog.md README.md library exposed-modules:- Json.ProgressTypes- Json.SubmitMediaTypes- Json.TranscriptTypes- VoicebaseClient+ Voicebase.V2Beta.Client+ Voicebase.V2Beta.Configuration other-modules: Paths_voicebase hs-source-dirs:- src+ lib build-depends: HsOpenSSL , aeson@@ -38,9 +37,12 @@ , bytestring , http-client , http-client-openssl- , json-autotype , lens+ , lens-aeson , mime-types+ , mtl+ , roundtrip+ , roundtrip-aeson , text , wreq default-language: Haskell2010@@ -50,7 +52,7 @@ other-modules: Paths_voicebase hs-source-dirs:- app+ src ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: aeson@@ -67,6 +69,7 @@ type: exitcode-stdio-1.0 main-is: Spec.hs other-modules:+ ConfigJSONSpec Paths_voicebase hs-source-dirs: test@@ -74,5 +77,7 @@ build-depends: aeson , base >=4.7 && <5+ , hspec+ , roundtrip-aeson , voicebase default-language: Haskell2010