diff --git a/apps/simplex-bot-advanced/Main.hs b/apps/simplex-bot-advanced/Main.hs index 04d8e4ffa..8d596c970 100644 --- a/apps/simplex-bot-advanced/Main.hs +++ b/apps/simplex-bot-advanced/Main.hs @@ -41,7 +41,7 @@ mySquaringBot :: User -> ChatController -> IO () mySquaringBot _user cc = do initializeBotAddress cc race_ (forever $ void getLine) . forever $ do - (_, resp) <- atomically . readTBQueue $ outputQ cc + (_, _, resp) <- atomically . readTBQueue $ outputQ cc case resp of CRContactConnected _ contact _ -> do contactConnected contact diff --git a/apps/simplex-broadcast-bot/src/Broadcast/Bot.hs b/apps/simplex-broadcast-bot/src/Broadcast/Bot.hs index 04b6627f3..afeb116f7 100644 --- a/apps/simplex-broadcast-bot/src/Broadcast/Bot.hs +++ b/apps/simplex-broadcast-bot/src/Broadcast/Bot.hs @@ -35,7 +35,7 @@ broadcastBot :: BroadcastBotOpts -> User -> ChatController -> IO () broadcastBot BroadcastBotOpts {publishers, welcomeMessage, prohibitedMessage} _user cc = do initializeBotAddress cc race_ (forever $ void getLine) . forever $ do - (_, resp) <- atomically . readTBQueue $ outputQ cc + (_, _, resp) <- atomically . readTBQueue $ outputQ cc case resp of CRContactConnected _ ct _ -> do contactConnected ct diff --git a/apps/simplex-chat/Server.hs b/apps/simplex-chat/Server.hs index 6f198340f..d32005e57 100644 --- a/apps/simplex-chat/Server.hs +++ b/apps/simplex-chat/Server.hs @@ -84,7 +84,7 @@ runChatServer ChatServerConfig {chatPort, clientQSize} cc = do >>= processCommand >>= atomically . writeTBQueue sndQ output ChatClient {sndQ} = forever $ do - (_, resp) <- atomically . readTBQueue $ outputQ cc + (_, _, resp) <- atomically . readTBQueue $ outputQ cc atomically $ writeTBQueue sndQ ChatSrvResponse {corrId = Nothing, resp} receive ws ChatClient {rcvQ, sndQ} = forever $ do s <- WS.receiveData ws diff --git a/apps/simplex-directory-service/src/Directory/Service.hs b/apps/simplex-directory-service/src/Directory/Service.hs index 46abc4652..7ed39847a 100644 --- a/apps/simplex-directory-service/src/Directory/Service.hs +++ b/apps/simplex-directory-service/src/Directory/Service.hs @@ -59,7 +59,7 @@ welcomeGetOpts :: IO DirectoryOpts welcomeGetOpts = do appDir <- getAppUserDataDirectory "simplex" opts@DirectoryOpts {coreOptions = CoreChatOpts {dbFilePrefix}, testing} <- getDirectoryOpts appDir "simplex_directory_service" - unless testing $ do + unless testing $ do putStrLn $ "SimpleX Directory Service Bot v" ++ versionNumber putStrLn $ "db: " <> dbFilePrefix <> "_chat.db, " <> dbFilePrefix <> "_agent.db" pure opts @@ -68,7 +68,7 @@ directoryService :: DirectoryStore -> DirectoryOpts -> User -> ChatController -> directoryService st DirectoryOpts {superUsers, serviceName, testing} user@User {userId} cc = do initializeBotAddress' (not testing) cc race_ (forever $ void getLine) . forever $ do - (_, resp) <- atomically . readTBQueue $ outputQ cc + (_, _, resp) <- atomically . readTBQueue $ outputQ cc forM_ (crDirectoryEvent resp) $ \case DEContactConnected ct -> deContactConnected ct DEGroupInvitation {contact = ct, groupInfo = g, fromMemberRole, memberRole} -> deGroupInvitation ct g fromMemberRole memberRole @@ -161,7 +161,7 @@ directoryService st DirectoryOpts {superUsers, serviceName, testing} user@User { badRolesMsg :: GroupRolesStatus -> Maybe String badRolesMsg = \case GRSOk -> Nothing - GRSServiceNotAdmin -> Just "You must have a group *owner* role to register the group" + GRSServiceNotAdmin -> Just "You must have a group *owner* role to register the group" GRSContactNotOwner -> Just "You must grant directory service *admin* role to register the group" GRSBadRoles -> Just "You must have a group *owner* role and you must grant directory service *admin* role to register the group" @@ -352,7 +352,7 @@ directoryService st DirectoryOpts {superUsers, serviceName, testing} user@User { groupRef = groupReference g srvRole = "*" <> B.unpack (strEncode serviceRole) <> "*" suSrvRole = "(" <> serviceName <> " role is changed to " <> srvRole <> ")." - whenContactIsOwner gr action = + whenContactIsOwner gr action = getGroupMember gr >>= mapM_ (\cm@GroupMember {memberRole} -> when (memberRole == GROwner && memberActive cm) action) diff --git a/package.yaml b/package.yaml index 406f9aaba..5c8c11a69 100644 --- a/package.yaml +++ b/package.yaml @@ -19,6 +19,7 @@ dependencies: - attoparsec == 0.14.* - base >= 4.7 && < 5 - base64-bytestring >= 1.0 && < 1.3 + - binary >= 0.8 && < 0.9 - bytestring == 0.11.* - composition == 1.0.* - constraints >= 0.12 && < 0.14 @@ -30,6 +31,7 @@ dependencies: - exceptions == 0.10.* - filepath == 1.4.* - http-types == 0.12.* + - http2 - memory == 0.18.* - mtl == 2.3.* - network >= 3.1.2.7 && < 3.2 diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 338346b65..eda9c371d 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -113,6 +113,7 @@ library Simplex.Chat.Migrations.M20230903_connections_to_subscribe Simplex.Chat.Migrations.M20230913_member_contacts Simplex.Chat.Migrations.M20230914_member_probes + Simplex.Chat.Migrations.M20230922_remote_controller Simplex.Chat.Mobile Simplex.Chat.Mobile.File Simplex.Chat.Mobile.Shared @@ -120,6 +121,8 @@ library Simplex.Chat.Options Simplex.Chat.ProfileGenerator Simplex.Chat.Protocol + Simplex.Chat.Remote + Simplex.Chat.Remote.Types Simplex.Chat.Store Simplex.Chat.Store.Connections Simplex.Chat.Store.Direct @@ -128,6 +131,7 @@ library Simplex.Chat.Store.Messages Simplex.Chat.Store.Migrations Simplex.Chat.Store.Profiles + Simplex.Chat.Store.Remote Simplex.Chat.Store.Shared Simplex.Chat.Styled Simplex.Chat.Terminal @@ -151,6 +155,7 @@ library , attoparsec ==0.14.* , base >=4.7 && <5 , base64-bytestring >=1.0 && <1.3 + , binary ==0.8.* , bytestring ==0.11.* , composition ==1.0.* , constraints >=0.12 && <0.14 @@ -162,6 +167,7 @@ library , exceptions ==0.10.* , filepath ==1.4.* , http-types ==0.12.* + , http2 , memory ==0.18.* , mtl ==2.3.* , network >=3.1.2.7 && <3.2 @@ -199,6 +205,7 @@ executable simplex-bot , attoparsec ==0.14.* , base >=4.7 && <5 , base64-bytestring >=1.0 && <1.3 + , binary ==0.8.* , bytestring ==0.11.* , composition ==1.0.* , constraints >=0.12 && <0.14 @@ -210,6 +217,7 @@ executable simplex-bot , exceptions ==0.10.* , filepath ==1.4.* , http-types ==0.12.* + , http2 , memory ==0.18.* , mtl ==2.3.* , network >=3.1.2.7 && <3.2 @@ -248,6 +256,7 @@ executable simplex-bot-advanced , attoparsec ==0.14.* , base >=4.7 && <5 , base64-bytestring >=1.0 && <1.3 + , binary ==0.8.* , bytestring ==0.11.* , composition ==1.0.* , constraints >=0.12 && <0.14 @@ -259,6 +268,7 @@ executable simplex-bot-advanced , exceptions ==0.10.* , filepath ==1.4.* , http-types ==0.12.* + , http2 , memory ==0.18.* , mtl ==2.3.* , network >=3.1.2.7 && <3.2 @@ -299,6 +309,7 @@ executable simplex-broadcast-bot , attoparsec ==0.14.* , base >=4.7 && <5 , base64-bytestring >=1.0 && <1.3 + , binary ==0.8.* , bytestring ==0.11.* , composition ==1.0.* , constraints >=0.12 && <0.14 @@ -310,6 +321,7 @@ executable simplex-broadcast-bot , exceptions ==0.10.* , filepath ==1.4.* , http-types ==0.12.* + , http2 , memory ==0.18.* , mtl ==2.3.* , network >=3.1.2.7 && <3.2 @@ -349,6 +361,7 @@ executable simplex-chat , attoparsec ==0.14.* , base >=4.7 && <5 , base64-bytestring >=1.0 && <1.3 + , binary ==0.8.* , bytestring ==0.11.* , composition ==1.0.* , constraints >=0.12 && <0.14 @@ -360,6 +373,7 @@ executable simplex-chat , exceptions ==0.10.* , filepath ==1.4.* , http-types ==0.12.* + , http2 , memory ==0.18.* , mtl ==2.3.* , network ==3.1.* @@ -403,6 +417,7 @@ executable simplex-directory-service , attoparsec ==0.14.* , base >=4.7 && <5 , base64-bytestring >=1.0 && <1.3 + , binary ==0.8.* , bytestring ==0.11.* , composition ==1.0.* , constraints >=0.12 && <0.14 @@ -414,6 +429,7 @@ executable simplex-directory-service , exceptions ==0.10.* , filepath ==1.4.* , http-types ==0.12.* + , http2 , memory ==0.18.* , mtl ==2.3.* , network >=3.1.2.7 && <3.2 @@ -476,6 +492,7 @@ test-suite simplex-chat-test , attoparsec ==0.14.* , base >=4.7 && <5 , base64-bytestring >=1.0 && <1.3 + , binary ==0.8.* , bytestring ==0.11.* , composition ==1.0.* , constraints >=0.12 && <0.14 @@ -489,6 +506,7 @@ test-suite simplex-chat-test , filepath ==1.4.* , hspec ==2.11.* , http-types ==0.12.* + , http2 , memory ==0.18.* , mtl ==2.3.* , network ==3.1.* diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index e74eaa0f5..d14ab5970 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -62,6 +62,8 @@ import Simplex.Chat.Messages.CIContent import Simplex.Chat.Options import Simplex.Chat.ProfileGenerator (generateRandomProfile) import Simplex.Chat.Protocol +import Simplex.Chat.Remote +import Simplex.Chat.Remote.Types import Simplex.Chat.Store import Simplex.Chat.Store.Connections import Simplex.Chat.Store.Direct @@ -204,6 +206,8 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen sndFiles <- newTVarIO M.empty rcvFiles <- newTVarIO M.empty currentCalls <- atomically TM.empty + remoteHostSessions <- atomically TM.empty + remoteCtrlSession <- newTVarIO Nothing filesFolder <- newTVarIO optFilesFolder chatStoreChanged <- newTVarIO False expireCIThreads <- newTVarIO M.empty @@ -213,7 +217,7 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen showLiveItems <- newTVarIO False userXFTPFileConfig <- newTVarIO $ xftpFileConfig cfg tempDirectory <- newTVarIO tempDir - pure ChatController {activeTo, firstTime, currentUser, smpAgent, agentAsync, chatStore, chatStoreChanged, idsDrg, inputQ, outputQ, notifyQ, subscriptionMode, chatLock, sndFiles, rcvFiles, currentCalls, config, sendNotification, filesFolder, expireCIThreads, expireCIFlags, cleanupManagerAsync, timedItemThreads, showLiveItems, userXFTPFileConfig, tempDirectory, logFilePath = logFile} + pure ChatController {activeTo, firstTime, currentUser, smpAgent, agentAsync, chatStore, chatStoreChanged, idsDrg, inputQ, outputQ, notifyQ, subscriptionMode, chatLock, sndFiles, rcvFiles, currentCalls, remoteHostSessions, remoteCtrlSession, config, sendNotification, filesFolder, expireCIThreads, expireCIFlags, cleanupManagerAsync, timedItemThreads, showLiveItems, userXFTPFileConfig, tempDirectory, logFilePath = logFile} where configServers :: DefaultAgentServers configServers = @@ -340,12 +344,14 @@ stopChatController ChatController {smpAgent, agentAsync = s, sndFiles, rcvFiles, mapM_ hClose fs atomically $ writeTVar files M.empty -execChatCommand :: ChatMonad' m => ByteString -> m ChatResponse -execChatCommand s = do +execChatCommand :: ChatMonad' m => Maybe RemoteHostId -> ByteString -> m ChatResponse +execChatCommand rh s = do u <- readTVarIO =<< asks currentUser case parseChatCommand s of Left e -> pure $ chatCmdError u e - Right cmd -> execChatCommand_ u cmd + Right cmd -> case rh of + Nothing -> execChatCommand_ u cmd + Just remoteHostId -> execRemoteCommand u remoteHostId (s, cmd) execChatCommand' :: ChatMonad' m => ChatCommand -> m ChatResponse execChatCommand' cmd = asks currentUser >>= readTVarIO >>= (`execChatCommand_` cmd) @@ -353,14 +359,26 @@ execChatCommand' cmd = asks currentUser >>= readTVarIO >>= (`execChatCommand_` c execChatCommand_ :: ChatMonad' m => Maybe User -> ChatCommand -> m ChatResponse execChatCommand_ u cmd = either (CRChatCmdError u) id <$> runExceptT (processChatCommand cmd) +execRemoteCommand :: ChatMonad' m => Maybe User -> RemoteHostId -> (ByteString, ChatCommand) -> m ChatResponse +execRemoteCommand u rh scmd = either (CRChatCmdError u) id <$> runExceptT (withRemoteHostSession rh $ \rhs -> processRemoteCommand rhs scmd) + parseChatCommand :: ByteString -> Either String ChatCommand parseChatCommand = A.parseOnly chatCommandP . B.dropWhileEnd isSpace +-- | Emit local events. toView :: ChatMonad' m => ChatResponse -> m () -toView event = do - q <- asks outputQ - atomically $ writeTBQueue q (Nothing, event) +toView = toView_ Nothing +-- | Used by transport to mark remote events with source. +toViewRemote :: ChatMonad' m => RemoteHostId -> ChatResponse -> m () +toViewRemote = toView_ . Just + +toView_ :: ChatMonad' m => Maybe RemoteHostId -> ChatResponse -> m () +toView_ rh event = do + q <- asks outputQ + atomically $ writeTBQueue q (Nothing, rh, event) + +-- | Chat API commands interpreted in context of a local zone processChatCommand :: forall m. ChatMonad m => ChatCommand -> m ChatResponse processChatCommand = \case ShowActiveUser -> withUser' $ pure . CRActiveUser @@ -1830,6 +1848,24 @@ processChatCommand = \case let pref = uncurry TimedMessagesGroupPreference $ maybe (FEOff, Just 86400) (\ttl -> (FEOn, Just ttl)) ttl_ updateGroupProfileByName gName $ \p -> p {groupPreferences = Just . setGroupPreference' SGFTimedMessages pref $ groupPreferences p} + CreateRemoteHost _displayName -> pure $ chatCmdError Nothing "not supported" + ListRemoteHosts -> pure $ chatCmdError Nothing "not supported" + StartRemoteHost rh -> do + RemoteHost {displayName = _, storePath, caKey, caCert} <- error "TODO: get from DB" + (fingerprint, sessionCreds) <- error "TODO: derive session creds" (caKey, caCert) + _announcer <- async $ error "TODO: run announcer" fingerprint + hostAsync <- async $ error "TODO: runServer" storePath sessionCreds + chatModifyVar remoteHostSessions $ M.insert rh RemoteHostSession {hostAsync, storePath, ctrlClient = undefined} + pure $ chatCmdError Nothing "not supported" + StopRemoteHost _rh -> pure $ chatCmdError Nothing "not supported" + DisposeRemoteHost _rh -> pure $ chatCmdError Nothing "not supported" + RegisterRemoteCtrl _displayName _oobData -> pure $ chatCmdError Nothing "not supported" + ListRemoteCtrls -> pure $ chatCmdError Nothing "not supported" + StartRemoteCtrl -> pure $ chatCmdError Nothing "not supported" + ConfirmRemoteCtrl _rc -> pure $ chatCmdError Nothing "not supported" + RejectRemoteCtrl _rc -> pure $ chatCmdError Nothing "not supported" + StopRemoteCtrl _rc -> pure $ chatCmdError Nothing "not supported" + DisposeRemoteCtrl _rc -> pure $ chatCmdError Nothing "not supported" QuitChat -> liftIO exitSuccess ShowVersion -> do let versionInfo = coreVersionInfo $(simplexmqCommitQ) @@ -5599,6 +5635,17 @@ chatCommandP = "/set disappear @" *> (SetContactTimedMessages <$> displayName <*> optional (A.space *> timedMessagesEnabledP)), "/set disappear " *> (SetUserTimedMessages <$> (("yes" $> True) <|> ("no" $> False))), ("/incognito" <* optional (A.space *> onOffP)) $> ChatHelp HSIncognito, + "/create remote host" *> (CreateRemoteHost <$> textP), + "/list remote hosts" $> ListRemoteHosts, + "/start remote host " *> (StartRemoteHost <$> A.decimal), + "/stop remote host " *> (StopRemoteHost <$> A.decimal), + "/dispose remote host " *> (DisposeRemoteHost <$> A.decimal), + "/register remote ctrl " *> (RegisterRemoteCtrl <$> textP <*> remoteHostOOBP), + "/start remote ctrl" $> StartRemoteCtrl, + "/confirm remote ctrl " *> (ConfirmRemoteCtrl <$> A.decimal), + "/reject remote ctrl " *> (RejectRemoteCtrl <$> A.decimal), + "/stop remote ctrl " *> (StopRemoteCtrl <$> A.decimal), + "/dispose remote ctrl " *> (DisposeRemoteCtrl <$> A.decimal), ("/quit" <|> "/q" <|> "/exit") $> QuitChat, ("/version" <|> "/v") $> ShowVersion, "/debug locks" $> DebugLocks, @@ -5716,6 +5763,7 @@ chatCommandP = srvCfgP = strP >>= \case AProtocolType p -> APSC p <$> (A.space *> jsonP) toServerCfg server = ServerCfg {server, preset = False, tested = Nothing, enabled = True} char_ = optional . A.char + remoteHostOOBP = RemoteHostOOB <$> textP adminContactReq :: ConnReqContact adminContactReq = diff --git a/src/Simplex/Chat/Bot.hs b/src/Simplex/Chat/Bot.hs index ecd1659bc..c5c5ff7ee 100644 --- a/src/Simplex/Chat/Bot.hs +++ b/src/Simplex/Chat/Bot.hs @@ -25,7 +25,7 @@ chatBotRepl :: String -> (Contact -> String -> IO String) -> User -> ChatControl chatBotRepl welcome answer _user cc = do initializeBotAddress cc race_ (forever $ void getLine) . forever $ do - (_, resp) <- atomically . readTBQueue $ outputQ cc + (_, _, resp) <- atomically . readTBQueue $ outputQ cc case resp of CRContactConnected _ contact _ -> do contactConnected contact diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 2c829e4a9..c6405990a 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -46,6 +46,7 @@ import Simplex.Chat.Markdown (MarkdownList) import Simplex.Chat.Messages import Simplex.Chat.Messages.CIContent import Simplex.Chat.Protocol +import Simplex.Chat.Remote.Types import Simplex.Chat.Store (AutoAccept, StoreError, UserContactLink, UserMsgReceiptSettings) import Simplex.Chat.Types import Simplex.Chat.Types.Preferences @@ -173,7 +174,7 @@ data ChatController = ChatController chatStoreChanged :: TVar Bool, -- if True, chat should be fully restarted idsDrg :: TVar ChaChaDRG, inputQ :: TBQueue String, - outputQ :: TBQueue (Maybe CorrId, ChatResponse), + outputQ :: TBQueue (Maybe CorrId, Maybe RemoteHostId, ChatResponse), notifyQ :: TBQueue Notification, sendNotification :: Notification -> IO (), subscriptionMode :: TVar SubscriptionMode, @@ -181,6 +182,8 @@ data ChatController = ChatController sndFiles :: TVar (Map Int64 Handle), rcvFiles :: TVar (Map Int64 Handle), currentCalls :: TMap ContactId Call, + remoteHostSessions :: TMap RemoteHostId RemoteHostSession, -- All the active remote hosts + remoteCtrlSession :: TVar (Maybe RemoteCtrlSession), -- Supervisor process for hosted controllers config :: ChatConfig, filesFolder :: TVar (Maybe FilePath), -- path to files folder for mobile apps, expireCIThreads :: TMap UserId (Maybe (Async ())), @@ -410,6 +413,18 @@ data ChatCommand | SetUserTimedMessages Bool -- UserId (not used in UI) | SetContactTimedMessages ContactName (Maybe TimedMessagesEnabled) | SetGroupTimedMessages GroupName (Maybe Int) + | CreateRemoteHost Text -- ^ Configure a new remote host + | ListRemoteHosts + | StartRemoteHost RemoteHostId -- ^ Start and announce a remote host + | StopRemoteHost RemoteHostId -- ^ Shut down a running session + | DisposeRemoteHost RemoteHostId -- ^ Unregister remote host and remove its data + | RegisterRemoteCtrl Text RemoteHostOOB -- ^ Register OOB data for satellite discovery and handshake + | StartRemoteCtrl -- ^ Start listening for announcements from all registered controllers + | ListRemoteCtrls + | ConfirmRemoteCtrl RemoteCtrlId -- ^ Confirm discovered data and store confirmation + | RejectRemoteCtrl RemoteCtrlId -- ^ Reject discovered data (and blacklist?) + | StopRemoteCtrl RemoteCtrlId -- ^ Stop listening for announcements or terminate an active session + | DisposeRemoteCtrl RemoteCtrlId -- ^ Remove all local data associated with a satellite session | QuitChat | ShowVersion | DebugLocks @@ -580,6 +595,17 @@ data ChatResponse | CRNtfMessages {user_ :: Maybe User, connEntity :: Maybe ConnectionEntity, msgTs :: Maybe UTCTime, ntfMessages :: [NtfMsgInfo]} | CRNewContactConnection {user :: User, connection :: PendingContactConnection} | CRContactConnectionDeleted {user :: User, connection :: PendingContactConnection} + | CRRemoteHostCreated {remoteHostId :: RemoteHostId, oobData :: RemoteHostOOB} + | CRRemoteHostList {remoteHosts :: [RemoteHostInfo]} -- XXX: RemoteHostInfo is mostly concerned with session setup + | CRRemoteHostStarted {remoteHostId :: RemoteHostId} + | CRRemoteHostStopped {remoteHostId :: RemoteHostId} + | CRRemoteHostDisposed {remoteHostId :: RemoteHostId} + | CRRemoteCtrlList {remoteCtrls :: [RemoteCtrlInfo]} + | CRRemoteCtrlRegistered {remoteCtrlId :: RemoteCtrlId} + | CRRemoteCtrlAccepted {remoteCtrlId :: RemoteCtrlId} + | CRRemoteCtrlRejected {remoteCtrlId :: RemoteCtrlId} + | CRRemoteCtrlConnected {remoteCtrlId :: RemoteCtrlId} + | CRRemoteCtrlDisconnected {remoteCtrlId :: RemoteCtrlId} | CRSQLResult {rows :: [Text]} | CRSlowSQLQueries {chatQueries :: [SlowSQLQuery], agentQueries :: [SlowSQLQuery]} | CRDebugLocks {chatLockName :: Maybe String, agentLocks :: AgentLocks} @@ -616,10 +642,32 @@ logResponseToFile = \case CRMessageError {} -> True _ -> False +instance FromJSON ChatResponse where + parseJSON todo = pure $ CRCmdOk Nothing -- TODO: actually use the instances + instance ToJSON ChatResponse where toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "CR" toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "CR" +data RemoteHostOOB = RemoteHostOOB + { fingerprint :: Text -- CA key fingerprint + } + deriving (Show, Generic, ToJSON) + +data RemoteHostInfo = RemoteHostInfo + { remoteHostId :: RemoteHostId, + displayName :: Text, + sessionActive :: Bool + } + deriving (Show, Generic, ToJSON) + +data RemoteCtrlInfo = RemoteCtrlInfo + { remoteCtrlId :: RemoteCtrlId, + displayName :: Text, + sessionActive :: Bool + } + deriving (Show, Generic, ToJSON) + newtype UserPwd = UserPwd {unUserPwd :: Text} deriving (Eq, Show) @@ -858,6 +906,8 @@ data ChatError | ChatErrorAgent {agentError :: AgentErrorType, connectionEntity_ :: Maybe ConnectionEntity} | ChatErrorStore {storeError :: StoreError} | ChatErrorDatabase {databaseError :: DatabaseError} + | ChatErrorRemoteCtrl {remoteCtrlId :: RemoteCtrlId, remoteControllerError :: RemoteCtrlError} + | ChatErrorRemoteHost {remoteHostId :: RemoteHostId, remoteHostError :: RemoteHostError} deriving (Show, Exception, Generic) instance ToJSON ChatError where @@ -967,6 +1017,41 @@ instance ToJSON SQLiteError where throwDBError :: ChatMonad m => DatabaseError -> m () throwDBError = throwError . ChatErrorDatabase +-- TODO review errors, some of it can be covered by HTTP2 errors +data RemoteHostError + = RHMissing -- ^ No remote session matches this identifier + | RHBusy -- ^ A session is already running + | RHRejected -- ^ A session attempt was rejected by a host + | RHTimeout -- ^ A discovery or a remote operation has timed out + | RHDisconnected {reason :: Text} -- ^ A session disconnected by a host + | RHConnectionLost {reason :: Text} -- ^ A session disconnected due to transport issues + deriving (Show, Exception, Generic) + +instance FromJSON RemoteHostError where + parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "RH" + +instance ToJSON RemoteHostError where + toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "RH" + toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "RH" + +-- TODO review errors, some of it can be covered by HTTP2 errors +data RemoteCtrlError + = RCEMissing -- ^ No remote session matches this identifier + | RCEBusy -- ^ A session is already running + | RCETimeout -- ^ Remote operation timed out + | RCEDisconnected {reason :: Text} -- ^ A session disconnected by a controller + | RCEConnectionLost {reason :: Text} -- ^ A session disconnected due to transport issues + | RCECertificateExpired -- ^ A connection or CA certificate in a chain have bad validity period + | RCECertificateUntrusted -- ^ TLS is unable to validate certificate chain presented for a connection + deriving (Show, Exception, Generic) + +instance FromJSON RemoteCtrlError where + parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "RCE" + +instance ToJSON RemoteCtrlError where + toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "RCE" + toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "RCE" + type ChatMonad' m = (MonadUnliftIO m, MonadReader ChatController m) type ChatMonad m = (ChatMonad' m, MonadError ChatError m) @@ -979,6 +1064,10 @@ chatWriteVar :: ChatMonad' m => (ChatController -> TVar a) -> a -> m () chatWriteVar f value = asks f >>= atomically . (`writeTVar` value) {-# INLINE chatWriteVar #-} +chatModifyVar :: ChatMonad' m => (ChatController -> TVar a) -> (a -> a) -> m () +chatModifyVar f newValue = asks f >>= atomically . (`modifyTVar'` newValue) +{-# INLINE chatModifyVar #-} + tryChatError :: ChatMonad m => m a -> m (Either ChatError a) tryChatError = tryAllErrors mkChatError {-# INLINE tryChatError #-} diff --git a/src/Simplex/Chat/Core.hs b/src/Simplex/Chat/Core.hs index 4af161ab4..5f5a27e77 100644 --- a/src/Simplex/Chat/Core.hs +++ b/src/Simplex/Chat/Core.hs @@ -40,7 +40,7 @@ runSimplexChat ChatOpts {maintenance} u cc chat waitEither_ a1 a2 sendChatCmdStr :: ChatController -> String -> IO ChatResponse -sendChatCmdStr cc s = runReaderT (execChatCommand . encodeUtf8 $ T.pack s) cc +sendChatCmdStr cc s = runReaderT (execChatCommand Nothing . encodeUtf8 $ T.pack s) cc sendChatCmd :: ChatController -> ChatCommand -> IO ChatResponse sendChatCmd cc cmd = runReaderT (execChatCommand' cmd) cc diff --git a/src/Simplex/Chat/Migrations/M20230922_remote_controller.hs b/src/Simplex/Chat/Migrations/M20230922_remote_controller.hs new file mode 100644 index 000000000..070a4e35c --- /dev/null +++ b/src/Simplex/Chat/Migrations/M20230922_remote_controller.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Chat.Migrations.M20230922_remote_controller where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +m20230922_remote_controller :: Query +m20230922_remote_controller = + [sql| +CREATE TABLE remote_hosts ( -- hosts known to a controlling app + remote_host_id INTEGER PRIMARY KEY, + display_name TEXT NOT NULL, + store_path TEXT NOT NULL, + ca_cert BLOB NOT NULL, + ca_key BLOB NOT NULL +); + +CREATE TABLE remote_controllers ( -- controllers known to a hosting app + remote_controller_id INTEGER PRIMARY KEY, + display_name TEXT NOT NULL, + fingerprint BLOB NOT NULL +); +|] + +down_m20230922_remote_controller :: Query +down_m20230922_remote_controller = + [sql| +DROP TABLE remote_hosts; +DROP TABLE remote_controllers; +|] diff --git a/src/Simplex/Chat/Migrations/chat_schema.sql b/src/Simplex/Chat/Migrations/chat_schema.sql index 141247e59..292fcf32f 100644 --- a/src/Simplex/Chat/Migrations/chat_schema.sql +++ b/src/Simplex/Chat/Migrations/chat_schema.sql @@ -515,6 +515,20 @@ CREATE TABLE IF NOT EXISTS "received_probes"( created_at TEXT CHECK(created_at NOT NULL), updated_at TEXT CHECK(updated_at NOT NULL) ); +CREATE TABLE remote_hosts( + -- hosts known to a controlling app + remote_host_id INTEGER PRIMARY KEY, + display_name TEXT NOT NULL, + store_path TEXT NOT NULL, + ca_cert BLOB NOT NULL, + ca_key BLOB NOT NULL +); +CREATE TABLE remote_controllers( + -- controllers known to a hosting app + remote_controller_id INTEGER PRIMARY KEY, + display_name TEXT NOT NULL, + fingerprint BLOB NOT NULL +); CREATE INDEX contact_profiles_index ON contact_profiles( display_name, full_name diff --git a/src/Simplex/Chat/Mobile.hs b/src/Simplex/Chat/Mobile.hs index 700548bb1..664412c58 100644 --- a/src/Simplex/Chat/Mobile.hs +++ b/src/Simplex/Chat/Mobile.hs @@ -3,6 +3,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fobject-code #-} module Simplex.Chat.Mobile where @@ -37,6 +38,7 @@ import Simplex.Chat.Mobile.File import Simplex.Chat.Mobile.Shared import Simplex.Chat.Mobile.WebRTC import Simplex.Chat.Options +import Simplex.Chat.Remote.Types import Simplex.Chat.Store import Simplex.Chat.Store.Profiles import Simplex.Chat.Types @@ -55,6 +57,8 @@ foreign export ccall "chat_migrate_init" cChatMigrateInit :: CString -> CString foreign export ccall "chat_send_cmd" cChatSendCmd :: StablePtr ChatController -> CString -> IO CJSONString +foreign export ccall "chat_send_remote_cmd" cChatSendRemoteCmd :: StablePtr ChatController -> CInt -> CString -> IO CJSONString + foreign export ccall "chat_recv_msg" cChatRecvMsg :: StablePtr ChatController -> IO CJSONString foreign export ccall "chat_recv_msg_wait" cChatRecvMsgWait :: StablePtr ChatController -> CInt -> IO CJSONString @@ -102,6 +106,14 @@ cChatSendCmd cPtr cCmd = do cmd <- B.packCString cCmd newCStringFromLazyBS =<< chatSendCmd c cmd +-- | send command to chat (same syntax as in terminal for now) +cChatSendRemoteCmd :: StablePtr ChatController -> CInt -> CString -> IO CJSONString +cChatSendRemoteCmd cPtr cRemoteHostId cCmd = do + c <- deRefStablePtr cPtr + cmd <- B.packCString cCmd + let rhId = Just $ fromIntegral cRemoteHostId + newCStringFromLazyBS =<< chatSendRemoteCmd c rhId cmd + -- | receive message from chat (blocking) cChatRecvMsg :: StablePtr ChatController -> IO CJSONString cChatRecvMsg cc = deRefStablePtr cc >>= chatRecvMsg >>= newCStringFromLazyBS @@ -195,13 +207,16 @@ chatMigrateInit dbFilePrefix dbKey confirm = runExceptT $ do _ -> dbError e dbError e = Left . DBMErrorSQL dbFile $ show e -chatSendCmd :: ChatController -> ByteString -> IO JSONByteString -chatSendCmd cc s = J.encode . APIResponse Nothing <$> runReaderT (execChatCommand s) cc +chatSendCmd :: ChatController -> B.ByteString -> IO JSONByteString +chatSendCmd cc = chatSendRemoteCmd cc Nothing + +chatSendRemoteCmd :: ChatController -> Maybe RemoteHostId -> B.ByteString -> IO JSONByteString +chatSendRemoteCmd cc rh s = J.encode . APIResponse Nothing rh <$> runReaderT (execChatCommand rh s) cc chatRecvMsg :: ChatController -> IO JSONByteString chatRecvMsg ChatController {outputQ} = json <$> atomically (readTBQueue outputQ) where - json (corr, resp) = J.encode APIResponse {corr, resp} + json (corr, remoteHostId, resp) = J.encode APIResponse {corr, remoteHostId, resp} chatRecvMsgWait :: ChatController -> Int -> IO JSONByteString chatRecvMsgWait cc time = fromMaybe "" <$> timeout time (chatRecvMsg cc) @@ -227,7 +242,7 @@ chatPasswordHash pwd salt = either (const "") passwordHash salt' salt' = U.decode salt passwordHash = U.encode . C.sha512Hash . (pwd <>) -data APIResponse = APIResponse {corr :: Maybe CorrId, resp :: ChatResponse} +data APIResponse = APIResponse {corr :: Maybe CorrId, remoteHostId :: Maybe RemoteHostId, resp :: ChatResponse} deriving (Generic) instance ToJSON APIResponse where diff --git a/src/Simplex/Chat/Remote.hs b/src/Simplex/Chat/Remote.hs new file mode 100644 index 000000000..ba543e33f --- /dev/null +++ b/src/Simplex/Chat/Remote.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Simplex.Chat.Remote where + +import Control.Monad.Except +import Control.Monad.IO.Class +import qualified Data.Aeson as J +import Data.ByteString.Char8 (ByteString) +import qualified Data.Map.Strict as M +import qualified Data.Binary.Builder as Binary +import qualified Network.HTTP.Types as HTTP +import qualified Network.HTTP2.Client as HTTP2Client +import Simplex.Chat.Controller +import Simplex.Chat.Remote.Types +import Simplex.Chat.Types +import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..)) +import qualified Simplex.Messaging.Transport.HTTP2.Client as HTTP2 +import Simplex.Messaging.Util (bshow) +import System.Directory (getFileSize) + +withRemoteHostSession :: ChatMonad m => RemoteHostId -> (RemoteHostSession -> m a) -> m a +withRemoteHostSession remoteHostId action = do + chatReadVar remoteHostSessions >>= maybe err action . M.lookup remoteHostId + where + err = throwError $ ChatErrorRemoteHost remoteHostId RHMissing + +processRemoteCommand :: ChatMonad m => RemoteHostSession -> (ByteString, ChatCommand) -> m ChatResponse +processRemoteCommand rhs = \case + -- XXX: intercept and filter some commands + -- TODO: store missing files on remote host + (s, _cmd) -> relayCommand rhs s + +relayCommand :: ChatMonad m => RemoteHostSession -> ByteString -> m ChatResponse +relayCommand RemoteHostSession {ctrlClient} s = postBytestring Nothing ctrlClient "/relay" mempty s >>= \case + Left e -> error "TODO: http2chatError" + Right HTTP2.HTTP2Response {respBody = HTTP2Body {bodyHead}} -> do + remoteChatResponse <- + if iTax then + case J.eitherDecodeStrict bodyHead of -- XXX: large JSONs can overflow into buffered chunks + Left e -> error "TODO: json2chatError" e + Right (raw :: J.Value) -> case J.fromJSON (sum2tagged raw) of + J.Error e -> error "TODO: json2chatError" e + J.Success cr -> pure cr + else + case J.eitherDecodeStrict bodyHead of -- XXX: large JSONs can overflow into buffered chunks + Left e -> error "TODO: json2chatError" e + Right cr -> pure cr + case remoteChatResponse of + -- TODO: intercept file responses and fetch files when needed + -- XXX: is that even possible, to have a file response to a command? + _ -> pure remoteChatResponse + where + iTax = True -- TODO: get from RemoteHost + -- XXX: extract to http2 transport + postBytestring timeout c path hs body = liftIO $ HTTP2.sendRequest c req timeout + where + req = HTTP2Client.requestBuilder "POST" path hs (Binary.fromByteString body) + +storeRemoteFile :: ChatMonad m => RemoteHostSession -> FilePath -> m ChatResponse +storeRemoteFile RemoteHostSession {ctrlClient} localFile = do + postFile Nothing ctrlClient "/store" mempty localFile >>= \case + Left e -> error "TODO: http2chatError" + Right HTTP2.HTTP2Response { response } -> case HTTP.statusCode <$> HTTP2Client.responseStatus response of + Just 200 -> pure $ CRCmdOk Nothing + unexpected -> error "TODO: http2chatError" + where + postFile timeout c path hs file = liftIO $ do + fileSize <- fromIntegral <$> getFileSize file + HTTP2.sendRequest c (req fileSize) timeout + where + req size = HTTP2Client.requestFile "POST" path hs (HTTP2Client.FileSpec file 0 size) + +fetchRemoteFile :: ChatMonad m => RemoteHostSession -> FileTransferId -> m ChatResponse +fetchRemoteFile RemoteHostSession {ctrlClient, storePath} remoteFileId = do + liftIO (HTTP2.sendRequest ctrlClient req Nothing) >>= \case + Left e -> error "TODO: http2chatError" + Right HTTP2.HTTP2Response {respBody} -> do + error "TODO: stream body into a local file" -- XXX: consult headers for a file name? + where + req = HTTP2Client.requestNoBody "GET" path mempty + path = "/fetch/" <> bshow remoteFileId + +-- | Convert swift single-field sum encoding into tagged/discriminator-field +sum2tagged :: J.Value -> J.Value +sum2tagged = \case + J.Object todo'convert -> J.Object todo'convert + skip -> skip diff --git a/src/Simplex/Chat/Remote/Types.hs b/src/Simplex/Chat/Remote/Types.hs new file mode 100644 index 000000000..8e705d5d2 --- /dev/null +++ b/src/Simplex/Chat/Remote/Types.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +module Simplex.Chat.Remote.Types where + +import Control.Concurrent.Async (Async) +import Data.ByteString.Char8 (ByteString) +import Data.Int (Int64) +import Data.Text (Text) +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client) + +type RemoteHostId = Int64 + +data RemoteHost = RemoteHost + { remoteHostId :: RemoteHostId, + displayName :: Text, + -- | Path to store replicated files + storePath :: FilePath, + -- | A stable part of X509 credentials used to access the host + caCert :: ByteString, + -- | Credentials signing key for root and session certs + caKey :: C.Key + } + +type RemoteCtrlId = Int + +data RemoteCtrl = RemoteCtrl + { remoteCtrlId :: RemoteCtrlId, + displayName :: Text, + fingerprint :: Text + } + +data RemoteHostSession = RemoteHostSession + { -- | process to communicate with the host + hostAsync :: Async (), + -- | Path for local resources to be synchronized with host + storePath :: FilePath, + ctrlClient :: HTTP2Client + } + +-- | Host-side dual to RemoteHostSession, on-methods represent HTTP API. +data RemoteCtrlSession = RemoteCtrlSession + { -- | process to communicate with the remote controller + ctrlAsync :: Async () + -- server :: HTTP2Server + } diff --git a/src/Simplex/Chat/Store/Migrations.hs b/src/Simplex/Chat/Store/Migrations.hs index d8bab817e..759244f01 100644 --- a/src/Simplex/Chat/Store/Migrations.hs +++ b/src/Simplex/Chat/Store/Migrations.hs @@ -81,6 +81,7 @@ import Simplex.Chat.Migrations.M20230829_connections_chat_vrange import Simplex.Chat.Migrations.M20230903_connections_to_subscribe import Simplex.Chat.Migrations.M20230913_member_contacts import Simplex.Chat.Migrations.M20230914_member_probes +import Simplex.Chat.Migrations.M20230922_remote_controller import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..)) schemaMigrations :: [(String, Query, Maybe Query)] @@ -161,7 +162,8 @@ schemaMigrations = ("20230829_connections_chat_vrange", m20230829_connections_chat_vrange, Just down_m20230829_connections_chat_vrange), ("20230903_connections_to_subscribe", m20230903_connections_to_subscribe, Just down_m20230903_connections_to_subscribe), ("20230913_member_contacts", m20230913_member_contacts, Just down_m20230913_member_contacts), - ("20230914_member_probes", m20230914_member_probes, Just down_m20230914_member_probes) + ("20230914_member_probes", m20230914_member_probes, Just down_m20230914_member_probes), + ("20230922_remote_controller", m20230922_remote_controller, Just down_m20230922_remote_controller) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Chat/Store/Remote.hs b/src/Simplex/Chat/Store/Remote.hs new file mode 100644 index 000000000..12fcb6c08 --- /dev/null +++ b/src/Simplex/Chat/Store/Remote.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Simplex.Chat.Store.Remote where + +import Data.ByteString.Char8 (ByteString) +import Data.Int (Int64) +import Data.Text (Text) +import qualified Database.SQLite.Simple as DB +import Simplex.Chat.Remote.Types (RemoteHostId, RemoteHost (..)) +import Simplex.Messaging.Agent.Store.SQLite (maybeFirstRow) +import qualified Simplex.Messaging.Crypto as C + +getRemoteHosts :: DB.Connection -> IO [RemoteHost] +getRemoteHosts db = + map toRemoteHost <$> DB.query_ db remoteHostQuery + +getRemoteHost :: DB.Connection -> RemoteHostId -> IO (Maybe RemoteHost) +getRemoteHost db remoteHostId = + maybeFirstRow toRemoteHost $ + DB.query db (remoteHostQuery <> "WHERE remote_host_id = ?") (DB.Only remoteHostId) + +remoteHostQuery :: DB.Query +remoteHostQuery = "SELECT remote_host_id, display_name, store_path, ca_cert, ca_key FROM remote_hosts" + +toRemoteHost :: (Int64, Text, FilePath, ByteString, C.Key) -> RemoteHost +toRemoteHost (remoteHostId, displayName, storePath, caCert, caKey) = + RemoteHost {remoteHostId, displayName, storePath, caCert, caKey} diff --git a/src/Simplex/Chat/Terminal/Input.hs b/src/Simplex/Chat/Terminal/Input.hs index 8841f15ff..1097a7954 100644 --- a/src/Simplex/Chat/Terminal/Input.hs +++ b/src/Simplex/Chat/Terminal/Input.hs @@ -56,7 +56,7 @@ runInputLoop ct@ChatTerminal {termState, liveMessageState} cc = forever $ do let bs = encodeUtf8 $ T.pack s cmd = parseChatCommand bs unless (isMessage cmd) $ echo s - r <- runReaderT (execChatCommand bs) cc + r <- runReaderT (execChatCommand Nothing bs) cc case r of CRChatCmdError _ _ -> when (isMessage cmd) $ echo s CRChatError _ _ -> when (isMessage cmd) $ echo s diff --git a/src/Simplex/Chat/Terminal/Output.hs b/src/Simplex/Chat/Terminal/Output.hs index db6f16f3c..74bb9e8c0 100644 --- a/src/Simplex/Chat/Terminal/Output.hs +++ b/src/Simplex/Chat/Terminal/Output.hs @@ -112,7 +112,7 @@ withTermLock ChatTerminal {termLock} action = do runTerminalOutput :: ChatTerminal -> ChatController -> IO () runTerminalOutput ct cc@ChatController {outputQ, showLiveItems, logFilePath} = do forever $ do - (_, r) <- atomically $ readTBQueue outputQ + (_, _, r) <- atomically $ readTBQueue outputQ case r of CRNewChatItem _ ci -> markChatItemRead ci CRChatItemUpdated _ ci -> markChatItemRead ci diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index 93964316c..a228055ad 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -10,13 +10,13 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE OverloadedRecordDot #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 5db0c317e..1f110fc95 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -297,6 +297,7 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView CRChatError u e -> ttyUser' u $ viewChatError logLevel e CRArchiveImported archiveErrs -> if null archiveErrs then ["ok"] else ["archive import errors: " <> plain (show archiveErrs)] CRTimedAction _ _ -> [] + todo'cr -> ["TODO" <> sShow todo'cr] where ttyUser :: User -> [StyledString] -> [StyledString] ttyUser user@User {showNtfs, activeUser} ss @@ -1677,6 +1678,8 @@ viewChatError logLevel = \case Nothing -> "" cId :: Connection -> StyledString cId conn = sShow conn.connId + ChatErrorRemoteCtrl remoteCtrlId todo'rc -> [sShow remoteCtrlId, sShow todo'rc] + ChatErrorRemoteHost remoteHostId todo'rh -> [sShow remoteHostId, sShow todo'rh] where fileNotFound fileId = ["file " <> sShow fileId <> " not found"] sqliteError' = \case