opentok (empty) → 0.0.1
raw patch · 10 files changed
+815/−0 lines, 10 filesdep +SHAdep +aesondep +aeson-casingsetup-changed
Dependencies added: SHA, aeson, aeson-casing, aeson-compat, base, base-compat, base64-string, bytestring, containers, convertible, either, hscolour, http-client, http-client-tls, http-conduit, http-types, iproute, jose, lens, monad-time, strings, text, time, transformers, unordered-containers, utf8-string, uuid
Files
- LICENSE +21/−0
- Setup.hs +2/−0
- opentok.cabal +56/−0
- src/OpenTok.hs +75/−0
- src/OpenTok/Archive.hs +205/−0
- src/OpenTok/Client.hs +166/−0
- src/OpenTok/Session.hs +112/−0
- src/OpenTok/Token.hs +126/−0
- src/OpenTok/Types.hs +22/−0
- src/OpenTok/Util.hs +30/−0
+ LICENSE view
@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) 2018 Aaron Rice++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ opentok.cabal view
@@ -0,0 +1,56 @@+name: opentok+version: 0.0.1+synopsis: An OpenTok SDK for Haskell+description:+ .+ Session creation, token generation, and archive management for the OpenTok platform.+category: Web+build-type: Simple+cabal-version: 1.18+author: Aaron Rice+maintainer: adrice727@gmail.com+homepage: https://github.com/adrice727/opentok-haskell+bug-reports: https://github.com/adrice727/opentok-haskell/issues+license: MIT+license-file: LICENSE+copyright: 2018 Aaron Rice++library+ default-language: Haskell2010+ exposed-modules: OpenTok, OpenTok.Session, OpenTok.Token, OpenTok.Archive, OpenTok.Types+ other-modules: OpenTok.Client, OpenTok.Util+ hs-source-dirs: src+ build-depends:+ base >=4.7 && <5+ , base-compat >= 0.9.0+ , aeson >= 1.1.2.0+ , aeson-casing >= 0.1.0.5+ , aeson-compat >= 0.3.4.0+ , base64-string >= 0.2+ , bytestring >= 0.10.0.0+ , containers >= 0.5.7.1+ , convertible >= 1.0.10.0+ , either >= 4.0+ , http-client >= 0.5.0+ , http-client-tls >= 0.3.0+ , http-conduit > 2.0.0+ , http-types >= 0.6.0+ , iproute >= 1.4.0+ , jose >= 0.6.0.0+ , lens >= 4.10+ , monad-time >= 0.2.0.0+ , unordered-containers >= 0.2.0+ , SHA >= 1.6.4.2+ , strings >= 1.1+ , uuid >= 1.3.13+ , utf8-string >=1.0.1.1+ , text >= 1.0.0.0+ , time >=1.4.0.1 && <1.9+ , transformers >= 0.5.2.0+ if flag(documentation)+ build-depends: hscolour == 1.20.*++flag documentation+ default: True++
+ src/OpenTok.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE OverloadedStrings #-}++module OpenTok+ ( OpenTok(apiKey, secret)+ , opentok+ , createSession+ , generateToken+ , startArchive+ , stopArchive+ )+where++import Prelude ( )+import Prelude.Compat+import Data.Semigroup ( (<>) )++import OpenTok.Archive+import OpenTok.Session+import OpenTok.Token+import OpenTok.Client+import OpenTok.Types++-- | Represents an OpenTok project.+--+-- Get your project key and secret from https://tokbox.com/account/+data OpenTok = OpenTok {+ apiKey :: APIKey,+ secret :: APISecret,+ client :: Client+}++instance Show OpenTok where+ show ot = "OpenTok { APIKey: " <> apiKey ot <> ", Secret: *_*_*_*_*_* }"++-- | Get an OpenTok project+--+-- > ot = opentok "my_api_key" "my_api_secret"+--+opentok :: APIKey -> APISecret -> OpenTok+opentok k s = OpenTok k s (OpenTok.Client.Client k s)++-- | Generate a new OpenTok Session+--+-- @+-- options = sessionOpts { mediaMode = Routed }+-- session <- createSession ot sessionOpts+-- @+--+createSession :: OpenTok -> SessionOptions -> IO (Either OTError Session)+createSession ot = OpenTok.Session.create (client ot)++-- | Generate a token.+--+-- @+-- let options = tokenOpts { connectionData = "name:tim" }+-- token <- generateToken ot options+-- @+--+generateToken :: OpenTok -> SessionId -> TokenOptions -> IO (Either OTError Token)+generateToken ot = OpenTok.Token.generate (apiKey ot) (secret ot)++-- | Start recording an archive of an OpenTok session+--+-- > startArchive ot archiveOpts { sessionId = "your_session_id" }+--+startArchive :: OpenTok -> ArchiveOptions -> IO (Either OTError Archive)+startArchive ot = OpenTok.Archive.start (client ot)+++-- | Stop recording an archive of an OpenTok session+--+-- > stopArchive ot archiveOpts { sessionId = "your_session_id" }+--+stopArchive :: OpenTok -> ArchiveId -> IO (Either OTError Archive)+stopArchive ot = OpenTok.Archive.stop (client ot)
+ src/OpenTok/Archive.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TemplateHaskell #-}++module OpenTok.Archive+ ( ArchiveOptions+ ( _hasAudio+ , _hasAudio+ , _name+ , _outputMode+ , _resolution+ , _sessionId+ )+ , ArchiveResolution(SD, HD)+ , Archive+ ( id+ , status+ , createdAt+ , size+ , partnerId+ , url+ , resolution+ , outputMode+ , hasAudio+ , hasVideo+ , reason+ , name+ , updatedAt+ , duration+ , sessionId+ )+ , OutputMode(Composed, Individual)+ , archiveOpts+ , start+ , stop+ )+where++import Prelude ( )+import Prelude.Compat+import Data.Aeson+import Data.Aeson.Types+import Data.Aeson.TH+import Data.Data+import Data.Semigroup ( (<>) )+import Data.Strings ( strToLower )+import GHC.Generics++import OpenTok.Client+import OpenTok.Types++-- | Composed means that streams will be composed into a single file+--+-- Individual means that an individual file will be created for each stream+--+data OutputMode = Composed | Individual deriving (Data, Generic, Typeable)++instance Show OutputMode where+ show = strToLower . showConstr . toConstr++deriveJSON defaultOptions { constructorTagModifier = strToLower } ''OutputMode++-- | SD (Standard Definition 640 x 480)+--+-- HD (High Definition 1280 x 720)+--+data ArchiveResolution = SD | HD++instance Show ArchiveResolution where+ show SD = "640x480 (SD)"+ show HD = "1280x720 (HD)"++instance ToJSON ArchiveResolution where+ toJSON SD = String "640x480"+ toJSON HD = String "1280x720"++instance FromJSON ArchiveResolution where+ parseJSON (String s) = case s of+ "640x480" -> pure SD+ "1280x720" -> pure HD+ _ -> typeMismatch "Could not parse ArchiveResolution" (String s)+ parseJSON x = typeMismatch "Expected String" x++-- | Defines options for an Archive+--+-- sessionId: The session to be archived+--+-- hasAudio: Whether the archive will record audio+--+-- hasVideo: Whether the archive will record video+--+-- name: The name of the archive+--+-- Whether all streams in the archive are recorded to a+-- single file ('Composed') or to individual files ('Individual')+--+-- The resolution of the archive, either 'SD' (the default, 640 x 480),+-- or 'HD' (1280 x 720)+--+data ArchiveOptions = ArchiveOptions {+ _hasAudio :: Bool,+ _hasVideo :: Bool,+ _name :: Maybe String,+ _outputMode :: OutputMode,+ _resolution :: ArchiveResolution,+ _sessionId :: SessionId+} deriving (Generic, Show)++instance ToJSON ArchiveOptions where+ toJSON = genericToJSON defaultOptions { omitNothingFields = True, fieldLabelModifier = drop 1 }++{-|+Default Archive options++@+ArchiveOptions+ { _hasVideo = 'True'+ , _name = 'Nothing'+ , _outputMode = 'Composed'+ , _resolution = 'SD'+ , _sessionId = ""+}+@++-}+archiveOpts :: ArchiveOptions+archiveOpts = ArchiveOptions+ { _hasAudio = True+ , _hasVideo = True+ , _name = Nothing+ , _outputMode = Composed+ , _resolution = SD+ , _sessionId = ""+ }++-- | Status of an OpenTok `Archive`+data ArchiveStatus = Available | Expired | Failed | Paused | Started | Stopped | Uploaded deriving (Data, Generic, Typeable)+deriveJSON defaultOptions { constructorTagModifier = strToLower } ''ArchiveStatus+++{-|++An OpenTok Archive++@+Archive {+ id :: 'String',+ status :: 'String',+ createdAt :: 'Integer',+ size :: 'Float',+ partnerId :: 'Int',+ url :: Maybe 'String',+ resolution :: 'ArchiveResolution',+ outputMode :: 'OutputMode',+ hasAudio :: 'Bool',+ hasVideo :: 'Bool',+ reason :: 'String',+ name :: 'String',+ updatedAt :: 'Integer',+ duration :: 'Float',+ sessionId :: 'String'+}+@++-}+data Archive = Archive {+ id :: String,+ status :: String,+ createdAt :: Integer,+ size :: Float,+ partnerId :: Int,+ url :: Maybe String,+ resolution :: ArchiveResolution,+ outputMode :: OutputMode,+ hasAudio :: Bool,+ hasVideo :: Bool,+ reason :: String,+ name :: String,+ updatedAt :: Integer,+ duration :: Float,+ sessionId :: String+} deriving (Show, Generic)++instance FromJSON Archive where+ parseJSON = genericParseJSON defaultOptions++-- [("event",String "archive"),("status",String "started"),("createdAt",Number 1.534898598419e12),("size",Number 0.0),("partnerId",Number 4.5759482e7),("url",Null),("resolution",String "640x480"),("outputMode",String "composed"),("hasAudio",Bool True),("reason",String ""),("name",Null),("password",String ""),("id",String "e4efbf78-244f-47e7-ae89-640988cac725"),("updatedAt",Number 1.53489859849e12),("sha256sum",String ""),("projectId",Number 4.5759482e7),("sessionId",String "2_MX40NTc1OTQ4Mn5-MTUzNDg5NzQ0MDgwMX44QjZFVFQ4VkhWL05YYUpvRUtlNGFUQkh-fg"),("hasVideo",Bool True),("duration",Number 0.0)]++start :: Client -> ArchiveOptions -> IO (Either OTError Archive)+start c opts = do+ let path = "/v2/project/" <> _apiKey c <> "/archive"+ response <- postWithBody c path (Just opts) :: IO (Either ClientError Archive)+ case response of+ Right archive -> pure $ Right archive+ Left e -> pure $ Left $ "Failed to start archive: " <> message e++stop :: Client -> ArchiveId -> IO (Either OTError Archive)+stop c aId = do+ let path = "/v2/project/" <> _apiKey c <> "/archive/" <> aId <> "/stop"+ response <- post c path :: IO (Either ClientError Archive)+ case response of+ Right archive -> pure $ Right archive+ Left e -> pure $ Left $ "An error occurred in attempting to stop an archive: " <> message e
+ src/OpenTok/Client.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE ConstrainedClassMethods #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DuplicateRecordFields #-}++module OpenTok.Client+ ( Client(Client, _apiKey, _secret)+ , ClientError(statusCode, message)+ , Path+ , emptyOptions+ , post+ , postWithBody+ )+where++import Prelude ( )+import Prelude.Compat+import Control.Arrow ( left )+import Control.Lens.Combinators+import Control.Lens.Operators+-- import Control.Monad.Trans.Either ( eitherT )+import Control.Monad.Time+import Control.Monad.Trans.Except+import Crypto.JWT+import Data.Either.Combinators ( mapLeft )+import Data.List ( isInfixOf )+import Data.Semigroup ( (<>) )+import Data.UUID ( toText )+import Data.UUID.V4+import Data.Aeson ( decode+ , encode+ , eitherDecode+ , FromJSON+ , ToJSON+ )+import Data.Aeson.Types+import qualified Data.ByteString.Char8 as C8+ ( pack )+import Data.ByteString.Lazy ( toStrict )+import Data.HashMap.Strict as HM+import Data.Time.Clock+import GHC.Generics ( Generic )+import Network.HTTP.Client hiding ( responseStatus )+import Network.HTTP.Client.TLS ( tlsManagerSettings )+import Network.HTTP.Simple ( getResponseStatusCode )+import Network.HTTP.Types.Header ( RequestHeaders )++import OpenTok.Util++type Path = String++data APIError = APIError {+ _code :: Int,+ _status :: Maybe String,+ _message :: String+} deriving (Generic, Show)++instance FromJSON APIError where+ parseJSON = genericParseJSON $ defaultOptions { omitNothingFields = True, fieldLabelModifier = drop 1 }++data ClientError = ClientError {+ statusCode :: Int,+ message :: String+} deriving (Generic, Show)++jwtError :: ClientError+jwtError = ClientError 0 "Failed to create JWT"++decodeError :: Int -> ClientError+decodeError sc = ClientError sc "Failed to decode API response"++expireTime :: UTCTime -> UTCTime+expireTime t = epochToUTC $ utcToEpoch t + 60++data Client = Client {+ _apiKey :: String,+ _secret :: String+}++-- | Create claims for a JWT+mkClaims :: String -> IO ClaimsSet+mkClaims projectKey = do+ now <- currentTime+ uuid <- nextRandom+ let now' = epochToUTC $ utcToEpoch now+ let later = expireTime now+ pure+ $ emptyClaimsSet+ & claimIss .~ preview stringOrUri (projectKey :: String)+ & claimIat ?~ NumericDate now'+ & claimExp ?~ NumericDate later+ & claimJti ?~ toText uuid+ & unregisteredClaims %~ HM.insert "ist" "project"++-- | Sign JWT claims+signJWT :: JWK -> ClaimsSet -> IO (Either JWTError SignedJWT)+signJWT key claims =+ runExceptT $ signClaims key (newJWSHeader ((), HS256)) claims++data EmptyOptions = EmptyOptions deriving (Generic)+instance ToJSON EmptyOptions++-- | A dummy type used when not passing any options to request+emptyOptions :: Maybe EmptyOptions+emptyOptions = Nothing++createJWT :: Client -> IO (Either ClientError SignedJWT)+createJWT client = do+ claims <- mkClaims (_apiKey client)+ let key = fromOctets (C8.pack $ _secret client)+ eitherSigned <- signJWT key claims+ pure $ mapLeft (const jwtError) eitherSigned++-- | Build headers for a Request+buildHeaders :: SignedJWT -> RequestHeaders+buildHeaders jwt =+ [+ ( "Content-Type", "application/json")+ , ("Accept" , "application/json")+ , ("X-OPENTOK-AUTH", toStrict $ encodeCompact jwt)+ ]++-- | Build headers for a Request to an API v1 endpoint (without Content-Type)+buildV1Headers :: SignedJWT -> RequestHeaders+buildV1Headers jwt = drop 1 $ buildHeaders jwt+++-- | Execute an API request+execute :: (FromJSON a) => Request -> IO (Either ClientError a)+execute req = do+ manager <- newManager tlsManagerSettings+ response <- httpLbs req manager+ let body = responseBody response+ let sc = getResponseStatusCode response+ case sc of+ 200 -> pure $ left (\_ -> decodeError sc) (eitherDecode body)+ _ -> pure $ Left $ maybe (decodeError sc)+ (ClientError sc . _message)+ (decode body :: Maybe APIError)++buildRequest :: Path -> SignedJWT -> IO Request+buildRequest p jwt = do+ initialRequest <- parseRequest $ "https://api.opentok.com" <> p+ let buildFn = if "v2" `isInfixOf` p then buildHeaders else buildV1Headers+ pure $ initialRequest { method = "POST", requestHeaders = buildFn jwt }++-- | Make a POST request+post :: (FromJSON a) => Client -> Path -> IO (Either ClientError a)+post client p = do+ eitherJWT <- createJWT client+ case eitherJWT of+ Left e -> pure $ Left e+ Right jwt -> do+ request <- buildRequest p jwt+ execute request++-- | Make a POST request with a body+postWithBody :: (ToJSON a, FromJSON b) => Client -> Path -> a -> IO (Either ClientError b)+postWithBody client p b = do+ eitherJWT <- createJWT client+ case eitherJWT of+ Left e -> pure $ Left $ e+ Right jwt -> do+ request <- buildRequest p jwt+ execute $ request { requestBody = RequestBodyLBS $ encode b }+
+ src/OpenTok/Session.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TemplateHaskell #-}++module OpenTok.Session+ ( Session+ , SessionOptions(_mediaMode, _archiveMode, _location)+ , MediaMode(Relayed, Routed)+ , create+ , sessionOpts+ )+where++import Prelude ( )+import Prelude.Compat+import Data.Aeson+import Data.Aeson.Casing ( snakeCase )+import Data.Aeson.Types+import Data.Aeson.TH+import Data.Data+import Data.Strings ( strToLower )+import GHC.Generics++import OpenTok.Client+import OpenTok.Types++-- | Relayed sessions will attempt to use peer-to-peer (p2p) connections.+--+-- Routed sessions will use the <https://tokbox.com/platform/multi-party OpenTok Media Router>+data MediaMode = Relayed | Routed deriving (Data, Generic, Typeable)++instance Show MediaMode where+ show = strToLower . showConstr . toConstr++deriveJSON defaultOptions { constructorTagModifier = strToLower } ''MediaMode++-- | Manual, as it implies, requires archives to be manually started and stopped.+-- Always means that archives will automatically be created.+data ArchiveMode = Manual | Always deriving (Data, Generic, Typeable)++instance Show ArchiveMode where+ show = strToLower . showConstr . toConstr++deriveJSON defaultOptions { constructorTagModifier = strToLower } ''ArchiveMode++-- | Defines options for an OpenTok Session+--+-- 'MediaMode' specifies how clients in the session will send audio+-- and video streams.+--+-- 'ArchiveMode' specifies how archives will be created.+--+-- An 'IPAddress' may be provided as a location hint which will+-- be when choosing an OpenTok Media Router for the session.+data SessionOptions = SessionOptions {+ _mediaMode :: MediaMode,+ _archiveMode :: ArchiveMode,+ _location :: Maybe IPAddress+} deriving(Show, Generic)+++instance ToJSON SessionOptions where+ toJSON = genericToJSON defaultOptions+ { omitNothingFields = True, fieldLabelModifier = drop 1 }++-- | Default options for Session creation+--+-- mediaMode: 'Relayed'+--+-- archiveMode: 'Manual'+--+-- location: Nothing+--+sessionOpts :: SessionOptions+sessionOpts = SessionOptions Relayed Manual Nothing++-- | Represents an OpenTok Session+data Session = Session {+ apiKey :: String,+ sessionId :: String,+ mediaMode :: MediaMode,+ archiveMode :: ArchiveMode+} deriving (Show)++data SessionProperties = SessionProperties {+ _sessionId :: String,+ _projectId :: String,+ _createDt :: String,+ _mediaServerUrl :: Maybe String+} deriving (Generic, Show)++instance FromJSON SessionProperties where+ parseJSON = genericParseJSON $ defaultOptions { fieldLabelModifier = snakeCase . drop 1 }++-- | Create a session using the session options and the properties+-- returned by the API call.+fromProps :: SessionOptions -> SessionProperties -> Session+fromProps opts props = Session+ { apiKey = _projectId props+ , sessionId = _sessionId props+ , mediaMode = _mediaMode opts+ , archiveMode = _archiveMode opts+ }++-- | Create a new OpenTok Session+create :: Client -> SessionOptions -> IO (Either OTError Session)+create client opts = do+ response <- postWithBody client "/session/create/" (Just opts) :: IO (Either ClientError [SessionProperties])+ case response of+ Right propsArray -> pure $ Right $ (fromProps opts . head) propsArray+ Left e -> pure $ Left $ message e
+ src/OpenTok/Token.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}++module OpenTok.Token where++import Prelude ( )+import Prelude.Compat+import qualified Data.Digest.Pure.SHA as SHA+import qualified Codec.Binary.Base64.String as B64+ ( encode+ , decode+ )+import Control.Lens.Fold+import Control.Lens.Combinators+import Data.Maybe+import qualified Data.ByteString.Char8 as C8+ ( ByteString+ , pack+ , unpack+ )+import qualified Data.ByteString.Lazy.Char8 as L8+ ( pack,+ fromStrict )+import Data.Semigroup ( (<>) )+import Data.Time.Clock+import Data.UUID ( )+import Data.UUID.V4 ( nextRandom )+import qualified Data.Text as T+import GHC.Generics+import Network.HTTP.Types ( renderQuery )+import OpenTok.Util+import OpenTok.Types++-- | Information on user roles can be found at https://tokbox.com/developer/guides/create-token/+data Role = Subscriber | Publisher | Moderator+instance Show Role where+ show Subscriber = "subscriber"+ show Publisher = "publisher"+ show Moderator = "moderator"++data TokenOptions = TokenOptions {+ _role :: Role,+ _expireTime :: Maybe UTCTime,+ _connectionData :: Maybe String,+ _initialLayoutClassList :: Maybe [String]+} deriving (Show, Generic)++-- | Default token options+tokenOpts :: TokenOptions+tokenOpts = TokenOptions+ { _role = Publisher+ , _expireTime = Nothing+ , _connectionData = Nothing+ , _initialLayoutClassList = Nothing+ }++-- | Replace invalid base64 chars+sanitize :: String -> String+sanitize = map+ (\c -> case () of+ _ | c == '-' -> '+'+ | c == '_' -> '\\'+ | otherwise -> c+ )++-- | Extract an API key from a session Id and compare against provided key+validSessionId :: SessionId -> APIKey -> Bool+validSessionId sessionId key =+ let sanitized = (sanitize . drop 2) sessionId+ components = (T.splitOn "~" . T.pack . B64.decode) sanitized+ maybeKey = T.unpack <$> components ^? element 1+ in maybeKey == Just key++-- | Validate token options+validExpireTime :: TokenOptions -> IO Bool+validExpireTime opts = case _expireTime opts of+ Nothing -> pure True+ Just expire -> do+ now <- getCurrentTime+ let maxExpire = addUTCTime (30 * 86400) now+ pure $ expire >= now && expire <= maxExpire++-- | Remove pairs with Nothing values before creating query string+cleanTokenOptions :: [(a, Maybe b)] -> [(a, Maybe b)]+cleanTokenOptions = filter (\(_, v) -> isJust v)++-- | Remove new-line characters from the final token+formatToken :: String -> String+formatToken = filter (/= '\n')++-- | Create a SHA1 encoded token+encodeToken :: APIKey -> APISecret -> SessionId -> TokenOptions -> IO Token+encodeToken key secret sessionId opts = do+ now <- getCurrentTime+ nonce <- nextRandom+ let tokenSentinel = "T1=="+ let expire = maybe (utcToBS $ addUTCTime 86400 now) utcToBS (_expireTime opts)+ let+ options =+ [ ("session_id" , Just $ C8.pack sessionId)+ , ("create_time" , Just $ utcToBS now)+ , ("expire_time" , Just expire)+ , ("nonce" , Just $ C8.pack $ show nonce)+ , ("role" , Just $ C8.pack $ show $ _role opts)+ , ("connection_data", C8.pack <$> _connectionData opts)+ ] :: [(C8.ByteString, Maybe C8.ByteString)]+ let dataString = renderQuery False $ cleanTokenOptions options+ let sig = SHA.showDigest $ SHA.hmacSha1 (L8.pack secret) (L8.fromStrict dataString)+ let decoded =+ "partner_id=" <> key <> "&sig=" <> sig <> ":" <> C8.unpack dataString :: String+ pure $ formatToken $ tokenSentinel <> B64.encode decoded++-- | Generate a new token for an OpenTok session using the provided token options+generate+ :: APIKey+ -> APISecret+ -> SessionId+ -> TokenOptions+ -> IO (Either OTError Token)+generate key secret sessionId opts = do+ let sessionIdValid = validSessionId sessionId key+ expirationValid <- validExpireTime opts+ case (sessionIdValid, expirationValid) of+ (False, _) -> pure $ Left $ error "Failed to validate provided SessionId"+ (_, False) -> pure $ Left $ error "Token expireTime must be between now and 30 days from now"+ (_, _) -> Right <$> encodeToken key secret sessionId opts
+ src/OpenTok/Types.hs view
@@ -0,0 +1,22 @@+module OpenTok.Types where++-- | An OpenTok API key (i.e. project key)+type APIKey = String++-- | An OpenTok API secret (i.e. project secret)+type APISecret = String++-- | An OpenTok Session identifier+type SessionId = String++-- | An OpenTok Archive identifier+type ArchiveId = String++-- | An IPv4 Address+type IPAddress = String++-- | An access token for an OpenTok Session+type Token = String++-- | An error generated by the OpenTok SDK+type OTError = String
+ src/OpenTok/Util.hs view
@@ -0,0 +1,30 @@+module OpenTok.Util where++import Control.Arrow+import Data.Time.Clock+import Data.Convertible ( convert )+import Data.ByteString.Char8 ( pack+ , ByteString+ )+import System.Posix.Types ( EpochTime )++maybeToEither :: a -> Maybe b -> Either a b+maybeToEither e = maybe (Left e) Right++utcToEpoch :: UTCTime -> EpochTime+utcToEpoch = convert++epochToUTC :: EpochTime -> UTCTime+epochToUTC = convert++epochToBS :: EpochTime -> ByteString+epochToBS t = pack $ show t++utcToBS :: UTCTime -> ByteString+utcToBS = epochToBS . utcToEpoch++days :: NominalDiffTime -> NominalDiffTime+days = (*) 86400++mapEither :: (a -> a) -> (b -> b) -> Either a b -> Either a b+mapEither f g = left f >>> right g