diff --git a/ChangeLog.md b/ChangeLog.md
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -1,3 +1,8 @@
# Changelog for voicebase
+0.2.0.0 - Nov 1 2018
+
+* Backwards incompatible rewrite
+* PCI redaction supported
+
## Unreleased changes
diff --git a/Setup.hs b/Setup.hs
--- a/Setup.hs
+++ b/Setup.hs
@@ -1,2 +1,2 @@
-import Distribution.Simple
+import Distribution.Simple
main = defaultMain
diff --git a/app/Main.hs b/app/Main.hs
deleted file mode 100644
--- a/app/Main.hs
+++ /dev/null
@@ -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
diff --git a/lib/Voicebase/V2Beta/Client.hs b/lib/Voicebase/V2Beta/Client.hs
new file mode 100644
--- /dev/null
+++ b/lib/Voicebase/V2Beta/Client.hs
@@ -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
+-- >
+-- >
+--
+--
+
+{-# 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
diff --git a/lib/Voicebase/V2Beta/Configuration.hs b/lib/Voicebase/V2Beta/Configuration.hs
new file mode 100644
--- /dev/null
+++ b/lib/Voicebase/V2Beta/Configuration.hs
@@ -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
diff --git a/src/Json/ProgressTypes.hs b/src/Json/ProgressTypes.hs
deleted file mode 100644
--- a/src/Json/ProgressTypes.hs
+++ /dev/null
@@ -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
diff --git a/src/Json/SubmitMediaTypes.hs b/src/Json/SubmitMediaTypes.hs
deleted file mode 100644
--- a/src/Json/SubmitMediaTypes.hs
+++ /dev/null
@@ -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
diff --git a/src/Json/TranscriptTypes.hs b/src/Json/TranscriptTypes.hs
deleted file mode 100644
--- a/src/Json/TranscriptTypes.hs
+++ /dev/null
@@ -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
diff --git a/src/Main.hs b/src/Main.hs
new file mode 100644
--- /dev/null
+++ b/src/Main.hs
@@ -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" )
+
diff --git a/src/VoicebaseClient.hs b/src/VoicebaseClient.hs
deleted file mode 100644
--- a/src/VoicebaseClient.hs
+++ /dev/null
@@ -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
diff --git a/test/ConfigJSONSpec.hs b/test/ConfigJSONSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/ConfigJSONSpec.hs
@@ -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
diff --git a/test/Spec.hs b/test/Spec.hs
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -1,2 +1,1 @@
-main :: IO ()
-main = putStrLn "Test suite not yet implemented"
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
diff --git a/voicebase.cabal b/voicebase.cabal
--- a/voicebase.cabal
+++ b/voicebase.cabal
@@ -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
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