matrix-client 0.1.1.0 → 0.1.2.0

raw patch · 13 files changed

+877/−88 lines, 13 filesdep +aeson-casingdep +containersdep −doctestdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: aeson-casing, containers

Dependencies removed: doctest

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +11/−0
• README.md +0/−21
• matrix-client.cabal +8/−11
• src/Network/Matrix/Client.hs +536/−3
• src/Network/Matrix/Events.hs +109/−20
• src/Network/Matrix/Identity.hs +1/−0
• src/Network/Matrix/Internal.hs +32/−16
• src/Network/Matrix/Room.hs +35/−0
• src/Network/Matrix/Tutorial.hs +45/−2
• test/Doctest.hs +0/−6
• test/Spec.hs +73/−9
• test/data/message-edit.json +16/−0
• test/data/message-reply.json +11/−0

@@ -1,5 +1,16 @@ # Changelog +## 0.1.2.0++- Add filtering client function+- Add sync client function+- Add createRoom client function+- Add retryWithLog and syncPoll utility function+- Add mkReply helper utility function+- Add reply and edit Event+- Change MessageText to include the TextType+- Change RoomEvent to use Author and EventID newtype+ ## 0.1.1.0  - Ensure aeson encoding test is reproducible using aeson-pretty

@@ -1,21 +0,0 @@-# matrix-client-haskell--[![Hackage](https://img.shields.io/hackage/v/matrix-client.svg)](https://hackage.haskell.org/package/matrix-client)--A client library for [matrix.org](https://matrix.org)--## Contribute--To work on this project you need a Haskell toolchain, for example on fedora:--```ShellSession-$ sudo dnf install -y ghc cabal-install && cabal update-```--Run the tests:--```ShellSession-$ cabal test-```--If you experience any difficulties, please don't hesistate to raise an issue.

@@ -1,6 +1,6 @@ cabal-version:       2.4 name:                matrix-client-version:             0.1.1.0+version:             0.1.2.0 synopsis:            A matrix client library description:     Matrix client is a library to interface with https://matrix.org.@@ -9,6 +9,8 @@     .     Read the "Network.Matrix.Tutorial" for a detailed tutorial.     .+    Please see the README at https://github.com/softwarefactory-project/matrix-client-haskell#readme+    . homepage:            https://github.com/softwarefactory-project/matrix-client-haskell#readme bug-reports:         https://github.com/softwarefactory-project/matrix-client-haskell/issues license:             Apache-2.0@@ -19,7 +21,7 @@ category:            Network build-type:          Simple extra-doc-files:     CHANGELOG.md-                     README.md+extra-source-files:  test/data/*.json tested-with:         GHC == 8.10.4  source-repository head@@ -28,6 +30,7 @@  common common-options   build-depends:       base                   >= 4.11.0.0 && < 5+                     , aeson-casing           >= 0.2.0.0  && < 0.3.0.0                      , aeson                  >= 1.0.0.0  && < 1.6   ghc-options:         -Wall                        -Wcompat@@ -47,6 +50,7 @@   build-depends:       SHA                    ^>= 1.6                      , base64                      , bytestring+                     , containers                      , exceptions                      , hashable                      , http-client            >= 0.5.0    && < 0.8@@ -65,6 +69,7 @@                      , Network.Matrix.Tutorial   other-modules:       Network.Matrix.Events                      , Network.Matrix.Internal+                     , Network.Matrix.Room  test-suite unit   import:             common-options, lib-depends@@ -72,16 +77,8 @@   hs-source-dirs:     test, src   main-is:            Spec.hs   build-depends:      base+                    , bytestring                     , aeson-pretty                     , hspec >= 2                     , matrix-client                     , text--test-suite doctest-  type:               exitcode-stdio-1.0-  default-language:   Haskell2010-  hs-source-dirs:     test-  ghc-options:        -threaded -Wall-  main-is:            Doctest.hs-  build-depends:      base-                    , doctest >= 0.9.3

