website: directory page (#6283)

* website: directory page

* core: use markdown in directory entries

* render markdown on directory page

* update markdown

* toggle secrets on click

* update listings asynchronously

* add group links to the listing

* cleanup

* better directory layout with pagination

* script to run website

* update page navigation

* search

* readable markdown colors, better "read less"

* core: atomic update of directory listings, to avoid files unavailable

* fix symlink, sort entries on page with new first

* update listings every 15 min, add activeAt time

* fix sorting in the page and listing url

* replace simplex:/ links on desktop

src/Simplex/Chat/Controller.hs

@@ -62,7 +62,7 @@ import Simplex.Chat.Protocol
 import Simplex.Chat.Remote.AppVersion
 import Simplex.Chat.Remote.Types
 import Simplex.Chat.Stats (PresentedServersSummary)
-import Simplex.Chat.Store (AddressSettings, ChatLockEntity, GroupLink, GroupLinkInfo, StoreError (..), UserContactLink, UserMsgReceiptSettings)
+import Simplex.Chat.Store (AddressSettings, ChatLockEntity, GroupLinkInfo, StoreError (..), UserContactLink, UserMsgReceiptSettings)
 import Simplex.Chat.Types
 import Simplex.Chat.Types.Preferences
 import Simplex.Chat.Types.Shared

src/Simplex/Chat/Store.hs

@@ -6,7 +6,6 @@ module Simplex.Chat.Store
     ChatLockEntity (..),
     UserMsgReceiptSettings (..),
     UserContactLink (..),
-    GroupLink (..),
     GroupLinkInfo (..),
     AddressSettings (..),
     AutoAccept (..),
@@ -16,7 +15,6 @@ module Simplex.Chat.Store
   )
 where
 
-import Simplex.Chat.Store.Groups (GroupLink (..))
 import Simplex.Chat.Store.Profiles
 import Simplex.Chat.Store.Shared
 import Simplex.Messaging.Agent.Store.Common (DBStore (..), withTransaction)

src/Simplex/Chat/Store/Groups.hs

@@ -18,7 +18,6 @@ module Simplex.Chat.Store.Groups
     GroupInfoRow,
     GroupMemberRow,
     MaybeGroupMemberRow,
-    GroupLink (..),
     toGroupInfo,
     toGroupMember,
     toMaybeGroupMember,
@@ -162,7 +161,6 @@ import Control.Monad
 import Control.Monad.Except
 import Control.Monad.IO.Class
 import Crypto.Random (ChaChaDRG)
-import qualified Data.Aeson.TH as J
 import Data.Bifunctor (second)
 import Data.Bitraversable (bitraverse)
 import Data.Char (toLower)
