diff --git a/opentok.cabal b/opentok.cabal --- a/opentok.cabal +++ b/opentok.cabal @@ -1,5 +1,5 @@ name: opentok -version: 0.0.4 +version: 0.0.5 synopsis: An OpenTok SDK for Haskell description: . @@ -49,6 +49,52 @@ , transformers >= 0.5.2.0 if flag(documentation) build-depends: hscolour == 1.20.* + + +test-suite tests + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Test.hs + other-modules: Session, Token, Archive, Config + + build-depends: + base + , base-compat + , aeson + , aeson-casing + , aeson-compat + , base64-string + , bytestring + , containers + , convertible + , either + , http-client + , http-client-tls + , http-conduit + , http-types + , iproute + , jose + , lens + , monad-time + , unordered-containers + , SHA + , strings + , uuid + , utf8-string + , text + , time + , transformers + + , opentok + + , hspec >= 2.0.0 + , split >= 0.2.3 + , QuickCheck >= 2 + , quickcheck-instances + , tasty + , tasty-hspec >= 1.0 + , tasty-quickcheck flag documentation default: True diff --git a/src/OpenTok.hs b/src/OpenTok.hs --- a/src/OpenTok.hs +++ b/src/OpenTok.hs @@ -6,7 +6,8 @@ , createSession , generateToken , Token - , TokenOptions + , Role(..) + , TokenOptions(..) , tokenOpts , startArchive , stopArchive diff --git a/src/OpenTok/Archive.hs b/src/OpenTok/Archive.hs --- a/src/OpenTok/Archive.hs +++ b/src/OpenTok/Archive.hs @@ -5,45 +5,15 @@ {-# LANGUAGE TemplateHaskell #-} module OpenTok.Archive - ( OutputMode(Composed, Individual) - , ArchiveResolution(SD, HD) - , ArchiveOptions - ( _hasAudio - , _hasAudio - , _name - , _outputMode - , _resolution - , _sessionId - ) + ( OutputMode(..) + , ArchiveResolution(..) + , ArchiveOptions(..) , archiveOpts - , ArchiveStatus(Available, Expired, Failed, Paused, Started, Stopped, Uploaded) - , Archive - ( id - , status - , createdAt - , size - , partnerId - , url - , resolution - , outputMode - , hasAudio - , hasVideo - , reason - , name - , updatedAt - , duration - , sessionId - ) - , ListArchiveOptions - ( _forSessionId - , _count - , _offset - ) + , ArchiveStatus(..) + , Archive(..) + , ListArchiveOptions(..) , listArchiveOpts - , ArchiveCollection - ( count - , items - ) + , ArchiveCollection(..) , start , stop , list @@ -130,6 +100,7 @@ @ ArchiveOptions { _hasVideo = 'True' + , _hasVideo = 'True' , _name = 'Nothing' , _outputMode = 'Composed' , _resolution = 'SD' @@ -266,7 +237,6 @@ ArchiveCollection { count :: 'Int' items :: ['Archive'] - id :: 'String' } @ diff --git a/src/OpenTok/Client.hs b/src/OpenTok/Client.hs --- a/src/OpenTok/Client.hs +++ b/src/OpenTok/Client.hs @@ -77,6 +77,9 @@ _secret :: String } +-- | HTTP Verbs +data Method = GET | POST | DELETE deriving (Show) + -- | Create claims for a JWT mkClaims :: String -> IO ClaimsSet mkClaims projectKey = do @@ -108,7 +111,7 @@ buildHeaders :: SignedJWT -> RequestHeaders buildHeaders jwt = [ - ( "Content-Type", "application/json") + ("Content-Type" , "application/json") , ("Accept" , "application/json") , ("X-OPENTOK-AUTH", toStrict $ encodeCompact jwt) ] @@ -140,11 +143,11 @@ 204 -> pure $ Right "Ok" _ -> pure $ Left $ ClientError sc "Failed to delete resource" -buildRequest :: Path -> SignedJWT -> IO Request -buildRequest p jwt = do +buildRequest :: Method -> Path -> SignedJWT -> IO Request +buildRequest m 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 } + pure $ initialRequest { method = C8.pack $ show m, requestHeaders = buildFn jwt } -- | Make a POST request post :: (FromJSON a) => Client -> Path -> IO (Either ClientError a) @@ -153,7 +156,7 @@ case eitherJWT of Left e -> pure $ Left e Right jwt -> do - request <- buildRequest p jwt + request <- buildRequest POST p jwt execute request -- | Make a POST request with a body @@ -163,25 +166,25 @@ case eitherJWT of Left e -> pure $ Left $ e Right jwt -> do - request <- buildRequest p jwt + request <- buildRequest POST p jwt execute $ request { requestBody = RequestBodyLBS $ encode b } --- | Make a GET request with a body +-- | Make a GET request get :: (FromJSON a) => Client -> Path -> IO (Either ClientError a) get client p = do eitherJWT <- createJWT client case eitherJWT of Left e -> pure $ Left $ e Right jwt -> do - request <- buildRequest p jwt - execute $ request { method = "GET" } + request <- buildRequest GET p jwt + execute $ request --- | Make a GET request with a body +-- | Make a DELETE request del :: Client -> Path -> IO (Either ClientError String) del client p = do eitherJWT <- createJWT client case eitherJWT of Left e -> pure $ Left $ e Right jwt -> do - request <- buildRequest p jwt - deleteResource $ request { method = "DELETE" } + request <- buildRequest DELETE p jwt + deleteResource $ request diff --git a/src/OpenTok/Session.hs b/src/OpenTok/Session.hs --- a/src/OpenTok/Session.hs +++ b/src/OpenTok/Session.hs @@ -2,13 +2,14 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module OpenTok.Session ( - ArchiveMode(Manual, Always) - , MediaMode(Relayed, Routed) - , SessionOptions(_mediaMode, _archiveMode, _location) - , Session(apiKey, sessionId, mediaMode, archiveMode) + ArchiveMode(..) + , MediaMode(..) + , SessionOptions(..) + , Session(..) , sessionOpts , create ) @@ -21,6 +22,7 @@ import Data.Aeson.Types import Data.Aeson.TH import Data.Data +import Data.IP ( IPv4 ) import Data.Strings ( strToLower ) import GHC.Generics @@ -30,7 +32,7 @@ -- | Relayed sessions will attempt to use peer-to-peer (p2p) connections. -- -- Routed sessions will use the -data MediaMode = Relayed | Routed deriving (Data, Generic, Typeable) +data MediaMode = Relayed | Routed deriving (Data, Eq, Generic, Typeable) instance Show MediaMode where show = strToLower . showConstr . toConstr @@ -39,7 +41,7 @@ -- | 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) +data ArchiveMode = Manual | Always deriving (Data, Eq, Generic, Typeable) instance Show ArchiveMode where show = strToLower . showConstr . toConstr @@ -53,15 +55,18 @@ -- -- '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. +-- An 'IPv4' address may be provided as a location hint which will +-- be used in selecting an OpenTok Media Router for the session. data SessionOptions = SessionOptions { _mediaMode :: MediaMode, _archiveMode :: ArchiveMode, - _location :: Maybe IPAddress + _location :: Maybe IPv4 } deriving(Show, Generic) +instance ToJSON IPv4 where + toJSON = genericToJSON defaultOptions + instance ToJSON SessionOptions where toJSON = genericToJSON defaultOptions { omitNothingFields = True, fieldLabelModifier = drop 1 } @@ -99,7 +104,8 @@ apiKey :: String, sessionId :: String, mediaMode :: MediaMode, - archiveMode :: ArchiveMode + archiveMode :: ArchiveMode, + location :: Maybe IPv4 } deriving (Show) data SessionProperties = SessionProperties { @@ -120,6 +126,7 @@ , sessionId = _sessionId props , mediaMode = _mediaMode opts , archiveMode = _archiveMode opts + , location = _location opts } -- | Create a new OpenTok Session diff --git a/src/OpenTok/Token.hs b/src/OpenTok/Token.hs --- a/src/OpenTok/Token.hs +++ b/src/OpenTok/Token.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} module OpenTok.Token where @@ -21,21 +22,23 @@ import qualified Data.ByteString.Lazy.Char8 as L8 ( pack, fromStrict ) +import Data.Data import Data.Semigroup ( (<>) ) +import Data.Strings ( strToLower ) 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 -data Role = Subscriber | Publisher | Moderator +data Role = Subscriber | Publisher | Moderator deriving (Data, Typeable) + instance Show Role where - show Subscriber = "subscriber" - show Publisher = "publisher" - show Moderator = "moderator" + show = strToLower . showConstr . toConstr -- | Information on user roles and other options can be found at https://tokbox.com/developer/guides/create-token/ data TokenOptions = TokenOptions { @@ -89,7 +92,7 @@ Nothing -> pure True Just expire -> do now <- getCurrentTime - let maxExpire = addUTCTime (30 * 86400) now + let maxExpire = addUTCTime (days 30) now pure $ expire >= now && expire <= maxExpire -- | Remove pairs with Nothing values before creating query string @@ -106,7 +109,7 @@ now <- getCurrentTime nonce <- nextRandom let tokenSentinel = "T1==" - let expire = maybe (utcToBS $ addUTCTime 86400 now) utcToBS (_expireTime opts) + let expire = maybe (utcToBS $ addUTCTime (days 1) now) utcToBS (_expireTime opts) let options = [ ("session_id" , Just $ C8.pack sessionId) diff --git a/test/Archive.hs b/test/Archive.hs new file mode 100644 --- /dev/null +++ b/test/Archive.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Archive(spec) where + +import Control.Arrow +import Control.Lens +import Control.Lens.Extras ( is ) +import Data.Either.Combinators ( fromRight ) +import Data.List.Split +import Test.Hspec + +import Config +import OpenTok +import OpenTok.Archive +import OpenTok.Types + +ot :: OpenTok +ot = opentok testKey testSecret + +spec :: Spec +spec = do + listArchivesSpec + +listArchivesSpec :: Spec +listArchivesSpec = describe "listArchives" $ do + it "should return an archive collection" $ do + eArchives <- listArchives ot listArchiveOpts + eArchives `shouldSatisfy` is _Right + + diff --git a/test/Config.hs b/test/Config.hs new file mode 100644 --- /dev/null +++ b/test/Config.hs @@ -0,0 +1,9 @@ +module Config where + +import OpenTok.Types + +testKey :: APIKey +testKey = "45759482" + +testSecret :: APISecret +testSecret = "ab7d7b9e00d412a9760cf4ae887908a989cc8dbb" diff --git a/test/Session.hs b/test/Session.hs new file mode 100644 --- /dev/null +++ b/test/Session.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Session(spec) where + +import Control.Arrow +import Control.Lens +import Control.Lens.Extras (is) +import Data.IP +import Test.Hspec + +import Config +import OpenTok +import OpenTok.Session +import OpenTok.Types + +ot :: OpenTok +ot = opentok testKey testSecret + +spec :: Spec +spec = do + defaultSessionSpec + customSessionSpec + invalidCredentialsSpec + +defaultSessionSpec :: Spec +defaultSessionSpec = describe "A session created with default options" $ do + it "should have default session properties" $ do + session <- createSession ot sessionOpts + session `shouldSatisfy` is _Right + right mediaMode session `shouldBe` Right Relayed + right archiveMode session `shouldBe` Right Manual + right location session `shouldBe` Right Nothing + +customSessionSpec :: Spec +customSessionSpec = describe "A session created with custom options" $ do + it "should have matching session properties" $ do + let loc = Just $ ipv4 "10.1.200.30" + session <- createSession ot sessionOpts { _mediaMode = Routed, _archiveMode = Always, _location = loc } + session `shouldSatisfy` is _Right + right mediaMode session `shouldBe` Right Routed + right archiveMode session `shouldBe` Right Always + right location session `shouldBe` Right loc + +invalidCredentialsSpec :: Spec +invalidCredentialsSpec = describe "A session created with invalid credentials" $ do + it "should return an error" $ do + let invalidOT = opentok "123456" "123456789123456789123456789" + session <- createSession invalidOT sessionOpts + session `shouldSatisfy` is _Left + + diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,19 @@ +import Test.Tasty +import Test.Tasty.Hspec +import Test.Tasty.QuickCheck + +import Archive +import Session +import Token + +main :: IO () +main = do + unitTests <- unitTestsIO + defaultMain $ testGroup "Tests" [unitTests] + +unitTestsIO :: IO TestTree +unitTestsIO = do + session <- testSpec "Session" Session.spec + token <- testSpec "Token" Token.spec + archive <- testSpec "Archive" Archive.spec + return $ testGroup "Unit tests" [session, token, archive] diff --git a/test/Token.hs b/test/Token.hs new file mode 100644 --- /dev/null +++ b/test/Token.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Token(spec) where + +import qualified Codec.Binary.Base64.String as B64 +import Control.Arrow +import Control.Lens +import Control.Lens.Extras ( is ) +import Data.Either.Combinators ( fromRight ) +import Data.List.Split +import Test.Hspec + +import Config +import OpenTok +import OpenTok.Session +import OpenTok.Types + +ot :: OpenTok +ot = opentok testKey testSecret + +sessionRequest :: IO (Either OTError Session) +sessionRequest = createSession ot sessionOpts + +tokenParts :: Either OTError Token -> [String] +tokenParts et = fromRight [] (right (splitOn "&" . B64.decode . drop 4) et) + +extractValue :: String -> Maybe String +extractValue p = splitOn "=" p ^? element 1 + +spec :: Spec +spec = do + defaultTokenSpec + customTokenSpec + +defaultTokenSpec :: Spec +defaultTokenSpec = describe "A token created with default options" $ do + it "should have default connection properties" $ do + eSession <- sessionRequest + eToken <- generateToken ot (fromRight "" (right sessionId eSession)) tokenOpts + let parts = tokenParts eToken + let role = (parts ^? element 5) >>= extractValue + let connectionData = (parts ^? element 6) >>= extractValue + role `shouldBe` Just "publisher" + connectionData `shouldBe` Nothing + +customTokenSpec :: Spec +customTokenSpec = describe "A token created with custom options" $ do + it "should have those properties encoded" $ do + let opts = tokenOpts { _role = Moderator, _connectionData = Just ("foo" :: String) } + eSession <- sessionRequest + eToken <- generateToken ot (fromRight "" (right sessionId eSession)) opts + let parts = tokenParts eToken + let role = (parts ^? element 5) >>= extractValue + let connectionData = (parts ^? element 6) >>= extractValue + role `shouldBe` Just "moderator" + connectionData `shouldBe` Just "foo" + +