Util.hs

module Tests.Util
  ( mmTestCase
  , print_
  , getConnection
  , getSession
  , getTeams
  , createChannel
  , deleteChannel
  , joinChannel
  , leaveChannel
--  , getMoreChannels
  , getChannels
  , getChannelMembers
  , getUserByName
  , getConfig
  , getClientConfig
  , saveConfig
  , teamAddUser
  , reportJSONExceptions
  , adminAccount
  , createAdminAccount
  , loginAccount
  , loginAdminAccount
  , createAccount
  , createTeam
  , findChannel
  , connectFromConfig
  , getMe

  -- * Testing Websocket Events
  , expectWSEvent
  , expectWSDone

  -- * Websocket Event Predicates
  , hasWSEventType
  , forUser
  , forChannel
  , isStatusChange
  , isPost
  , isNewUserEvent
  , isChannelCreatedEvent
  , isChannelDeleteEvent
  , isAddedToTeam
  , isUserJoin
  , isUserLeave
  , isViewedChannel
  , wsHas
  , (&&&)
  )
where

import qualified Control.Exception as E
import qualified Control.Concurrent.STM as STM
import Control.Concurrent (forkIO)
import Control.Concurrent.MVar
import qualified Data.Foldable as F
import Data.Monoid ((<>))
import qualified Data.Sequence as Seq
import qualified Data.Text as T
import Test.Tasty (TestTree)
import Test.Tasty.HUnit (testCaseSteps)
import Control.Monad.State.Lazy
import System.Timeout (timeout)

import Network.Mattermost (ConnectionData)
import Network.Mattermost.Endpoints
import Network.Mattermost.Types
import Network.Mattermost.Types.Config
import Network.Mattermost.WebSocket
import Network.Mattermost.Exceptions
import Network.Mattermost.Util

import Tests.Types

mmTestCase :: String -> TestConfig -> TestM () -> TestTree
mmTestCase testName cfg act =
    testCaseSteps testName $ \prnt -> do
      cd <- connectFromConfig cfg
      wsChan <- STM.atomically STM.newTChan
      mv <- newEmptyMVar
      let initState = TestState { tsPrinter = prnt
                                , tsConfig = cfg
                                , tsConnectionData = cd
                                , tsSession = Nothing
                                , tsDebug = False
                                , tsWebsocketChan = wsChan
                                , tsDone = mv
                                }
      (reportJSONExceptions $ evalStateT act initState) `E.finally`
        (putMVar mv ())

print_ :: String -> TestM ()
print_ s = do
    dbg <- gets tsDebug
    printFunc <- gets tsPrinter
    when dbg $ liftIO $ printFunc s

-- This only exists because tasty will call `show` on the exception that
-- we give it. If we directly output the exception first then we avoid
-- an unnecessary level of quotation in the output. We still throw the
-- exception though so that tasty reports the correct exception type.
-- This results in some redundancy but we only see it when there are
-- failures, so it seems acceptable.
reportJSONExceptions :: IO a -> IO a
reportJSONExceptions io = io
  `E.catch` \e@(JSONDecodeException msg badJson) -> do
  putStrLn $ "\nException: JSONDecodeException: " ++ msg
  putStrLn badJson
  E.throwIO e

adminAccount :: TestConfig -> UsersCreate
adminAccount cfg =
    UsersCreate { usersCreateEmail          = configEmail    cfg
                , usersCreatePassword       = configPassword cfg
                , usersCreateUsername       = configUsername cfg
                , usersCreateAllowMarketing = True
                }

createAdminAccount :: TestM User
createAdminAccount = do
  cd <- getConnection
  cfg <- gets tsConfig
  u <- liftIO $ mmInitialUser cd $ adminAccount cfg
  print_ "Admin Account created"
  return u

loginAccount :: Login -> TestM ()
loginAccount login = do
  cd <- getConnection
  (session, _mmUser) <- liftIO $ join (hoistE <$> mmLogin cd login)
  print_ $ "Authenticated as " ++ T.unpack (username login)
  chan <- gets tsWebsocketChan
  doneMVar <- gets tsDone
  printFunc <- gets tsPrinter
  void $ liftIO $ forkIO $ mmWithWebSocket session
                           (either printFunc (STM.atomically . STM.writeTChan chan))
                           (const $ takeMVar doneMVar)
  modify $ \ts -> ts { tsSession = Just session }

hasWSEventType :: WebsocketEventType -> WebsocketEvent -> Bool
hasWSEventType = wsHas weEvent

wsHas :: (Eq a) => (WebsocketEvent -> a) -> a -> WebsocketEvent -> Bool
wsHas f expected e = f e == expected

(&&&) :: (a -> Bool) -> (a -> Bool) -> a -> Bool
(&&&) f g a = f a && g a

