diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/opentok.cabal b/opentok.cabal new file mode 100644 --- /dev/null +++ b/opentok.cabal @@ -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 + + diff --git a/src/OpenTok.hs b/src/OpenTok.hs new file mode 100644 --- /dev/null +++ b/src/OpenTok.hs @@ -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) diff --git a/src/OpenTok/Archive.hs b/src/OpenTok/Archive.hs new file mode 100644 --- /dev/null +++ b/src/OpenTok/Archive.hs @@ -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 diff --git a/src/OpenTok/Client.hs b/src/OpenTok/Client.hs new file mode 100644 --- /dev/null +++ b/src/OpenTok/Client.hs @@ -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 } + diff --git a/src/OpenTok/Session.hs b/src/OpenTok/Session.hs new file mode 100644 --- /dev/null +++ b/src/OpenTok/Session.hs @@ -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 +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 diff --git a/src/OpenTok/Token.hs b/src/OpenTok/Token.hs new file mode 100644 --- /dev/null +++ b/src/OpenTok/Token.hs @@ -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 diff --git a/src/OpenTok/Types.hs b/src/OpenTok/Types.hs new file mode 100644 --- /dev/null +++ b/src/OpenTok/Types.hs @@ -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 diff --git a/src/OpenTok/Util.hs b/src/OpenTok/Util.hs new file mode 100644 --- /dev/null +++ b/src/OpenTok/Util.hs @@ -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