never executed always true always false

    1 module PureClaw.Channels.Signal
    2   ( -- * Signal channel
    3     SignalChannel (..)
    4   , SignalConfig (..)
    5   , mkSignalChannel
    6     -- * Message parsing
    7   , parseSignalEnvelope
    8   , SignalEnvelope (..)
    9   , SignalDataMessage (..)
   10   ) where
   11 
   12 import Control.Concurrent.STM
   13 import Data.Aeson
   14 import Data.Text (Text)
   15 import Data.Text qualified as T
   16 
   17 import PureClaw.Channels.Class
   18 import PureClaw.Core.Errors
   19 import PureClaw.Core.Types
   20 import PureClaw.Handles.Channel
   21 import PureClaw.Handles.Log
   22 
   23 -- | Configuration for Signal channel.
   24 newtype SignalConfig = SignalConfig
   25   { _sc_account :: Text
   26   }
   27   deriving stock (Show, Eq)
   28 
   29 -- | A Signal channel backed by a message queue. Messages from signal-cli
   30 -- are pushed into the queue and the agent loop pulls them out via 'receive'.
   31 data SignalChannel = SignalChannel
   32   { _sch_config :: SignalConfig
   33   , _sch_inbox  :: TQueue SignalEnvelope
   34   , _sch_log    :: LogHandle
   35   }
   36 
   37 -- | Create a Signal channel with an empty inbox.
   38 mkSignalChannel :: SignalConfig -> LogHandle -> IO SignalChannel
   39 mkSignalChannel config lh = do
   40   inbox <- newTQueueIO
   41   pure SignalChannel
   42     { _sch_config = config
   43     , _sch_inbox  = inbox
   44     , _sch_log    = lh
   45     }
   46 
   47 instance Channel SignalChannel where
   48   toHandle sc = ChannelHandle
   49     { _ch_receive    = receiveEnvelope sc
   50     , _ch_send       = sendSignalMessage sc
   51     , _ch_sendError  = sendSignalError sc
   52     , _ch_sendChunk  = \_ -> pure ()  -- Signal doesn't support streaming
   53     , _ch_readSecret = ioError (userError "Vault management requires the CLI interface")
   54     }
   55 
   56 -- | Block until a Signal envelope arrives in the queue.
   57 receiveEnvelope :: SignalChannel -> IO IncomingMessage
   58 receiveEnvelope sc = do
   59   envelope <- atomically $ readTQueue (_sch_inbox sc)
   60   let sender = _se_source envelope
   61       content = maybe "" _sdm_message (_se_dataMessage envelope)
   62   pure IncomingMessage
   63     { _im_userId  = UserId sender
   64     , _im_content = content
   65     }
   66 
   67 -- | Send a message via Signal. In a full implementation this would
   68 -- invoke signal-cli. For now, logs the outgoing message.
   69 sendSignalMessage :: SignalChannel -> OutgoingMessage -> IO ()
   70 sendSignalMessage sc msg =
   71   _lh_logInfo (_sch_log sc) $ "Signal send: " <> _om_content msg
   72 
   73 -- | Send an error via Signal.
   74 sendSignalError :: SignalChannel -> PublicError -> IO ()
   75 sendSignalError sc err =
   76   _lh_logWarn (_sch_log sc) $ "Signal error: " <> T.pack (show err)
   77 
   78 -- | A Signal envelope (simplified JSON-RPC format from signal-cli).
   79 data SignalEnvelope = SignalEnvelope
   80   { _se_source      :: Text
   81   , _se_timestamp   :: Int
   82   , _se_dataMessage :: Maybe SignalDataMessage
   83   }
   84   deriving stock (Show, Eq)
   85 
   86 -- | A Signal data message.
   87 data SignalDataMessage = SignalDataMessage
   88   { _sdm_message   :: Text
   89   , _sdm_timestamp :: Int
   90   }
   91   deriving stock (Show, Eq)
   92 
   93 instance FromJSON SignalEnvelope where
   94   parseJSON = withObject "SignalEnvelope" $ \o ->
   95     SignalEnvelope <$> o .: "source" <*> o .: "timestamp" <*> o .:? "dataMessage"
   96 
   97 instance FromJSON SignalDataMessage where
   98   parseJSON = withObject "SignalDataMessage" $ \o ->
   99     SignalDataMessage <$> o .: "message" <*> o .: "timestamp"
  100 
  101 -- | Parse a JSON value as a Signal envelope.
  102 parseSignalEnvelope :: Value -> Either String SignalEnvelope
  103 parseSignalEnvelope v = case fromJSON v of
  104   Error err -> Left err
  105   Success e -> Right e