diff --git a/migrations/20220101_initial.sql b/migrations/20220101_initial.sql index f1ea5f67e..2abd3ce52 100644 --- a/migrations/20220101_initial.sql +++ b/migrations/20220101_initial.sql @@ -1,6 +1,6 @@ CREATE TABLE servers ( host TEXT NOT NULL, - port TEXT, + port TEXT NOT NULL, key_hash BLOB NOT NULL, PRIMARY KEY (host, port) ) WITHOUT ROWID; @@ -19,7 +19,7 @@ CREATE TABLE connections ( CREATE TABLE rcv_queues ( host TEXT NOT NULL, - port TEXT, + port TEXT NOT NULL, rcv_id BLOB NOT NULL, conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE, rcv_private_key BLOB NOT NULL, @@ -39,7 +39,7 @@ CREATE TABLE rcv_queues ( CREATE TABLE snd_queues ( host TEXT NOT NULL, - port TEXT, + port TEXT NOT NULL, snd_id BLOB NOT NULL, conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE, snd_private_key BLOB NOT NULL, diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 69adeb4c4..8cddbc5f4 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -300,7 +300,8 @@ logServer dir AgentClient {clientId} srv qId cmdStr = logInfo . decodeUtf8 $ B.unwords ["A", "(" <> bshow clientId <> ")", dir, showServer srv, ":", logSecret qId, cmdStr] showServer :: SMPServer -> ByteString -showServer srv = B.pack $ host srv <> maybe "" (":" <>) (port srv) +showServer SMPServer {host, port} = + B.pack $ host <> if null port then "" else ':' : port logSecret :: ByteString -> ByteString logSecret bs = encode $ B.take 3 bs diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 3c1b73114..d6f11dffd 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -579,7 +579,7 @@ instance StrEncoding ConnReqScheme where <|> "https://" *> (CRSAppServer <$> strP) simplexChat :: ConnReqScheme -simplexChat = CRSAppServer $ SrvLoc "simplex.chat" Nothing +simplexChat = CRSAppServer $ SrvLoc "simplex.chat" "" -- | SMP queue status. data QueueStatus diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 46977aeeb..92eaf120a 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -164,9 +164,9 @@ getSMPClient smpServer cfg@SMPClientConfig {qSize, tcpTimeout, smpPing} msgQ dis useTransport :: (ServiceName, ATransport) useTransport = case port smpServer of - Nothing -> defaultTransport cfg - Just "80" -> ("80", transport @WS) - Just p -> (p, transport @TLS) + "" -> defaultTransport cfg + "80" -> ("80", transport @WS) + p -> (p, transport @TLS) client :: forall c. Transport c => TProxy c -> SMPClient -> TMVar (Either SMPClientError (THandle c)) -> c -> IO () client _ c thVar h = diff --git a/src/Simplex/Messaging/Crypto/Ratchet.hs b/src/Simplex/Messaging/Crypto/Ratchet.hs index 35540337f..4d967dd4f 100644 --- a/src/Simplex/Messaging/Crypto/Ratchet.hs +++ b/src/Simplex/Messaging/Crypto/Ratchet.hs @@ -24,6 +24,7 @@ import qualified Data.Aeson as J import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as LB +import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Maybe (fromMaybe) @@ -71,11 +72,11 @@ data E2ERatchetParamsUri (a :: Algorithm) instance AlgorithmI a => StrEncoding (E2ERatchetParamsUri a) where strEncode (E2ERatchetParamsUri vs key1 key2) = strEncode $ - QSP QNoEscaping [("v", strEncode vs), ("x3dh", strEncode [key1, key2])] + QSP QNoEscaping [("v", strEncode vs), ("x3dh", strEncodeList [key1, key2])] strP = do query <- strP vs <- queryParam "v" query - keys <- queryParam "x3dh" query + keys <- L.toList <$> queryParam "x3dh" query case keys of [key1, key2] -> pure $ E2ERatchetParamsUri vs key1 key2 _ -> fail "bad e2e params" diff --git a/src/Simplex/Messaging/Encoding.hs b/src/Simplex/Messaging/Encoding.hs index e2f4486ab..9fc1a59fe 100644 --- a/src/Simplex/Messaging/Encoding.hs +++ b/src/Simplex/Messaging/Encoding.hs @@ -11,6 +11,8 @@ module Simplex.Messaging.Encoding ( Encoding (..), Tail (..), Large (..), + smpEncodeList, + smpListP, ) where @@ -111,12 +113,18 @@ instance (Encoding a, Encoding b) => Encoding (a, b) where smpP = (,) <$> smpP <*> smpP -- lists encode/parse as a sequence of items prefixed with list length (as 1 byte) -instance Encoding a => Encoding [a] where - smpEncode xs = B.cons (lenEncode $ length xs) . B.concat $ map smpEncode xs - smpP = (`A.count` smpP) =<< lenP +smpEncodeList :: Encoding a => [a] -> ByteString +smpEncodeList xs = B.cons (lenEncode $ length xs) . B.concat $ map smpEncode xs + +smpListP :: Encoding a => Parser [a] +smpListP = (`A.count` smpP) =<< lenP + +instance Encoding String where + smpEncode = smpEncode . B.pack + smpP = B.unpack <$> smpP instance Encoding a => Encoding (L.NonEmpty a) where - smpEncode = smpEncode . L.toList + smpEncode = smpEncodeList . L.toList smpP = lenP >>= \case 0 -> fail "empty list" diff --git a/src/Simplex/Messaging/Encoding/String.hs b/src/Simplex/Messaging/Encoding/String.hs index 0f440af26..9e7d32c3f 100644 --- a/src/Simplex/Messaging/Encoding/String.hs +++ b/src/Simplex/Messaging/Encoding/String.hs @@ -9,6 +9,8 @@ module Simplex.Messaging.Encoding.String strToJEncoding, strParseJSON, base64urlP, + strEncodeList, + strListP, ) where @@ -75,14 +77,15 @@ instance StrEncoding Word16 where strP = A.decimal -- lists encode/parse as comma-separated strings -instance StrEncoding a => StrEncoding [a] where - strEncode = B.intercalate "," . map strEncode - strP = listItem `A.sepBy'` A.char ',' +strEncodeList :: StrEncoding a => [a] -> ByteString +strEncodeList = B.intercalate "," . map strEncode +strListP :: StrEncoding a => Parser [a] +strListP = listItem `A.sepBy'` A.char ',' + +-- relies on sepBy1 never returning an empty list instance StrEncoding a => StrEncoding (L.NonEmpty a) where - strEncode = strEncode . L.toList - - -- relies on sepBy1 never returning an empty list + strEncode = strEncodeList . L.toList strP = L.fromList <$> listItem `A.sepBy1'` A.char ',' listItem :: StrEncoding a => Parser a diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index 2fdcb1fe1..a9eb0f64a 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -87,7 +87,7 @@ module Simplex.Messaging.Protocol ) where -import Control.Applicative (optional) +import Control.Applicative (optional, (<|>)) import Control.Monad.Except import Data.Attoparsec.ByteString.Char8 (Parser) import qualified Data.Attoparsec.ByteString.Char8 as A @@ -368,7 +368,7 @@ instance Encoding ClientMessage where -- | SMP server location and transport key digest (hash). data SMPServer = SMPServer { host :: HostName, - port :: Maybe ServiceName, + port :: ServiceName, keyHash :: C.KeyHash } deriving (Eq, Ord, Show) @@ -392,12 +392,12 @@ instance StrEncoding SMPServer where SrvLoc host port <- strP pure SMPServer {host, port, keyHash} -data SrvLoc = SrvLoc HostName (Maybe ServiceName) +data SrvLoc = SrvLoc HostName ServiceName deriving (Eq, Ord, Show) instance StrEncoding SrvLoc where - strEncode (SrvLoc host port) = B.pack $ host <> maybe "" (':' :) port - strP = SrvLoc <$> host <*> optional port + strEncode (SrvLoc host port) = B.pack $ host <> if null port then "" else ':' : port + strP = SrvLoc <$> host <*> (port <|> pure "") where host = B.unpack <$> A.takeWhile1 (A.notInClass ":#,;/ ") port = B.unpack <$> (A.char ':' *> A.takeWhile1 A.isDigit) diff --git a/tests/AgentTests/ConnectionRequestTests.hs b/tests/AgentTests/ConnectionRequestTests.hs index 93c073dfb..cbab22793 100644 --- a/tests/AgentTests/ConnectionRequestTests.hs +++ b/tests/AgentTests/ConnectionRequestTests.hs @@ -22,7 +22,7 @@ srv :: SMPServer srv = SMPServer { host = "smp.simplex.im", - port = Just "5223", + port = "5223", keyHash = C.KeyHash "\215m\248\251" } @@ -77,15 +77,15 @@ connectionRequestTests :: Spec connectionRequestTests = describe "connection request parsing / serializing" $ do it "should serialize SMP queue URIs" $ do - strEncode (queue :: SMPQueueUri) {smpServer = srv {port = Nothing}} + strEncode (queue :: SMPQueueUri) {smpServer = srv {port = ""}} `shouldBe` "smp://1234-w==@smp.simplex.im/3456-w==#" <> testDhKeyStr strEncode queue {clientVRange = mkVersionRange 1 2} `shouldBe` "smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr it "should parse SMP queue URIs" $ do strDecode ("smp://1234-w==@smp.simplex.im/3456-w==#/?v=1&dh=" <> testDhKeyStr) - `shouldBe` Right (queue :: SMPQueueUri) {smpServer = srv {port = Nothing}} + `shouldBe` Right (queue :: SMPQueueUri) {smpServer = srv {port = ""}} strDecode ("smp://1234-w==@smp.simplex.im/3456-w==#" <> testDhKeyStr) - `shouldBe` Right (queue :: SMPQueueUri) {smpServer = srv {port = Nothing}} + `shouldBe` Right (queue :: SMPQueueUri) {smpServer = srv {port = ""}} strDecode ("smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr) `shouldBe` Right queue strDecode ("smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr <> "/?v=1&extra_param=abc") diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index 2bbbbe884..2c339a118 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -158,7 +158,7 @@ testDhSecret = "01234567890123456789012345678901" rcvQueue1 :: RcvQueue rcvQueue1 = RcvQueue - { server = SMPServer "smp.simplex.im" (Just "5223") testKeyHash, + { server = SMPServer "smp.simplex.im" "5223" testKeyHash, rcvId = "1234", rcvPrivateKey = testPrivateSignKey, rcvDhSecret = testDhSecret, @@ -171,7 +171,7 @@ rcvQueue1 = sndQueue1 :: SndQueue sndQueue1 = SndQueue - { server = SMPServer "smp.simplex.im" (Just "5223") testKeyHash, + { server = SMPServer "smp.simplex.im" "5223" testKeyHash, sndId = "3456", sndPrivateKey = testPrivateSignKey, e2eDhSecret = testDhSecret, @@ -247,7 +247,7 @@ testCreateSndConnDuplicate = testGetRcvConn :: SpecWith SQLiteStore testGetRcvConn = it "should get connection using rcv queue id and server" $ \store -> do - let smpServer = SMPServer "smp.simplex.im" (Just "5223") testKeyHash + let smpServer = SMPServer "smp.simplex.im" "5223" testKeyHash let recipientId = "1234" g <- newTVarIO =<< drgNew _ <- runExceptT $ createRcvConn store g cData1 rcvQueue1 SCMInvitation @@ -301,7 +301,7 @@ testUpgradeRcvConnToDuplex = _ <- runExceptT $ createSndConn store g cData1 sndQueue1 let anotherSndQueue = SndQueue - { server = SMPServer "smp.simplex.im" (Just "5223") testKeyHash, + { server = SMPServer "smp.simplex.im" "5223" testKeyHash, sndId = "2345", sndPrivateKey = testPrivateSignKey, e2eDhSecret = testDhSecret, @@ -320,7 +320,7 @@ testUpgradeSndConnToDuplex = _ <- runExceptT $ createRcvConn store g cData1 rcvQueue1 SCMInvitation let anotherRcvQueue = RcvQueue - { server = SMPServer "smp.simplex.im" (Just "5223") testKeyHash, + { server = SMPServer "smp.simplex.im" "5223" testKeyHash, rcvId = "3456", rcvPrivateKey = testPrivateSignKey, rcvDhSecret = testDhSecret, diff --git a/tests/SMPAgentClient.hs b/tests/SMPAgentClient.hs index f3d952738..4379908e3 100644 --- a/tests/SMPAgentClient.hs +++ b/tests/SMPAgentClient.hs @@ -173,7 +173,7 @@ cfg = withSmpAgentThreadOn_ :: (MonadUnliftIO m, MonadRandom m) => ATransport -> (ServiceName, ServiceName, String) -> m () -> (ThreadId -> m a) -> m a withSmpAgentThreadOn_ t (port', smpPort', db') afterProcess = - let cfg' = cfg {tcpPort = port', dbFile = db', smpServers = L.fromList [SMPServer "localhost" (Just smpPort') testKeyHash]} + let cfg' = cfg {tcpPort = port', dbFile = db', smpServers = L.fromList [SMPServer "localhost" smpPort' testKeyHash]} in serverBracket (\started -> runSMPAgentBlocking t started cfg') afterProcess