@@ -1,4 +1,8 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -12,17 +16,25 @@     createSession,      -- * API+    MatrixM,     MatrixIO,     MatrixError (..),     retry,+    retryWithLog,      -- * User data     UserID (..),     getTokenOwner, +    -- * Room management+    RoomCreatePreset (..),+    RoomCreateRequest (..),+    createRoom,+     -- * Room participation     TxnID (..),     sendMessage,+    mkReply,     module Network.Matrix.Events,      -- * Room membership@@ -31,18 +43,61 @@     joinRoom,     joinRoomById,     leaveRoomById,++    -- * Filter+    EventFormat (..),+    EventFilter (..),+    defaultEventFilter,+    eventFilterAll,+    RoomEventFilter (..),+    defaultRoomEventFilter,+    roomEventFilterAll,+    StateFilter (..),+    defaultStateFilter,+    stateFilterAll,+    RoomFilter (..),+    defaultRoomFilter,+    Filter (..),+    defaultFilter,+    FilterID (..),+    messageFilter,+    createFilter,+    getFilter,++    -- * Events+    sync,+    getTimelines,+    syncPoll,+    Author (..),+    Presence (..),+    RoomEvent (..),+    RoomSummary (..),+    TimelineSync (..),+    InvitedRoomSync (..),+    JoinedRoomSync (..),+    SyncResult (..),+    SyncResultRoom (..),   ) where  import Control.Monad (mzero)-import Data.Aeson (FromJSON (..), Value (Object), encode, (.:))+import Control.Monad.IO.Class (MonadIO(liftIO))+import Data.Aeson (FromJSON (..), ToJSON (..), Value (Object, String), encode, genericParseJSON, genericToJSON, object, (.:), (.:?), (.=))+import qualified Data.Aeson as Aeson+import Data.Aeson.Casing (aesonPrefix, snakeCase) import Data.Hashable (Hashable)-import Data.Text (Text)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Map.Strict (Map, foldrWithKey)+import Data.Maybe (fromMaybe)+import Data.Text (Text, pack)+import qualified Data.Text as Text import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import GHC.Generics import qualified Network.HTTP.Client as HTTP import Network.HTTP.Types.URI (urlEncode) import Network.Matrix.Events import Network.Matrix.Internal+import Network.Matrix.Room  -- $setup -- >>> import Data.Aeson (decode)@@ -74,6 +129,36 @@ getTokenOwner session =   doRequest session =<< mkRequest session True "/_matrix/client/r0/account/whoami" +-- | A workaround data type to handle room create error being reported with a {message: "error"} response+data CreateRoomResponse = CreateRoomResponse+  { crrMessage :: Maybe Text,+    crrID :: Maybe Text+  }++instance FromJSON CreateRoomResponse where+  parseJSON (Object o) = CreateRoomResponse <$> o .:? "message" <*> o .:? "room_id"+  parseJSON _ = mzero++createRoom :: ClientSession -> RoomCreateRequest -> MatrixIO RoomID+createRoom session rcr = do+  request <- mkRequest session True "/_matrix/client/r0/createRoom"+  toRoomID+    <$> doRequest+      session+      ( request+          { HTTP.method = "POST",+            HTTP.requestBody = HTTP.RequestBodyLBS $ encode rcr+          }+      )+  where+    toRoomID :: Either MatrixError CreateRoomResponse -> Either MatrixError RoomID+    toRoomID resp = case resp of+      Left err -> Left err+      Right crr -> case (crrID crr, crrMessage crr) of+        (Just roomID, _) -> pure $ RoomID roomID+        (_, Just message) -> Left $ MatrixError "UNKNOWN" message Nothing+        _ -> Left $ MatrixError "UNKOWN" "" Nothing+ newtype TxnID = TxnID Text deriving (Show, Eq)  sendMessage :: ClientSession -> RoomID -> Event -> TxnID -> MatrixIO EventID@@ -90,7 +175,7 @@     path = "/_matrix/client/r0/rooms/" <> roomId <> "/send/" <> eventId <> "/" <> txnId     eventId = eventType event -newtype RoomID = RoomID Text deriving (Show, Eq, Hashable)+newtype RoomID = RoomID Text deriving (Show, Eq, Ord, Hashable)  instance FromJSON RoomID where   parseJSON (Object v) = RoomID <$> v .: "room_id"@@ -136,3 +221,451 @@     ensureEmptyObject value = case value of       Object xs | xs == mempty -> ()       _anyOther -> error $ "Unknown leave response: " <> show value++-------------------------------------------------------------------------------+-- https://matrix.org/docs/spec/client_server/latest#post-matrix-client-r0-user-userid-filter+newtype FilterID = FilterID Text deriving (Show, Eq, Hashable)++instance FromJSON FilterID where+  parseJSON (Object v) = FilterID <$> v .: "filter_id"+  parseJSON _ = mzero++data EventFormat = Client | Federation deriving (Show, Eq)++instance ToJSON EventFormat where+  toJSON ef = case ef of+    Client -> "client"+    Federation -> "federation"++instance FromJSON EventFormat where+  parseJSON v = case v of+    (String "client") -> pure Client+    (String "federation") -> pure Federation+    _ -> mzero++data EventFilter = EventFilter+  { efLimit :: Maybe Int,+    efNotSenders :: Maybe [Text],+    efNotTypes :: Maybe [Text],+    efSenders :: Maybe [Text],+    efTypes :: Maybe [Text]+  }+  deriving (Show, Eq, Generic)++defaultEventFilter :: EventFilter+defaultEventFilter = EventFilter Nothing Nothing Nothing Nothing Nothing++-- | A filter that should match nothing+eventFilterAll :: EventFilter+eventFilterAll = defaultEventFilter {efLimit = Just 0, efNotTypes = Just ["*"]}++aesonOptions :: Aeson.Options+aesonOptions = (aesonPrefix snakeCase) {Aeson.omitNothingFields = True}++instance ToJSON EventFilter where+  toJSON = genericToJSON aesonOptions++instance FromJSON EventFilter where+  parseJSON = genericParseJSON aesonOptions++data RoomEventFilter = RoomEventFilter+  { refLimit :: Maybe Int,+    refNotSenders :: Maybe [Text],+    refNotTypes :: Maybe [Text],+    refSenders :: Maybe [Text],+    refTypes :: Maybe [Text],+    refLazyLoadMembers :: Maybe Bool,+    refIncludeRedundantMembers :: Maybe Bool,+    refNotRooms :: Maybe [Text],+    refRooms :: Maybe [Text],+    refContainsUrl :: Maybe Bool+  }+  deriving (Show, Eq, Generic)++defaultRoomEventFilter :: RoomEventFilter+defaultRoomEventFilter = RoomEventFilter Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing++-- | A filter that should match nothing+roomEventFilterAll :: RoomEventFilter+roomEventFilterAll = defaultRoomEventFilter {refLimit = Just 0, refNotTypes = Just ["*"]}++instance ToJSON RoomEventFilter where+  toJSON = genericToJSON aesonOptions++instance FromJSON RoomEventFilter where+  parseJSON = genericParseJSON aesonOptions++data StateFilter = StateFilter+  { sfLimit :: Maybe Int,+    sfNotSenders :: Maybe [Text],+    sfNotTypes :: Maybe [Text],+    sfSenders :: Maybe [Text],+    sfTypes :: Maybe [Text],+    sfLazyLoadMembers :: Maybe Bool,+    sfIncludeRedundantMembers :: Maybe Bool,+    sfNotRooms :: Maybe [Text],+    sfRooms :: Maybe [Text],+    sfContains_url :: Maybe Bool+  }+  deriving (Show, Eq, Generic)++defaultStateFilter :: StateFilter+defaultStateFilter = StateFilter Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing++stateFilterAll :: StateFilter+stateFilterAll = defaultStateFilter {sfLimit = Just 0, sfNotTypes = Just ["*"]}++instance ToJSON StateFilter where+  toJSON = genericToJSON aesonOptions++instance FromJSON StateFilter where+  parseJSON = genericParseJSON aesonOptions++data RoomFilter = RoomFilter+  { rfNotRooms :: Maybe [Text],+    rfRooms :: Maybe [Text],+    rfEphemeral :: Maybe RoomEventFilter,+    rfIncludeLeave :: Maybe Bool,+    rfState :: Maybe StateFilter,+    rfTimeline :: Maybe RoomEventFilter,+    rfAccountData :: Maybe RoomEventFilter+  }+  deriving (Show, Eq, Generic)++defaultRoomFilter :: RoomFilter+defaultRoomFilter = RoomFilter Nothing Nothing Nothing Nothing Nothing Nothing Nothing++instance ToJSON RoomFilter where+  toJSON = genericToJSON aesonOptions++instance FromJSON RoomFilter where+  parseJSON = genericParseJSON aesonOptions++data Filter = Filter+  { filterEventFields :: Maybe [Text],+    filterEventFormat :: Maybe EventFormat,+    filterPresence :: Maybe EventFilter,+    filterAccountData :: Maybe EventFilter,+    filterRoom :: Maybe RoomFilter+  }+  deriving (Show, Eq, Generic)++defaultFilter :: Filter+defaultFilter = Filter Nothing Nothing Nothing Nothing Nothing++-- | A filter to keep all the messages+messageFilter :: Filter+messageFilter =+  defaultFilter+    { filterPresence = Just eventFilterAll,+      filterAccountData = Just eventFilterAll,+      filterRoom = Just roomFilter+    }+  where+    roomFilter =+      defaultRoomFilter+        { rfEphemeral = Just roomEventFilterAll,+          rfState = Just stateFilterAll,+          rfTimeline = Just timelineFilter,+          rfAccountData = Just roomEventFilterAll+        }+    timelineFilter =+      defaultRoomEventFilter+        { refTypes = Just ["m.room.message"]+        }++instance ToJSON Filter where+  toJSON = genericToJSON aesonOptions++instance FromJSON Filter where+  parseJSON = genericParseJSON aesonOptions++-- | Upload a new filter definition to the homeserver+-- https://matrix.org/docs/spec/client_server/latest#post-matrix-client-r0-user-userid-filter+createFilter ::+  -- | The client session, use 'createSession' to get one.+  ClientSession ->+  -- | The userID, use 'getTokenOwner' to get it.+  UserID ->+  -- | The filter definition, use 'defaultFilter' to create one or use the 'messageFilter' example.+  Filter ->+  -- | The function returns a 'FilterID' suitable for the 'sync' function.+  MatrixIO FilterID+createFilter session (UserID userID) body = do+  request <- mkRequest session True path+  doRequest+    session+    ( request+        { HTTP.method = "POST",+          HTTP.requestBody = HTTP.RequestBodyLBS $ encode body+        }+    )+  where+    path = "/_matrix/client/r0/user/" <> userID <> "/filter"++getFilter :: ClientSession -> UserID -> FilterID -> MatrixIO Filter+getFilter session (UserID userID) (FilterID filterID) =+  doRequest session =<< mkRequest session True path+  where+    path = "/_matrix/client/r0/user/" <> userID <> "/filter/" <> filterID++-------------------------------------------------------------------------------+-- https://matrix.org/docs/spec/client_server/latest#get-matrix-client-r0-sync+newtype Author = Author {unAuthor :: Text}+  deriving (Show, Eq)+  deriving newtype (FromJSON, ToJSON)++data RoomEvent = RoomEvent+  { reContent :: Event,+    reType :: Text,+    reEventId :: EventID,+    reSender :: Author+  }+  deriving (Show, Eq, Generic)++data RoomSummary = RoomSummary+  { rsJoinedMemberCount :: Maybe Int,+    rsInvitedMemberCount :: Maybe Int+  }+  deriving (Show, Eq, Generic)++data TimelineSync = TimelineSync+  { tsEvents :: Maybe [RoomEvent],+    tsLimited :: Maybe Bool,+    tsPrevBatch :: Maybe Text+  }+  deriving (Show, Eq, Generic)++data JoinedRoomSync = JoinedRoomSync+  { jrsSummary :: Maybe RoomSummary,+    jrsTimeline :: TimelineSync+  }+  deriving (Show, Eq, Generic)++data Presence = Offline | Online | Unavailable deriving (Eq)++instance Show Presence where+  show = \case+    Offline -> "offline"+    Online -> "online"+    Unavailable -> "unavailable"++instance ToJSON Presence where+  toJSON ef = String . pack . show $ ef++instance FromJSON Presence where+  parseJSON v = case v of+    (String "offline") -> pure Offline+    (String "online") -> pure Online+    (String "unavailable") -> pure Unavailable+    _ -> mzero++data SyncResult = SyncResult+  { srNextBatch :: Text,+    srRooms :: Maybe SyncResultRoom+  }+  deriving (Show, Eq, Generic)++data SyncResultRoom = SyncResultRoom+  { srrJoin :: Maybe (Map Text JoinedRoomSync)+  , srrInvite :: Maybe (Map Text InvitedRoomSync)+  }+  deriving (Show, Eq, Generic)++data InvitedRoomSync = InvitedRoomSync+  deriving (Show, Eq, Generic)++unFilterID :: FilterID -> Text+unFilterID (FilterID x) = x++-------------------------------------------------------------------------------+-- https://matrix.org/docs/spec/client_server/latest#forming-relationships-between-events++headMaybe :: [a] -> Maybe a+headMaybe xs = case xs of+  [] -> Nothing+  (x : _) -> Just x++tail' :: [a] -> [a]+tail' xs = case xs of+  [] -> []+  (_ : rest) -> rest++-- | An helper to create a reply body+--+-- >>> let sender = Author "foo@matrix.org"+-- >>> addReplyBody sender "Hello" "hi"+-- "> <foo@matrix.org> Hello\n\nhi"+--+-- >>> addReplyBody sender "" "hey"+-- "> <foo@matrix.org>\n\nhey"+--+-- >>> addReplyBody sender "a multi\nline" "resp"+-- "> <foo@matrix.org> a multi\n> line\n\nresp"+addReplyBody :: Author -> Text -> Text -> Text+addReplyBody (Author author) old reply =+  let oldLines = Text.lines old+      headLine = "> <" <> author <> ">" <> maybe "" (mappend " ") (headMaybe oldLines)+      newBody = [headLine] <> map (mappend "> ") (tail' oldLines) <> [""] <> [reply]+   in Text.dropEnd 1 $ Text.unlines newBody++addReplyFormattedBody :: RoomID -> EventID -> Author -> Text -> Text -> Text+addReplyFormattedBody (RoomID roomID) (EventID eventID) (Author author) old reply =+  Text.unlines+    [ "<mx-reply>",+      "  <blockquote>",+      "    <a href=\"https://matrix.to/#/" <> roomID <> "/" <> eventID <> "\">In reply to</a>",+      "    <a href=\"https://matrix.to/#/" <> author <> "\">" <> author <> "</a>",+      "    <br />",+      "    " <> old,+      "  </blockquote>",+      "</mx-reply>",+      reply+    ]++-- | Convert body by encoding HTML special char+--+-- >>> toFormattedBody "& <test>"+-- "&amp; &lt;test&gt;"+toFormattedBody :: Text -> Text+toFormattedBody = Text.concatMap char+  where+    char x = case x of+      '<' -> "&lt;"+      '>' -> "&gt;"+      '&' -> "&amp;"+      _ -> Text.singleton x++-- | Prepare a reply event+mkReply ::+  -- | The destination room, must match the original event+  RoomID ->+  -- | The original event+  RoomEvent ->+  -- | The reply message+  MessageText ->+  -- | The event to send+  Event+mkReply room re mt =+  let getFormattedBody mt' = fromMaybe (toFormattedBody $ mtBody mt') (mtFormattedBody mt')+      eventID = reEventId re+      author = reSender re+      updateText oldMT =+        oldMT+          { mtFormat = Just "org.matrix.custom.html",+            mtBody = addReplyBody author (mtBody oldMT) (mtBody mt),+            mtFormattedBody =+              Just $+                addReplyFormattedBody+                  room+                  eventID+                  author+                  (getFormattedBody oldMT)+                  (getFormattedBody mt)+          }++      newMessage = case reContent re of+        EventRoomMessage (RoomMessageText oldMT) -> updateText oldMT+        EventRoomReply _ (RoomMessageText oldMT) -> updateText oldMT+        EventRoomEdit _ (RoomMessageText oldMT) -> updateText oldMT+        EventUnknown x -> error $ "Can't reply to " <> show x+   in EventRoomReply eventID (RoomMessageText newMessage)++sync :: ClientSession -> Maybe FilterID -> Maybe Text -> Maybe Presence -> Maybe Int -> MatrixIO SyncResult+sync session filterM sinceM presenceM timeoutM = do+  request <- mkRequest session True "/_matrix/client/r0/sync"+  doRequest session (HTTP.setQueryString qs request)+  where+    toQs name = \case+      Nothing -> []+      Just v -> [(name, Just . encodeUtf8 $ v)]+    qs =+      toQs "filter" (unFilterID <$> filterM)+        <> toQs "since" sinceM+        <> toQs "set_presence" (pack . show <$> presenceM)+        <> toQs "timeout" (pack . show <$> timeoutM)++syncPoll ::+  (MonadIO m) =>+  -- | The client session, use 'createSession' to get one.+  ClientSession ->+  -- | A sync filter, use 'createFilter' to get one.+  Maybe FilterID ->+  -- | A since value, get it from a previous sync result using the 'srNextBatch' field.+  Maybe Text ->+  -- | Set the session presence.+  Maybe Presence ->+  -- | Your callback to handle sync result.+  (SyncResult -> m ()) ->+  -- | This function does not return unless there is an error.+  MatrixM m ()+syncPoll session filterM sinceM presenceM cb = go sinceM+  where+    go since = do+      syncResultE <- liftIO $ retry $ sync session filterM since presenceM (Just 10_000)+      case syncResultE of+        Left err -> pure (Left err)+        Right sr -> cb sr >> go (Just (srNextBatch sr))++-- | Extract room events from a sync result+getTimelines :: SyncResult -> [(RoomID, NonEmpty RoomEvent)]+getTimelines sr = foldrWithKey getEvents [] joinedRooms+  where+    getEvents :: Text -> JoinedRoomSync -> [(RoomID, NonEmpty RoomEvent)] -> [(RoomID, NonEmpty RoomEvent)]+    getEvents roomID jrs acc = case tsEvents (jrsTimeline jrs) of+      Just (x : xs) -> (RoomID roomID, x :| xs) : acc+      _ -> acc+    joinedRooms = fromMaybe mempty $ srRooms sr >>= srrJoin++-------------------------------------------------------------------------------+-- Derived JSON instances+instance ToJSON RoomEvent where+  toJSON RoomEvent {..} =+    object+      [ "content" .= reContent,+        "type" .= reType,+        "event_id" .= unEventID reEventId,+        "sender" .= reSender+      ]++instance FromJSON RoomEvent where+  parseJSON (Object o) = do+    eventId <- o .: "event_id"+    RoomEvent <$> o .: "content" <*> o .: "type" <*> pure (EventID eventId) <*> o .: "sender"+  parseJSON _ = mzero++instance ToJSON RoomSummary where+  toJSON = genericToJSON aesonOptions++instance FromJSON RoomSummary where+  parseJSON = genericParseJSON aesonOptions++instance ToJSON TimelineSync where+  toJSON = genericToJSON aesonOptions++instance FromJSON TimelineSync where+  parseJSON = genericParseJSON aesonOptions++instance ToJSON JoinedRoomSync where+  toJSON = genericToJSON aesonOptions++instance FromJSON JoinedRoomSync where+  parseJSON = genericParseJSON aesonOptions++instance ToJSON InvitedRoomSync where+  toJSON _ = object []++instance FromJSON InvitedRoomSync where+  parseJSON _ = pure InvitedRoomSync++instance ToJSON SyncResult where+  toJSON = genericToJSON aesonOptions++instance FromJSON SyncResult where+  parseJSON = genericParseJSON aesonOptions++instance ToJSON SyncResultRoom where+  toJSON = genericToJSON aesonOptions++instance FromJSON SyncResultRoom where+  parseJSON = genericParseJSON aesonOptions

