Add listing module

CHANGELOG.md

@@ -2,6 +2,7 @@
 
 ## upcoming
 - add `Haboli.Euphoria.Command` module
+- add `Haboli.Euphoria.Listing` module
 - add `Haboli.Euphoria.Util` module and move `respondingToPing` there
 - clean up project
 - fix nick of example bot in readme

haboli.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: e4041146c275e14c632860cfd7af7b3ac3fe6bf5493f57168143777df245a1cf
+-- hash: 67a0b5c2b39acab50a31b3d9efa3e4a48e13f1edd28bdbb23b99fc1c8c30bd3b
 
 name:           haboli
 version:        0.3.1.0
@@ -33,6 +33,7 @@ library
       Haboli.Euphoria.Api
       Haboli.Euphoria.Client
       Haboli.Euphoria.Command
+      Haboli.Euphoria.Listing
       Haboli.Euphoria.Util
   other-modules:
       Paths_haboli

src/Haboli/Euphoria/Api.hs

@@ -194,7 +194,7 @@ data UserType
   -- ^ The client has none of the other user types. While this value does not
   -- occur nowadays, some messages in the room logs are still from a time before
   -- the distinction of user types were introduced.
-  deriving (Show, Eq)
+  deriving (Show, Eq, Ord)
 
 -- | A 'UserId' identifies a user. It consists of two parts: The type of
 -- session, and a unique value for that type of session. See
@@ -202,7 +202,7 @@ data UserType
 data UserId = UserId
   { userType      :: UserType
   , userSnowflake :: Snowflake
-  } deriving (Show, Eq)
+  } deriving (Show, Eq, Ord)
 
 instance ToJSON UserId where
   toJSON uid =

src/Haboli/Euphoria/Listing.hs

@@ -0,0 +1,67 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Haboli.Euphoria.Listing
+  ( Listing
+  , newListing
+  , self
+  , others
+  , updateOwnNick
+  , updateFromList
+  , updateFromEvent
+  ) where
+
+import qualified Data.Map.Strict        as Map
+import           Data.Maybe
+import qualified Data.Text              as T
+
+import           Haboli.Euphoria.Api
+import           Haboli.Euphoria.Client
+
+data Listing = Listing
+  { lsSelf   :: SessionView
+  , lsOthers :: Map.Map UserId SessionView
+  } deriving (Show)
+
+othersFromList :: [SessionView] -> Map.Map UserId SessionView
+othersFromList sessions = Map.fromList [(svId sv, sv) | sv <- sessions]
+
+newListing :: (HelloEvent, SnapshotEvent) -> Listing
+newListing (h, s) = Listing
+  { lsSelf   = helloSessionView h
+  , lsOthers = othersFromList $ snapshotListing s
+  }
+
+self :: Listing -> SessionView
+self = lsSelf
+
+others :: Listing -> Map.Map UserId SessionView
+others = lsOthers
+
+updateOwnNick :: T.Text -> Listing -> Listing
+updateOwnNick name listing = listing{lsSelf = (lsSelf listing){svNick = name}}
+
+updateFromList :: [SessionView] -> Listing -> Listing
+updateFromList sessions listing =
+  let ownId = svId $ lsSelf listing
+      others' = othersFromList sessions
+      newSelf = fromMaybe (lsSelf listing) $ others' Map.!? ownId
+      newOthers = Map.filterWithKey (\k _ -> k /= ownId) others'
+  in  Listing newSelf newOthers
+
+onJoin :: SessionView -> Listing -> Listing
+onJoin sv listing = listing{lsOthers = Map.insert (svId sv) sv $ lsOthers listing}
+
+onPart :: SessionView -> Listing -> Listing
+onPart sv listing = listing{lsOthers = Map.delete (svId sv) $ lsOthers listing}
+
+updateFromEvent :: Event -> Listing -> Listing
+updateFromEvent (EventJoin e) listing = onJoin (joinSession e) listing
+updateFromEvent (EventPart e) listing = onPart (partSession e) listing
+updateFromEvent (EventNetwork e) listing | networkType e == "partition" =
+  let sId = networkServerId e
+      sEra = networkServerEra e
+      isAffected sv = svServerId sv == sId && svServerEra sv == sEra
+      others' = Map.filter (not . isAffected) $ lsOthers listing
+  in  listing{lsOthers = others'}
+updateFromEvent _ listing = listing
+