simple MQTT publish/subscribe over TLS shebang programs written in Haskell

MqttPublish.hs

#! /usr/bin/env nix-shell
#! nix-shell -I nixpkgs=https://github.com/NixOS/nixpkgs/archive/cbe419ed4c8f98bd82d169c321d339ea30904f1f.tar.gz --tarball-ttl 4294967295
#! nix-shell -p "haskellPackages.ghcWithPackages (p: with p; [net-mqtt data-default])"
#! nix-shell -i "runhaskell -Wall"

--    This program builds itself and publishes given message to MQTT broker.
--    Copyright (C) 2024  Alexander Tomokhov
--
--    This program is free software: you can redistribute it and/or modify
--    it under the terms of the GNU General Public License as published by
--    the Free Software Foundation, either version 3 of the License, or
--    (at your option) any later version.
--
--    This program is distributed in the hope that it will be useful,
--    but WITHOUT ANY WARRANTY; without even the implied warranty of
--    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--    GNU General Public License for more details.
--
--    You should have received a copy of the GNU General Public License
--    along with this program.  If not, see <https://www.gnu.org/licenses/>.

{-# LANGUAGE BangPatterns #-}

module MqttPublish where

import Data.Default (def)
import Data.Maybe (fromJust)
import Data.X509
import Network.Connection (TLSSettings (..))
import Network.MQTT.Client
import Network.MQTT.Topic (unTopic, mkTopic)
import Network.TLS
import Network.TLS.Extra.Cipher (ciphersuite_default)
import Network.URI (parseURI, URI)
import System.Environment (getArgs)
import qualified Data.ByteString.Lazy.Char8 as B
import qualified Data.Text as T

mqttRetainFlag :: Bool
mqttRetainFlag = False

tlsClientParams :: (CertificateChain, PrivKey) -> ClientParams
tlsClientParams creds = (defaultParamsClient "" mempty)
  { clientHooks = def { onCertificateRequest = \_ -> return (Just creds)
                      , onServerCertificate = \_ _ _ _ -> return []
                      }
  , clientSupported = def { supportedCiphers = ciphersuite_default }
  }

parseArgs :: [String] -> (URI, FilePath, FilePath, Topic, B.ByteString)
parseArgs [brokerAddr, certFile, keyFile, topic, msg] =
  ( fromJust $ parseURI $ "mqtts://" ++ brokerAddr
  , certFile, keyFile, fromJust $ mkTopic $ T.pack topic, B.pack msg
  )
parseArgs _ = error
  "Error. Incorrect number of arguments given!\n\n\
  \mqttPublish <BROKER_ADDR> <CERT_FILE> <KEY_FILE> <TOPIC> <MSG>\n\
  \mqttPublish mqtt.aws.com\
  \ cert key topic\
  \ {\"keyA\":\"value1\",\
  \\"keyB\":\"value2\",\
  \\"keyC\":\"value3\"}\n"

main :: IO ()
main = do
  (!brokerURI, !crtFile, !keyFile, !topic, !msg) <- parseArgs <$> getArgs
  tlsCreds <- either error id `fmap` credentialLoadX509 crtFile keyFile

  mc <- connectURI
    (mqttConfig { _protocol = Protocol50
                , _tlsSettings = TLSSettings (tlsClientParams tlsCreds)
                })
    brokerURI
  putStrLn $ "connected to " ++ show brokerURI

  gotSrvProps <- svrProps mc
  putStrLn $ "server props: " ++ show gotSrvProps

  publish mc topic msg mqttRetainFlag
  putStrLn $ "published to topic \""
    ++ T.unpack (unTopic topic) ++ "\":\n" ++ B.unpack msg ++ "\n"

  normalDisconnect mc
  putStrLn "normal disconnect"

  waitForClient mc

MqttSubscribe.hs

#! /usr/bin/env nix-shell
#! nix-shell -I nixpkgs=https://github.com/NixOS/nixpkgs/archive/cbe419ed4c8f98bd82d169c321d339ea30904f1f.tar.gz --tarball-ttl 4294967295
#! nix-shell -p "haskellPackages.ghcWithPackages (p: with p; [net-mqtt data-default])"
#! nix-shell -i "runhaskell -Wall"

--    This program builds itself and publishes given message to MQTT broker.
--    Copyright (C) 2024  Alexander Tomokhov
--
--    This program is free software: you can redistribute it and/or modify
--    it under the terms of the GNU General Public License as published by
--    the Free Software Foundation, either version 3 of the License, or
--    (at your option) any later version.
--
--    This program is distributed in the hope that it will be useful,
--    but WITHOUT ANY WARRANTY; without even the implied warranty of
--    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--    GNU General Public License for more details.
--
--    You should have received a copy of the GNU General Public License
--    along with this program.  If not, see <https://www.gnu.org/licenses/>.

{-# LANGUAGE BangPatterns #-}

module MqttSubscribe where

import Control.Concurrent.MVar (newMVar, withMVar)
import Data.Default (def)
import Data.X509
import Network.Connection (TLSSettings (..))
import Network.MQTT.Client
import Network.MQTT.Topic (Filter, unTopic, mkFilter)
import Network.TLS
import Network.TLS.Extra.Cipher (ciphersuite_default)
import Network.URI (parseURI, URI)
import System.Environment (getArgs)
import qualified Data.Text as T
import Data.Maybe (fromJust)

import qualified Data.ByteString.Lazy.Char8 as B
import Data.ByteString.Lazy.Char8 (ByteString)

tlsClientParams :: (CertificateChain, PrivKey) -> ClientParams
tlsClientParams creds = (defaultParamsClient "" mempty)
  { clientHooks = def { onCertificateRequest = \_ -> return (Just creds)
                      , onServerCertificate = \_ _ _ _ -> return []
                      }
  , clientSupported = def { supportedCiphers = ciphersuite_default }
  }

printMqttMessage :: Topic -> ByteString -> [Property] -> IO ()
printMqttMessage t m ps = putStrLn $ topic ++ props ++ message
  where
    topic = "| " ++ T.unpack (unTopic t) ++ " -> "
    message = "  " ++ B.unpack m ++ "\n"
    props = if null ps then "" else show ps ++ "\n"

parseArgs :: [String] -> (URI, FilePath, FilePath, Filter)
parseArgs [brokerAddr, certFile, keyFile, topicFilter] =
  ( fromJust $ parseURI $ "mqtts://" ++ brokerAddr
  , certFile, keyFile, fromJust $ mkFilter $ T.pack topicFilter
  )
parseArgs _ = error
  "Error. Incorrect number of arguments given!\n\n\
  \mqttSubscribe <BROKER_ADDR> <CERT_FILE> <KEY_FILE> <TOPIC_FILTER>\n\
  \mqttSubscribe mqtt.aws.com tls.crt tls.key topic/filter\n"

main :: IO ()
main = do
  (!brokerURI, !crtFile, !keyFile, !topicFilter) <- parseArgs <$> getArgs
  tlsCreds <- either error id `fmap` credentialLoadX509 crtFile keyFile
  printLock <- newMVar () -- for printing exactly one message at a time

  let
    showme _ t m ps =
      withMVar printLock
      $ \_ -> printMqttMessage t m ps

  mc <- connectURI
    (mqttConfig { _lwt = Nothing -- no Last Will and Testament MQTT message
                , _msgCB = OrderedCallback showme
                , _protocol = Protocol50
                , _connProps = [ PropTopicAliasMaximum 100
                               , PropRequestResponseInformation 1
                               , PropRequestProblemInformation 1
                               ]
                , _tlsSettings = TLSSettings (tlsClientParams tlsCreds)
                })
    brokerURI
  putStrLn $ "connected to " ++ show brokerURI

  gotSrvProps <- svrProps mc
  putStrLn $ "server props: " ++ show gotSrvProps

  ([eQoS], topicProps) <- subscribe mc [(topicFilter, subOptions)] mempty
  case eQoS of
    Left err -> error $ "cannot connect to topic: " ++ show err
    Right topicQoS -> putStrLn $ "topic QoS: " ++ show topicQoS
  putStrLn $
    "subscribed to topic "
    ++ show topicFilter ++ " with props " ++ show topicProps
  putChar '\n'

  waitForClient mc

Usage:

1. install Nix
2. $ chmod +x Mqtt{Publish,Subscribe}.hs
3. $ ./MqttSubscribe.hs
4. $ ./MqttPublish.hs

Useful function to retrieve CN from certificate:

getCnFromChain :: CertificateChain -> String
getCnFromChain =
  B.unpack . B.fromStrict . fromMaybeAsn1 . getMaybeAsn . fstCertFromChain
  where
    fstCertFromChain (CertificateChain (signed:_)) = getCertificate signed
    fstCertFromChain _ = error "no certificates in chain"
    getMaybeAsn cert = getDnElement DnCommonName $ certSubjectDN cert
    fromMaybeAsn1 (Just asn) = getCharacterStringRawData asn
    fromMaybeAsn1 Nothing = error "certificate has no CN"

Usage:

  cuid = getCnFromChain (fst tlsCreds)