@@ -2,7 +2,8 @@  -- | Matrix event data type module Network.Matrix.Events-  ( MessageText (..),+  ( MessageTextType (..),+    MessageText (..),     RoomMessage (..),     Event (..),     EventID (..),@@ -10,59 +11,147 @@   ) where +import Control.Applicative ((<|>)) import Control.Monad (mzero)-import Data.Aeson (FromJSON (..), ToJSON (..), Value (Object), object, (.:), (.=))+import Data.Aeson (FromJSON (..), Object, ToJSON (..), Value (Object, String), object, (.:), (.:?), (.=)) import Data.Aeson.Types (Pair) import Data.Text (Text) +data MessageTextType+  = TextType+  | EmoteType+  | NoticeType+  deriving (Eq, Show)++instance FromJSON MessageTextType where+  parseJSON (String name) = case name of+    "m.text" -> pure TextType+    "m.emote" -> pure EmoteType+    "m.notice" -> pure NoticeType+    _ -> mzero+  parseJSON _ = mzero++instance ToJSON MessageTextType where+  toJSON mt = String $ case mt of+    TextType -> "m.text"+    EmoteType -> "m.emote"+    NoticeType -> "m.notice"+ data MessageText = MessageText   { mtBody :: Text,+    mtType :: MessageTextType,     mtFormat :: Maybe Text,     mtFormattedBody :: Maybe Text   }   deriving (Show, Eq) +instance FromJSON MessageText where+  parseJSON (Object v) =+    MessageText+      <$> v .: "body"+        <*> v .: "msgtype"+        <*> v .:? "format"+        <*> v .:? "formatted_body"+  parseJSON _ = mzero+ messageTextAttr :: MessageText -> [Pair] messageTextAttr msg =-  ["body" .= mtBody msg] <> format <> formattedBody+  ["body" .= mtBody msg, "msgtype" .= mtType msg] <> format <> formattedBody   where     omitNull k vM = maybe [] (\v -> [k .= v]) vM     format = omitNull "format" $ mtFormat msg     formattedBody = omitNull "formatted_body" $ mtFormattedBody msg -data RoomMessage+instance ToJSON MessageText where+  toJSON = object . messageTextAttr++newtype RoomMessage   = RoomMessageText MessageText-  | RoomMessageEmote MessageText-  | RoomMessageNotice MessageText   deriving (Show, Eq) -roomMessageType :: RoomMessage -> Text-roomMessageType roomMessage = case roomMessage of-  RoomMessageText _ -> "m.text"-  RoomMessageEmote _ -> "m.emote"-  RoomMessageNotice _ -> "m.notice"+roomMessageAttr :: RoomMessage -> [Pair]+roomMessageAttr rm = case rm of+  RoomMessageText mt -> messageTextAttr mt  instance ToJSON RoomMessage where-  toJSON msg =-    let msgtype = roomMessageType msg-        attr = case msg of-          RoomMessageText mt -> messageTextAttr mt-          RoomMessageEmote mt -> messageTextAttr mt-          RoomMessageNotice mt -> messageTextAttr mt-     in object (["msgtype" .= msgtype] <> attr)+  toJSON msg = case msg of+    RoomMessageText mt -> toJSON mt -newtype Event = EventRoomMessage RoomMessage+instance FromJSON RoomMessage where+  parseJSON x = RoomMessageText <$> parseJSON x +data RelatedMessage = RelatedMessage+  { rmMessage :: RoomMessage,+    rmRelatedTo :: EventID+  }+  deriving (Show, Eq)++data Event+  = EventRoomMessage RoomMessage+  | -- | A reply defined by the parent event id and the reply message+    EventRoomReply EventID RoomMessage+  | -- | An edit defined by the original message and the new message+    EventRoomEdit (EventID, RoomMessage) RoomMessage+  | EventUnknown Object+  deriving (Eq, Show)+ instance ToJSON Event where   toJSON event = case event of     EventRoomMessage msg -> toJSON msg+    EventRoomReply eventID msg ->+      let replyAttr =+            [ "m.relates_to"+                .= object+                  [ "m.in_reply_to" .= toJSON eventID+                  ]+            ]+       in object $ replyAttr <> roomMessageAttr msg+    EventRoomEdit (EventID eventID, msg) newMsg ->+      let editAttr =+            [ "m.relates_to"+                .= object+                  [ "rel_type" .= ("m.replace" :: Text),+                    "event_id" .= eventID+                  ],+              "m.new_content" .= object (roomMessageAttr newMsg)+            ]+       in object $ editAttr <> roomMessageAttr msg+    EventUnknown v -> Object v +instance FromJSON Event where+  parseJSON (Object content) =+    parseRelated <|> parseMessage <|> pure (EventUnknown content)+    where+      parseMessage = EventRoomMessage <$> parseJSON (Object content)+      parseRelated = do+        relateM <- content .: "m.relates_to"+        case relateM of+          Object relate -> parseReply relate <|> parseReplace relate+          _ -> mzero+      parseReply relate =+        EventRoomReply <$> relate .: "m.in_reply_to" <*> parseJSON (Object content)+      parseReplace relate = do+        rel_type <- relate .: "rel_type"+        if rel_type == ("m.replace" :: Text)+          then do+            ev <- EventID <$> relate .: "event_id"+            msg <- parseJSON (Object content)+            EventRoomEdit (ev, msg) <$> content .: "m.new_content"+          else mzero+  parseJSON _ = mzero+ eventType :: Event -> Text eventType event = case event of   EventRoomMessage _ -> "m.room.message"+  EventRoomReply _ _ -> "m.room.message"+  EventRoomEdit _ _ -> "m.room.message"+  EventUnknown _ -> error $ "Event is not implemented: " <> show event -newtype EventID = EventID Text deriving (Show)+newtype EventID = EventID {unEventID :: Text} deriving (Show, Eq, Ord)  instance FromJSON EventID where   parseJSON (Object v) = EventID <$> v .: "event_id"   parseJSON _ = mzero++instance ToJSON EventID where+  toJSON (EventID v) = object ["event_id" .= v]

@@ -14,6 +14,7 @@     MatrixIO,     MatrixError (..),     retry,+    retryWithLog,      -- * User data     UserID (..),

@@ -1,3 +1,4 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-}@@ -9,11 +10,13 @@ import Control.Concurrent (threadDelay) import Control.Exception (Exception, throw, throwIO) import Control.Monad (mzero, unless, void)-import Control.Monad.Catch (Handler (Handler))+import Control.Monad.Catch (Handler (Handler), MonadMask)+import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Retry (RetryStatus (..)) import qualified Control.Retry as Retry import Data.Aeson (FromJSON (..), Value (Object), eitherDecode, (.:), (.:?)) import Data.ByteString.Lazy (ByteString, toStrict)+import Data.Hashable (Hashable) import Data.Maybe (fromMaybe) import Data.Text (Text, pack, unpack) import Data.Text.Encoding (decodeUtf8, encodeUtf8)@@ -21,6 +24,7 @@ import qualified Network.HTTP.Client as HTTP import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.HTTP.Types (Status (..))+import Network.HTTP.Types.Status (statusIsSuccessful) import System.Environment (getEnv) import System.IO (stderr) @@ -65,18 +69,20 @@ doRequest' :: FromJSON a => HTTP.Manager -> HTTP.Request -> IO (Either MatrixError a) doRequest' manager request = do   response <- HTTP.httpLbs request manager-  case decodeResp (HTTP.responseBody response) of-    Nothing -> throwResponseError request response (HTTP.responseBody response)-    Just a -> pure a+  case decodeResp $ HTTP.responseBody response of+    Right x -> pure x+    Left e -> if statusIsSuccessful $ HTTP.responseStatus response+      then fail e+      else throwResponseError request response (HTTP.responseBody response) -decodeResp :: FromJSON a => ByteString -> Maybe (Either MatrixError a)+decodeResp :: FromJSON a => ByteString -> Either String (Either MatrixError a) decodeResp resp = case eitherDecode resp of-  Right a -> Just $ pure a-  Left _ -> case eitherDecode resp of-    Right me -> Just $ Left me-    Left _ -> Nothing+  Right a -> Right $ pure a+  Left e -> case eitherDecode resp of+    Right me -> Right $ Left me+    Left _ -> Left e -newtype UserID = UserID Text deriving (Show, Eq)+newtype UserID = UserID Text deriving (Show, Eq, Ord, Hashable)  instance FromJSON UserID where   parseJSON (Object v) = UserID <$> v .: "user_id"@@ -102,11 +108,21 @@   parseJSON _ = mzero  -- | 'MatrixIO' is a convenient type alias for server response-type MatrixIO a = IO (Either MatrixError a)+type MatrixIO a = MatrixM IO a --- | Retry 5 times network action, doubling backoff each time-retry' :: Int -> (Text -> IO ()) -> MatrixIO a -> MatrixIO a-retry' limit logRetry action =+type MatrixM m a = m (Either MatrixError a)++-- | Retry a network action+retryWithLog ::+  (MonadMask m, MonadIO m) =>+  -- | Maximum number of retry+  Int ->+  -- | A log function, can be used to measure errors+  (Text -> m ()) ->+  -- | The action to retry+  MatrixM m a ->+  MatrixM m a+retryWithLog limit logRetry action =   Retry.recovering     (Retry.exponentialBackoff backoff <> Retry.limitRetries limit)     [handler, rateLimitHandler]@@ -118,7 +134,7 @@         Left (MatrixError "M_LIMIT_EXCEEDED" err delayMS) -> do           -- Reponse contains a retry_after_ms           logRetry $ "RateLimit: " <> err <> " (delay: " <> pack (show delayMS) <> ")"-          threadDelay $ fromMaybe 5_000 delayMS * 1000+          liftIO $ threadDelay $ fromMaybe 5_000 delayMS * 1000           throw MatrixRateLimit         _ -> pure res @@ -142,4 +158,4 @@       HTTP.InvalidUrlException _ _ -> pure False  retry :: MatrixIO a -> MatrixIO a-retry = retry' 7 (hPutStrLn stderr)+retry = retryWithLog 7 (hPutStrLn stderr)