@@ -188,7 +186,6 @@ import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..))
 import qualified Simplex.Messaging.Agent.Store.DB as DB
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.Ratchet (pattern PQEncOff, pattern PQSupportOff)
-import Simplex.Messaging.Parsers (defaultJSON)
 import Simplex.Messaging.Protocol (SubscriptionMode (..))
 import Simplex.Messaging.Util (eitherToMaybe, firstRow', safeDecodeUtf8, ($>>), ($>>=), (<$$>))
 import Simplex.Messaging.Version
@@ -280,16 +277,6 @@ deleteGroupLink db User {userId} GroupInfo {groupId} = do
     (userId, groupId)
   DB.execute db "DELETE FROM user_contact_links WHERE user_id = ? AND group_id = ?" (userId, groupId)
 
-data GroupLink = GroupLink
-  { userContactLinkId :: Int64,
-    connLinkContact :: CreatedLinkContact,
-    shortLinkDataSet :: Bool,
-    shortLinkLargeDataSet :: BoolDef,
-    groupLinkId :: GroupLinkId,
-    acceptMemberRole :: GroupMemberRole
-  }
-  deriving (Show)
-
 getGroupLink :: DB.Connection -> User -> GroupInfo -> ExceptT StoreError IO GroupLink
 getGroupLink db User {userId} gInfo@GroupInfo {groupId} =
   ExceptT . firstRow toGroupLink (SEGroupLinkNotFound gInfo) $
@@ -982,9 +969,12 @@ getUserGroupDetails db vr User {userId, userContactId} _contactId_ search_ = do
     search = maybe "" (map toLower) search_
 
 getUserGroupsWithSummary :: DB.Connection -> VersionRangeChat -> User -> Maybe ContactId -> Maybe String -> IO [GroupInfoSummary]
-getUserGroupsWithSummary db vr user _contactId_ search_ =
-  getUserGroupDetails db vr user _contactId_ search_
-    >>= mapM (\g@GroupInfo {groupId} -> GIS g <$> getGroupSummary db user groupId)
+getUserGroupsWithSummary db vr user _contactId_ search_ = do
+  gs <- getUserGroupDetails db vr user _contactId_ search_
+  forM gs $ \g@GroupInfo {groupId} -> do
+    s <- getGroupSummary db user groupId
+    link_ <- eitherToMaybe <$> runExceptT (getGroupLink db user g)
+    pure $ GIS g s link_
 
 -- the statuses on non-current members should match memberCurrent' function
 getGroupSummary :: DB.Connection -> User -> GroupId -> IO GroupSummary
@@ -2905,5 +2895,3 @@ updateGroupAlias db userId g@GroupInfo {groupId} localAlias = do
   updatedAt <- getCurrentTime
   DB.execute db "UPDATE groups SET local_alias = ?, updated_at = ? WHERE user_id = ? AND group_id = ?" (localAlias, updatedAt, userId, groupId)
   pure (g :: GroupInfo) {localAlias = localAlias}
-
-$(J.deriveJSON defaultJSON ''GroupLink)

src/Simplex/Chat/Store/Messages.hs

@@ -2204,8 +2204,6 @@ updateGroupScopeUnreadStats db vr user g@GroupInfo {membership} scopeInfo (unrea
       m_ <- runExceptT $ getGroupMemberById db vr user groupMemberId
       pure $ either (const m) id m_ -- Left shouldn't happen, but types require it
 
-deriving instance Show BoolInt
-
 setGroupChatItemsDeleteAt :: DB.Connection -> User -> GroupId -> [(ChatItemId, Int)] -> UTCTime -> IO [(ChatItemId, UTCTime)]
 setGroupChatItemsDeleteAt db User {userId} groupId itemIds currentTs = forM itemIds $ \(chatItemId, ttl) -> do
   let deleteAt = addUTCTime (realToFrac ttl) currentTs

src/Simplex/Chat/Types.hs

@@ -527,7 +527,17 @@ data GroupSummary = GroupSummary
   }
   deriving (Show)
 
-data GroupInfoSummary = GIS {groupInfo :: GroupInfo, groupSummary :: GroupSummary}
+data GroupInfoSummary = GIS {groupInfo :: GroupInfo, groupSummary :: GroupSummary, groupLink :: Maybe GroupLink}
+  deriving (Show)
+
+data GroupLink = GroupLink
+  { userContactLinkId :: Int64,
+    connLinkContact :: CreatedLinkContact,
+    shortLinkDataSet :: Bool,
+    shortLinkLargeDataSet :: BoolDef,
+    groupLinkId :: GroupLinkId,
+    acceptMemberRole :: GroupMemberRole
+  }
   deriving (Show)
 
 data ContactOrGroup = CGContact Contact | CGGroup GroupInfo [GroupMember]
@@ -2075,6 +2085,8 @@ $(JQ.deriveJSON defaultJSON ''Group)
 
 $(JQ.deriveJSON defaultJSON ''GroupSummary)
 
+$(JQ.deriveJSON defaultJSON ''GroupLink)
+
 $(JQ.deriveJSON defaultJSON ''GroupInfoSummary)
 
 instance FromField MsgFilter where fromField = fromIntField_ msgFilterIntP

src/Simplex/Chat/View.hs

@@ -50,7 +50,7 @@ import Simplex.Chat.Operators
 import Simplex.Chat.Protocol
 import Simplex.Chat.Remote.AppVersion (AppVersion (..), pattern AppVersionRange)
 import Simplex.Chat.Remote.Types
-import Simplex.Chat.Store (AddressSettings (..), AutoAccept (..), GroupLink (..), StoreError (..), UserContactLink (..))
+import Simplex.Chat.Store (AddressSettings (..), AutoAccept (..), StoreError (..), UserContactLink (..))
 import Simplex.Chat.Styled
 import Simplex.Chat.Types
 import Simplex.Chat.Types.Preferences
@@ -1365,8 +1365,8 @@ viewGroupsList [] = ["you have no groups!", "to create: " <> highlight' "/g <nam
 viewGroupsList gs = map groupSS $ sortOn ldn_ gs
   where
     ldn_ :: GroupInfoSummary -> Text
-    ldn_ (GIS GroupInfo {localDisplayName} _) = T.toLower localDisplayName
-    groupSS (GIS g@GroupInfo {membership, chatSettings = ChatSettings {enableNtfs}} GroupSummary {currentMembers}) =
+    ldn_ (GIS GroupInfo {localDisplayName} _ _) = T.toLower localDisplayName
+    groupSS (GIS g@GroupInfo {membership, chatSettings = ChatSettings {enableNtfs}} GroupSummary {currentMembers} _) =
       case memberStatus membership of
         GSMemInvited -> groupInvitation' g
         s -> membershipIncognito g <> ttyFullGroup g <> viewMemberStatus s <> alias g