-- | Expect the websocket event channel to contain an event that matches
-- the specified predicate.
expectWSEvent :: String
              -- ^ A human-readable label for this test in case it
              -- fails.
              -> (WebsocketEvent -> Bool)
              -- ^ The predicate to apply.
              -> TestM ()
expectWSEvent name match = do
    chan <- gets tsWebsocketChan
    let timeoutAmount = 10 * 1000 * 1000
    mEv <- liftIO $ timeout timeoutAmount $
                   STM.atomically $ STM.readTChan chan

    case mEv of
        Nothing -> do
            let msg = "Expected a websocket event for " <> show name <>
                      " but timed out waiting"
            print_ msg
            error msg
        Just ev -> when (not $ match ev) $ do
            let msg = "Expected a websocket event for " <> show name <>
                      " but got " <> show ev
            print_ msg
            error msg

-- | Does the websocket correspond to the specified user?
forUser :: User -> WebsocketEvent -> Bool
forUser u =
    wsHas (wepUserId . weData) (Just $ userId u)

-- | Does the websocket correspond to the specified channel?
forChannel :: Channel -> WebsocketEvent -> Bool
forChannel ch =
    wsHas (wepChannelId . weData) (Just $ channelId ch)

-- | Is this websocket event a status change message?
isStatusChange :: User
               -- ^ The user whose status changed
               -> T.Text
               -- ^ The new status
               -> WebsocketEvent
               -> Bool
isStatusChange u s =
    hasWSEventType WMStatusChange &&&
    forUser u &&&
    wsHas (wepStatus . weData) (Just s)

-- | Is the websocket event indicating that a new user was added to the
-- server?
isNewUserEvent :: User
               -- ^ The user that was added
               -> WebsocketEvent
               -> Bool
isNewUserEvent u =
    hasWSEventType WMNewUser &&& forUser u

isViewedChannel :: WebsocketEvent -> Bool
isViewedChannel = hasWSEventType WMChannelViewed

-- | Is the websocket event indicating that a new user was added to the
-- team
isAddedToTeam :: User
              -- ^ The user that was added
              -> Team
              -- ^ The team to which the user was added
              -> WebsocketEvent
              -> Bool
isAddedToTeam u _ =
    hasWSEventType WMAddedToTeam &&& forUser u

isChannelCreatedEvent :: Channel
                      -> WebsocketEvent
                      -> Bool
isChannelCreatedEvent c =
    hasWSEventType WMChannelCreated &&& forChannel c

-- | Is the websocket event indicating that a channel was deleted?
isChannelDeleteEvent :: Channel -> WebsocketEvent -> Bool
isChannelDeleteEvent ch =
    forChannel ch &&& hasWSEventType WMChannelDeleted

-- | Is the websocket event indicating that a user joined a channel?
isUserJoin :: User
           -- ^ The user that joined a channel
           -> Channel
           -- ^ The channel that was joined
           -> WebsocketEvent
           -> Bool
isUserJoin u ch =
    hasWSEventType WMUserAdded &&&
    forUser u &&&
    wsHas (webChannelId . weBroadcast) (Just $ channelId ch)

-- | Is the websocket event indicating that a user left a channel?
isUserLeave :: User
            -- ^ The user that left a channel
            -> Channel
            -- ^ The channel that the user left
            -> WebsocketEvent
            -> Bool
isUserLeave u ch =
    hasWSEventType WMUserRemoved &&&
    forChannel ch &&&
    wsHas (webUserId . weBroadcast) (Just $ userId u)

-- | Is the websocket event indicating that a new message was posted to
-- a channel?
isPost :: User
       -- ^ The user who posted
       -> Channel
       -- ^ The channel to which the new post was added
       -> UserText
       -- ^ The content of the new post
       -> WebsocketEvent
       -> Bool
isPost u ch msg =
    hasWSEventType WMPosted &&&
    wsHas (\e -> postMessage <$> (wepPost $ weData e))
          (Just msg) &&&
    wsHas (\e -> postChannelId <$> (wepPost $ weData e))
          (Just $ channelId ch) &&&
    wsHas (\e -> postUserId =<< (wepPost $ weData e))
          (Just $ userId u)

-- | Timeout in seconds for expectWSDone to wait before concluding that
-- no new websocket events are available.
emptyWSTimeout :: Int
emptyWSTimeout = 2

-- | Expect that the websocket event channel is empty. Waits up to
-- emptyWSTimeout seconds. Succeeds if no events are received; fails
-- otherwise.
expectWSDone :: TestM ()
expectWSDone = do
    chan <- gets tsWebsocketChan
    let timeoutAmount = emptyWSTimeout * 1000 * 1000
    mEv <- liftIO $ timeout timeoutAmount $
                   STM.atomically $ STM.readTChan chan
    case mEv of
        Nothing -> return ()
        Just ev -> do
            let msg = "Expected no websocket events but got " <> show ev
            print_ msg
            error msg