@@ -0,0 +1,35 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Matrix room related data types+module Network.Matrix.Room (RoomCreatePreset (..), RoomCreateRequest (..)) where++import Data.Aeson (ToJSON (..), Value (..), genericToJSON)+import qualified Data.Aeson as Aeson+import Data.Aeson.Casing (aesonPrefix, snakeCase)+import Data.Text (Text)+import GHC.Generics (Generic)++-- | https://matrix.org/docs/spec/client_server/latest#post-matrix-client-r0-createroom+data RoomCreatePreset+  = PrivateChat+  | TrustedPrivateChat+  | PublicChat+  deriving (Eq, Show)++instance ToJSON RoomCreatePreset where+  toJSON preset = String $ case preset of+    PrivateChat -> "private_chat"+    TrustedPrivateChat -> "trusted_private_chat"+    PublicChat -> "public_chat"++data RoomCreateRequest = RoomCreateRequest+  { rcrPreset :: RoomCreatePreset,+    rcrRoomAliasName :: Text,+    rcrName :: Text,+    rcrTopic :: Text+  }+  deriving (Eq, Show, Generic)++instance ToJSON RoomCreateRequest where+  toJSON = genericToJSON $ (aesonPrefix snakeCase) {Aeson.omitNothingFields = True}

@@ -22,6 +22,9 @@     -- * Create a session     -- $session +    -- * Get messages+    -- $sync+     -- * Lookup identity     -- $identity   )@@ -47,15 +50,55 @@ --   > getTokenOwner :: ClientSession -> MatrixIO WhoAmI  -- $session---   Most functions require 'ClientSession' which carries the+--   Most functions require 'Network.Matrix.Client.ClientSession' which carries the --   endpoint url and the http client manager. -----   The only way to get the client is through the 'Client.createSession' function:+--   The only way to get the client is through the 'Network.Matrix.Client.createSession' function: -- --   > > token <- getTokenFromEnv "MATRIX_TOKEN" --   > > sess <- createSession "https://matrix.org" token --   > > getTokenOwner sess --   > Right (WhoAmI "@tristanc_:matrix.org")++-- $sync+--   Create a filter to limit the sync result using the 'Network.Matrix.Client.createFilter' function.+--   To keep room message only, use the 'Network.Matrix.Client.messageFilter' default filter:+--+--   > > Right userId <- getTokenOwner sess+--   > > Right filterId <- createFilter sess userId messageFilter+--   > > getFilter sess (UserID "@gerritbot:matrix.org") filterId+--   > Right (Filter {filterEventFields = ...})+--+--   Call the 'Network.Matrix.Client.sync' function to synchronize your client state:+--+--   > > Right syncResult <- sync sess (Just filterId) Nothing (Just Online) Nothing+--   > > putStrLn $ take 512 $ show (getTimelines syncResult)+--   > SyncResult {srNextBatch = ...}+--+--   Get next batch with a 300 second timeout using the @since@ argument:+--+--   > > Right syncResult' <- sync sess (Just filterId) (Just (srNextBatch syncResult)) (Just Online) (Just 300000)+--+--   Here are some helpers function to format the messages from sync results, copy them in your REPL:+--+--   > > import qualified Data.Text.IO as Text+--   > > :{+--   >   let printEvent re = Text.putStrLn $ case reContent re of+--   >         EventRoomMessage (RoomMessageText mt) -> unAuthor (reSender re) <> ": " <> mtBody mt+--   >         _ -> ""+--   >   :}+--   > > let printRoomEvent room event = Text.putStr room >> putStr "| " >> printEvent event+--   > > let printRoomEvents (RoomID room, events) = traverse (printRoomEvent room) events+--   > > let printTimelines sr = mapM_ printRoomEvents (getTimelines sr)+--   > > printTimelines syncResult+--   > ...+--+--   Use the 'Network.Matrix.Client.syncPoll' utility function to continuously get events,+--   here is an example to print new messages, similar to a @tail -f@ process:+--+--   > > syncPoll sess (Just filterId) (Just (srNextBatch syncResult)) (Just Online) printTimelines+--   > room1| test-user: Hello world!+--   > ...  -- $identity --  To use the Identity api you need another token. Get it by running these commands:

