never executed always true always false

    1 module PureClaw.Channels.Signal.Transport
    2   ( -- * Transport handle (testability seam for signal-cli)
    3     SignalTransport (..)
    4     -- * Real implementation
    5   , mkSignalCliTransport
    6     -- * Mock implementation (for tests)
    7   , mkMockSignalTransport
    8     -- * Message chunking
    9   , chunkMessage
   10   ) where
   11 
   12 import Control.Concurrent.STM
   13 import Data.Aeson
   14 import Data.ByteString.Char8 qualified as BS8
   15 import Data.ByteString.Lazy qualified as BL
   16 import Data.IORef
   17 import Data.Text (Text)
   18 import Data.Text qualified as T
   19 import System.IO
   20 import System.Process.Typed qualified as P
   21 
   22 import PureClaw.Handles.Log
   23 
   24 -- | Transport abstraction over signal-cli. The real implementation spawns
   25 -- signal-cli as a child process and communicates via JSON-RPC over stdio.
   26 -- The mock implementation uses in-memory queues for testing.
   27 data SignalTransport = SignalTransport
   28   { _st_receive :: IO Value
   29     -- ^ Block until a JSON-RPC message arrives from signal-cli
   30   , _st_send    :: Text -> Text -> IO ()
   31     -- ^ Send a message: recipient (E.164) -> body -> IO ()
   32   , _st_close   :: IO ()
   33     -- ^ Shut down the transport (kill signal-cli, close handles)
   34   }
   35 
   36 -- | Create a real transport that spawns @signal-cli jsonRpc@ as a child process.
   37 -- The process runs for the lifetime of the transport. Call '_st_close' to shut down.
   38 mkSignalCliTransport :: Text -> LogHandle -> IO SignalTransport
   39 mkSignalCliTransport account logger = do
   40   let config = P.setStdin P.createPipe
   41              $ P.setStdout P.createPipe
   42              $ P.setStderr P.inherit
   43              $ P.proc "signal-cli"
   44                  [ "--output=json"
   45                  , "--trust-new-identities=always"
   46                  , "-u", T.unpack account
   47                  , "jsonRpc"
   48                  ]
   49   process <- P.startProcess config
   50   let stdinH  = P.getStdin process
   51       stdoutH = P.getStdout process
   52   hSetBuffering stdinH LineBuffering
   53   hSetBuffering stdoutH LineBuffering
   54   _lh_logInfo logger $ "signal-cli started for account " <> account
   55   reqIdRef <- newIORef (0 :: Int)
   56   let recvLoop = do
   57         line <- BS8.hGetLine stdoutH
   58         case eitherDecode (BL.fromStrict line) of
   59           Left err -> do
   60             _lh_logWarn logger $ "signal-cli parse error: " <> T.pack err
   61             recvLoop  -- Skip unparseable lines and try again
   62           Right val -> pure val
   63   pure SignalTransport
   64     { _st_receive = recvLoop
   65     , _st_send = \recipient body -> do
   66         reqId <- atomicModifyIORef' reqIdRef (\n -> (n + 1, n + 1))
   67         let rpcMsg = object
   68               [ "jsonrpc" .= ("2.0" :: Text)
   69               , "method"  .= ("send" :: Text)
   70               , "id"      .= show reqId
   71               , "params"  .= object
   72                   [ "recipient" .= [recipient]
   73                   , "message"   .= body
   74                   ]
   75               ]
   76         _lh_logInfo logger $ "Signal send to " <> recipient <> " (" <> T.pack (show (T.length body)) <> " chars)"
   77         BL.hPut stdinH (encode rpcMsg <> "\n")
   78         hFlush stdinH
   79     , _st_close = do
   80         _lh_logInfo logger "Stopping signal-cli..."
   81         P.stopProcess process
   82     }
   83 
   84 -- | Create a mock transport backed by in-memory queues. Used in tests.
   85 mkMockSignalTransport
   86   :: TQueue Value         -- ^ Incoming messages (simulates signal-cli stdout)
   87   -> TQueue (Text, Text)  -- ^ Outgoing messages (recipient, body) for assertions
   88   -> SignalTransport
   89 mkMockSignalTransport inQueue outQueue = SignalTransport
   90   { _st_receive = atomically $ readTQueue inQueue
   91   , _st_send    = \recipient body ->
   92       atomically $ writeTQueue outQueue (recipient, body)
   93   , _st_close   = pure ()
   94   }
   95 
   96 -- | Split a long message into chunks that fit within a character limit,
   97 -- breaking on paragraph boundaries (double newline) where possible.
   98 chunkMessage :: Int -> Text -> [Text]
   99 chunkMessage limit text
  100   | T.length text <= limit = [text]
  101   | otherwise = go text
  102   where
  103     go remaining
  104       | T.null remaining = []
  105       | T.length remaining <= limit = [remaining]
  106       | otherwise =
  107           let candidate = T.take limit remaining
  108               -- Try to break at a paragraph boundary
  109               breakPoint = case T.breakOnAll "\n\n" candidate of
  110                 [] -> case T.breakOnAll "\n" candidate of
  111                   [] -> limit  -- no good break point, hard cut
  112                   breaks -> T.length (fst (last breaks)) + 1
  113                 breaks -> T.length (fst (last breaks)) + 2
  114               (chunk, rest) = T.splitAt breakPoint remaining
  115           in T.stripEnd chunk : go (T.stripStart rest)