loginAdminAccount :: TestM ()
loginAdminAccount = do
    cfg <- gets tsConfig
    let admin = Login { username = configUsername cfg
                      , password = configPassword cfg
                      }
    loginAccount admin

createAccount :: UsersCreate -> TestM User
createAccount account = do
  session <- getSession
  newUser <- liftIO $ mmCreateUser account session
  print_ $ "account created for " <> (T.unpack $ usersCreateUsername account)
  return newUser

createTeam :: TeamsCreate -> TestM Team
createTeam tc = do
  session <- getSession
  team <- liftIO $ mmCreateTeam tc session
  print_ $ "Team created: " <> (T.unpack $ teamsCreateName tc)
  return team

findChannel :: Channels -> UserText -> Channel
findChannel chans name =
    let result = Seq.viewl (Seq.filter nameMatches chans)
        nameMatches c = name `elem` [ channelName c
                                    , channelDisplayName c
                                    ]
    in case result of
        chan Seq.:< _ -> chan
        _ ->
            let namePairs = mkPair <$> chans
                mkPair c = (channelName c, channelDisplayName c)
            in error $ "Expected to find channel by name " <>
                     show name <> " but got " <> show namePairs

connectFromConfig :: TestConfig -> IO ConnectionData
connectFromConfig cfg =
  initConnectionDataInsecure (configHostname cfg) (fromIntegral (configPort cfg))
                             defaultConnectionPoolConfig

getConnection :: TestM ConnectionData
getConnection = gets tsConnectionData

getSession :: TestM Session
getSession = do
    val <- gets tsSession
    case val of
        Just s -> return s
        Nothing -> error "Expected authentication token but none was present"

getTeams :: TestM (Seq.Seq Team)
getTeams = do
  session <- getSession
  liftIO $ mmGetUsersTeams UserMe session

getMe :: TestM User
getMe = do
  session <- getSession
  liftIO $ mmGetUser UserMe session

getUserByName :: T.Text -> TestM (Maybe User)
getUserByName uname = do
    session <- getSession
    let query = defaultUserQuery
          { userQueryPage = Just 0
          , userQueryPerPage = Just 10000
          }
    allUserMap <- liftIO $ mmGetUsers query session
    -- Find the user matching the username and get its ID
    let matches = Seq.filter matchingUser allUserMap
        matchingUser u = userUsername u == uname

    case Seq.viewl matches of
        user Seq.:< _ -> do
            let uId = userId user
            -- Then load the User record
            Just <$> (liftIO $ mmGetUser (UserById uId) session)
        _ -> return Nothing

createChannel :: MinChannel -> TestM Channel
createChannel mc = do
  session <- getSession
  liftIO $ mmCreateChannel mc session

deleteChannel :: Channel -> TestM ()
deleteChannel ch = do
  session <- getSession
  liftIO $ mmDeleteChannel (channelId ch) session

joinChannel :: User -> Channel -> TestM ()
joinChannel user chan = do
  session <- getSession
  let member = MinChannelMember
        { minChannelMemberUserId = userId user
        , minChannelMemberChannelId = channelId chan
        }
  liftIO $ void $ mmAddUser (channelId chan) member session

leaveChannel :: Channel -> TestM ()
leaveChannel chan = do
  session <- getSession
  liftIO $ mmRemoveUserFromChannel (channelId chan) UserMe session

getChannelMembers :: Channel -> TestM [User]
getChannelMembers chan = do
  session <- getSession
  let query = defaultUserQuery
        { userQueryPage = Just 0
        , userQueryPerPage = Just 10000
        , userQueryInChannel = Just (channelId chan)
        }
  F.toList <$> (liftIO $ mmGetUsers query session)

getChannels :: Team -> TestM Channels
getChannels team = do
  session <- getSession
  liftIO $ mmGetPublicChannels (teamId team) Nothing Nothing session

getConfig :: TestM ServerConfig
getConfig = do
  session <- getSession
  liftIO $ mmGetConfiguration session

getClientConfig :: TestM ClientConfig -- A.Value
getClientConfig = do
  session <- getSession
  liftIO $ mmGetClientConfiguration (Just (T.pack "old")) session

saveConfig :: ServerConfig -> TestM ()
saveConfig newConfig = do
  session <- getSession
  liftIO $ void $ mmUpdateConfiguration newConfig session

teamAddUser :: Team -> User -> TestM ()
teamAddUser team user = do
  session <- getSession
  let member = TeamMember
        { teamMemberUserId = userId user
        , teamMemberTeamId = teamId team
        , teamMemberRoles  = T.empty
        }
  liftIO $ void $ mmAddUserToTeam (teamId team) member session