@@ -1,6 +0,0 @@-module Main (main) where--import Test.DocTest--main :: IO ()-main = doctest ["src/", "-XOverloadedStrings"]

@@ -6,28 +6,92 @@  import Control.Monad (void) import qualified Data.Aeson.Encode.Pretty as Aeson-import Data.Text (Text)+import qualified Data.ByteString.Lazy as BS+import Data.Either (isLeft)+import Data.Text (Text, pack) import Data.Time.Clock.System (SystemTime (..), getSystemTime) import Network.Matrix.Client import Network.Matrix.Internal+import System.Environment (lookupEnv) import Test.Hspec  main :: IO ()-main = hspec spec+main = do+  env <- fmap (fmap pack) <$> traverse lookupEnv ["HOMESERVER_URL", "PRIMARY_TOKEN", "SECONDARY_TOKEN"]+  runIntegration <- case env of+    [Just url, Just tok1, Just tok2] -> do+      sess1 <- createSession url (MatrixToken tok1)+      sess2 <- createSession url (MatrixToken tok2)+      pure $ integration sess1 sess2+    _ -> do+      putStrLn "Skipping integration test"+      pure $ pure mempty+  hspec (parallel $ spec >> runIntegration) +integration :: ClientSession -> ClientSession -> Spec+integration sess1 sess2 = do+  describe "integration tests" $ do+    it "create room" $ do+      resp <-+        createRoom+          sess1+          ( RoomCreateRequest+              { rcrPreset = PublicChat,+                rcrRoomAliasName = "test",+                rcrName = "matrix-client-haskell-test",+                rcrTopic = "Testing matrix-client-haskell"+              }+          )+      case resp of+        Left err -> meError err `shouldBe` "Alias already exists"+        Right (RoomID roomID) -> roomID `shouldSatisfy` (/= mempty)+    it "join room" $ do+      resp <- joinRoom sess1 "#test:localhost"+      case resp of+        Left err -> error (show err)+        Right (RoomID roomID) -> roomID `shouldSatisfy` (/= mempty)+      resp' <- joinRoom sess2 "#test:localhost"+      case resp' of+        Left err -> error (show err)+        Right (RoomID roomID) -> roomID `shouldSatisfy` (/= mempty)+    it "send message and reply" $ do+      -- Flush previous events+      Right sr <- sync sess2 Nothing Nothing Nothing Nothing+      Right [room] <- getJoinedRooms sess1+      let msg body = RoomMessageText $ MessageText body TextType Nothing Nothing+      let since = srNextBatch sr+      Right eventID <- sendMessage sess1 room (EventRoomMessage $ msg "Hello") (TxnID since)+      Right reply <- sendMessage sess2 room (EventRoomReply eventID $ msg "Hi!") (TxnID since)+      reply `shouldNotBe` eventID+ spec :: Spec spec = describe "unit tests" $ do   it "decode unknown" $-    (decodeResp "" :: Maybe (Either MatrixError String))-      `shouldBe` Nothing+    (decodeResp "" :: Either String (Either MatrixError String))+      `shouldSatisfy` isLeft   it "decode error" $-    (decodeResp "{\"errcode\": \"TEST\", \"error\":\"a error\"}" :: Maybe (Either MatrixError String))-      `shouldBe` (Just . Left $ MatrixError "TEST" "a error" Nothing)+    (decodeResp "{\"errcode\": \"TEST\", \"error\":\"a error\"}" :: Either String (Either MatrixError String))+      `shouldBe` (Right . Left $ MatrixError "TEST" "a error" Nothing)   it "decode response" $     decodeResp "{\"user_id\": \"@tristanc_:matrix.org\"}"-      `shouldBe` (Just . Right $ UserID "@tristanc_:matrix.org")+      `shouldBe` (Right . Right $ UserID "@tristanc_:matrix.org")+  it "decode reply" $ do+    resp <- decodeResp <$> BS.readFile "test/data/message-reply.json"+    case resp of+      Right (Right (EventRoomReply eventID (RoomMessageText message))) -> do+        eventID `shouldBe` EventID "$eventID"+        mtBody message `shouldBe` "> <@tristanc_:matrix.org> :hello\n\nHello there!"+      _ -> error $ show resp+  it "decode edit" $ do+    resp <- decodeResp <$> BS.readFile "test/data/message-edit.json"+    case resp of+      Right (Right (EventRoomEdit (eventID, RoomMessageText srcMsg) (RoomMessageText message))) -> do+        eventID `shouldBe` EventID "$eventID"+        mtBody srcMsg `shouldBe` " * > :typo"+        mtBody message `shouldBe` "> :hello"+      _ -> error $ show resp   it "encode room message" $-    encodePretty (RoomMessageText (MessageText "Hello" Nothing Nothing))+    encodePretty (RoomMessageText (MessageText "Hello" TextType Nothing Nothing))       `shouldBe` "{\"body\":\"Hello\",\"msgtype\":\"m.text\"}"   it "does not retry on success" $     checkPause (<=) $ do@@ -42,7 +106,7 @@   it "retry on rate limit failure" $     checkPause (>=) $ do       let resp = Left $ MatrixError "M_LIMIT_EXCEEDED" "error" (Just 1000)-      (retry' 1 (const $ pure ()) (pure resp) :: MatrixIO Int)+      (retryWithLog 1 (const $ pure ()) (pure resp) :: MatrixIO Int)         `shouldThrow` rateLimitSelector   where     rateLimitSelector :: MatrixException -> Bool

@@ -0,0 +1,16 @@+{+  "body": " * > :typo",+  "format": "org.matrix.custom.html",+  "formatted_body": " * <blockquote>\n:typo\n</blockquote>\n",+  "m.new_content": {+    "body": "> :hello",+    "format": "org.matrix.custom.html",+    "formatted_body": "<blockquote>\n:hello\n</blockquote>\n",+    "msgtype": "m.text"+  },+  "m.relates_to": {+    "event_id": "$eventID",+    "rel_type": "m.replace"+  },+  "msgtype": "m.text"+}

@@ -0,0 +1,11 @@+{+  "body": "> <@tristanc_:matrix.org> :hello\n\nHello there!",+  "format": "org.matrix.custom.html",+  "formatted_body": "<mx-reply><blockquote><a href=\"https://matrix.to/#/!roomID/$eventID?via=matrix.org\">In reply to</a> <a href=\"https://matrix.to/#/@tristanc_:matrix.org\">@tristanc_:matrix.org</a><br>:hello</blockquote></mx-reply>Hello there!",+  "m.relates_to": {+    "m.in_reply_to": {+      "event_id": "$eventID"+    }+  },+  "msgtype": "m.text"+}