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     , _ch_prompt       = \promptText -> do
   55         sendSignalMessage sc (OutgoingMessage promptText)
   56         _im_content <$> receiveEnvelope sc
   57     , _ch_promptSecret = \_ ->
   58         ioError (userError "Vault management requires the CLI interface")
   59     }
   60 
   61 -- | Block until a Signal envelope arrives in the queue.
   62 receiveEnvelope :: SignalChannel -> IO IncomingMessage
   63 receiveEnvelope sc = do
   64   envelope <- atomically $ readTQueue (_sch_inbox sc)
   65   let sender = _se_source envelope
   66       content = maybe "" _sdm_message (_se_dataMessage envelope)
   67   pure IncomingMessage
   68     { _im_userId  = UserId sender
   69     , _im_content = content
   70     }
   71 
   72 -- | Send a message via Signal. In a full implementation this would
   73 -- invoke signal-cli. For now, logs the outgoing message.
   74 sendSignalMessage :: SignalChannel -> OutgoingMessage -> IO ()
   75 sendSignalMessage sc msg =
   76   _lh_logInfo (_sch_log sc) $ "Signal send: " <> _om_content msg
   77 
   78 -- | Send an error via Signal.
   79 sendSignalError :: SignalChannel -> PublicError -> IO ()
   80 sendSignalError sc err =
   81   _lh_logWarn (_sch_log sc) $ "Signal error: " <> T.pack (show err)
   82 
   83 -- | A Signal envelope (simplified JSON-RPC format from signal-cli).
   84 data SignalEnvelope = SignalEnvelope
   85   { _se_source      :: Text
   86   , _se_timestamp   :: Int
   87   , _se_dataMessage :: Maybe SignalDataMessage
   88   }
   89   deriving stock (Show, Eq)
   90 
   91 -- | A Signal data message.
   92 data SignalDataMessage = SignalDataMessage
   93   { _sdm_message   :: Text
   94   , _sdm_timestamp :: Int
   95   }
   96   deriving stock (Show, Eq)
   97 
   98 instance FromJSON SignalEnvelope where
   99   parseJSON = withObject "SignalEnvelope" $ \o ->
  100     SignalEnvelope <$> o .: "source" <*> o .: "timestamp" <*> o .:? "dataMessage"
  101 
  102 instance FromJSON SignalDataMessage where
  103   parseJSON = withObject "SignalDataMessage" $ \o ->
  104     SignalDataMessage <$> o .: "message" <*> o .: "timestamp"
  105 
  106 -- | Parse a JSON value as a Signal envelope.
  107 parseSignalEnvelope :: Value -> Either String SignalEnvelope
  108 parseSignalEnvelope v = case fromJSON v of
  109   Error err -> Left err
  110   Success e -> Right e