TLS 1.3 transport (#203)

* TLS as Transport class instance with pre-defined server certificate/key * refactor error logging * remove Ed25519 * refactor TLS.cGet * TLS over TCP for Transport * Plain -> TLS * comment * getLn, change supported cipher * use non fixed certificates * comment * check options earlier * wording * headers * Update apps/smp-server/Main.hs Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> * Update apps/smp-server/Main.hs Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> * localhost -> server * Update apps/smp-server/Main.hs Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> * remove comment * agent key and cert fixtures WIP * certificate and key in correct order * exitFailure * refactor loadServerCertificate * remove liftIO Co-authored-by: Efim Poberezkin <8711996+efim-poberezkin@users.noreply.github.com>
2026-08-29 01:18:40 +00:00 · 2021-12-15 07:48:57 +00:00
parent 7dba734ab8
commit 83d352cfbe
17 changed files with 343 additions and 127 deletions
@@ -105,15 +105,18 @@ runSMPAgent t cfg = do
 -- This function uses passed TMVar to signal when the server is ready to accept TCP requests (True)
 -- and when it is disconnected from the TCP socket once the server thread is killed (False).
 runSMPAgentBlocking :: (MonadRandom m, MonadUnliftIO m) => ATransport -> TMVar Bool -> AgentConfig -> m ()
-runSMPAgentBlocking (ATransport t) started cfg@AgentConfig {tcpPort} = runReaderT (smpAgent t) =<< newSMPAgentEnv cfg
+runSMPAgentBlocking (ATransport t) started cfg@AgentConfig {tcpPort} = do
+  runReaderT (smpAgent t) =<< newSMPAgentEnv cfg
  where
    smpAgent :: forall c m'. (Transport c, MonadUnliftIO m', MonadReader Env m') => TProxy c -> m' ()
-    smpAgent _ = runTransportServer started tcpPort $ \(h :: c) -> do
-      liftIO . putLn h $ "Welcome to SMP agent v" <> currentSMPVersionStr
-      c <- getAgentClient
-      logConnection c True
-      race_ (connectClient h c) (runAgentClient c)
-        `E.finally` disconnectAgentClient c
+    smpAgent _ = do
+      credential <- asks agentCredential
+      runTransportServer started tcpPort credential $ \(h :: c) -> do
+        liftIO . putLn h $ "Welcome to SMP agent v" <> currentSMPVersionStr
+        c <- getAgentClient
+        logConnection c True
+        race_ (connectClient h c) (runAgentClient c)
+          `E.finally` disconnectAgentClient c

 -- | Creates an SMP agent client instance
 getSMPAgentClient :: (MonadRandom m, MonadUnliftIO m) => AgentConfig -> m AgentClient
@@ -10,6 +10,7 @@ import Control.Monad.IO.Unlift
 import Crypto.Random
 import Data.List.NonEmpty (NonEmpty)
 import Network.Socket
+import qualified Network.TLS as T
 import Numeric.Natural
 import Simplex.Messaging.Agent.Protocol (SMPServer)
 import Simplex.Messaging.Agent.RetryInterval
@@ -17,6 +18,7 @@ import Simplex.Messaging.Agent.Store.SQLite
 import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
 import Simplex.Messaging.Client
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Transport (loadServerCredential)
 import System.Random (StdGen, newStdGen)
 import UnliftIO.STM

@@ -31,7 +33,9 @@ data AgentConfig = AgentConfig
    dbPoolSize :: Int,
    smpCfg :: SMPClientConfig,
    retryInterval :: RetryInterval,
-    reconnectInterval :: RetryInterval
+    reconnectInterval :: RetryInterval,
+    agentPrivateKeyFile :: FilePath,
+    agentCertificateFile :: FilePath
  }

 minute :: Int
@@ -60,7 +64,10 @@ defaultAgentConfig =
          { initialInterval = 1_000_000,
            increaseAfter = 10_000_000,
            maxInterval = 10_000_000
-          }
+          },
+      -- ! we do not generate these key and certificate
+      agentPrivateKeyFile = "/etc/opt/simplex-agent/agent.key",
+      agentCertificateFile = "/etc/opt/simplex-agent/agent.crt"
    }

 data Env = Env
@@ -69,7 +76,8 @@ data Env = Env
    idsDrg :: TVar ChaChaDRG,
    clientCounter :: TVar Int,
    reservedMsgSize :: Int,
-    randomServer :: TVar StdGen
+    randomServer :: TVar StdGen,
+    agentCredential :: T.Credential
  }

 newSMPAgentEnv :: (MonadUnliftIO m, MonadRandom m) => AgentConfig -> m Env
@@ -78,7 +86,8 @@ newSMPAgentEnv cfg = do
  store <- liftIO $ createSQLiteStore (dbFile cfg) (dbPoolSize cfg) Migrations.app
  clientCounter <- newTVarIO 0
  randomServer <- newTVarIO =<< liftIO newStdGen
-  return Env {config = cfg, store, idsDrg, clientCounter, reservedMsgSize, randomServer}
+  agentCredential <- liftIO $ loadServerCredential (agentPrivateKeyFile cfg) (agentCertificateFile cfg)
+  return Env {config = cfg, store, idsDrg, clientCounter, reservedMsgSize, randomServer, agentCredential}
  where
    -- 1st rsaKeySize is used by the RSA signature in each command,
    -- 2nd - by encrypted message body header
@@ -64,7 +64,7 @@ import Numeric.Natural
 import Simplex.Messaging.Agent.Protocol (SMPServer (..))
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Protocol
-import Simplex.Messaging.Transport (ATransport (..), TCP, THandle (..), TProxy, Transport (..), TransportError, clientHandshake, runTransportClient)
+import Simplex.Messaging.Transport (ATransport (..), THandle (..), TLS, TProxy, Transport (..), TransportError, clientHandshake, runTransportClient)
 import Simplex.Messaging.Transport.WebSockets (WS)
 import Simplex.Messaging.Util (bshow, liftError, raceAny_)
 import System.Timeout (timeout)
@@ -114,7 +114,7 @@ smpDefaultConfig :: SMPClientConfig
 smpDefaultConfig =
  SMPClientConfig
    { qSize = 16,
-      defaultTransport = ("5223", transport @TCP),
+      defaultTransport = ("5223", transport @TLS),
      tcpTimeout = 4_000_000,
      smpPing = 30_000_000,
      smpBlockSize = Just 8192,
@@ -174,8 +174,8 @@ getSMPClient smpServer cfg@SMPClientConfig {qSize, tcpTimeout, smpPing, smpBlock
    useTransport :: (ServiceName, ATransport)
    useTransport = case port smpServer of
      Nothing -> defaultTransport cfg
-      Just "80" -> ("80", transport @WS)
-      Just p -> (p, transport @TCP)
+      -- Just "80" -> ("80", transport @WS)
+      Just p -> (p, transport @TLS)

    client :: forall c. Transport c => TProxy c -> SMPClient -> TMVar (Either SMPClientError Int) -> c -> IO ()
    client _ c thVar h =
@@ -83,7 +83,9 @@ runSMPServerBlocking started cfg@ServerConfig {transports} = do
        `finally` withLog closeStoreLog

    runServer :: (MonadUnliftIO m', MonadReader Env m') => (ServiceName, ATransport) -> m' ()
-    runServer (tcpPort, ATransport t) = runTransportServer started tcpPort (runClient t)
+    runServer (tcpPort, ATransport t) = do
+      credential <- asks serverCredential
+      runTransportServer started tcpPort credential (runClient t)

    serverThread ::
      forall m' s.
@@ -11,27 +11,30 @@ import Crypto.Random
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
 import Network.Socket (ServiceName)
+import qualified Network.TLS as T
 import Numeric.Natural
-import qualified Simplex.Messaging.Crypto as C
+import qualified Simplex.Messaging.Crypto as C -- TODO delete
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server.MsgStore.STM
 import Simplex.Messaging.Server.QueueStore (QueueRec (..))
 import Simplex.Messaging.Server.QueueStore.STM
 import Simplex.Messaging.Server.StoreLog
-import Simplex.Messaging.Transport (ATransport)
+import Simplex.Messaging.Transport (ATransport, loadServerCredential)
 import System.IO (IOMode (..))
 import UnliftIO.STM

 data ServerConfig = ServerConfig
-  { transports :: [(ServiceName, ATransport)],
-    tbqSize :: Natural,
+  { tbqSize :: Natural,
    msgQueueQuota :: Natural,
    queueIdBytes :: Int,
-    msgIdBytes :: Int, -- must be at least 24 bytes, it is used as 192-bit nonce for XSalsa20
+    msgIdBytes :: Int,
+    transports :: [(ServiceName, ATransport)],
    storeLog :: Maybe (StoreLog 'ReadMode),
    blockSize :: Int,
-    trnSignAlg :: C.SignAlg,
-    serverPrivateKey :: C.PrivateKey 'C.RSA
+    serverPrivateKey :: C.PrivateKey 'C.RSA, -- TODO delete
+    serverPrivateKeyFile :: FilePath,
+    serverCertificateFile :: FilePath,
+    trnSignAlg :: C.SignAlg
  }

 data Env = Env
@@ -40,8 +43,9 @@ data Env = Env
    queueStore :: QueueStore,
    msgStore :: STMMsgStore,
    idsDrg :: TVar ChaChaDRG,
-    serverKeyPair :: C.KeyPair 'C.RSA,
-    storeLog :: Maybe (StoreLog 'WriteMode)
+    serverKeyPair :: C.KeyPair 'C.RSA, -- TODO delete
+    storeLog :: Maybe (StoreLog 'WriteMode),
+    serverCredential :: T.Credential
  }

 data Server = Server
@@ -93,9 +97,10 @@ newEnv config = do
  msgStore <- atomically newMsgStore
  idsDrg <- drgNew >>= newTVarIO
  s' <- restoreQueues queueStore `mapM` storeLog (config :: ServerConfig)
-  let pk = serverPrivateKey config
+  let pk = serverPrivateKey config -- TODO remove
      serverKeyPair = (C.publicKey pk, pk)
-  return Env {config, server, queueStore, msgStore, idsDrg, serverKeyPair, storeLog = s'}
+  serverCredential <- liftIO $ loadServerCredential (serverPrivateKeyFile config) (serverCertificateFile config)
+  return Env {config, server, queueStore, msgStore, idsDrg, serverKeyPair, storeLog = s', serverCredential}
  where
    restoreQueues :: QueueStore -> StoreLog 'ReadMode -> m (StoreLog 'WriteMode)
    restoreQueues queueStore s = do
@@ -5,6 +5,7 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -29,12 +30,13 @@ module Simplex.Messaging.Transport
    TProxy (..),
    ATransport (..),

-    -- * Transport over TCP
+    -- * Transport over TLS 1.3
    runTransportServer,
    runTransportClient,
+    loadServerCredential,

-    -- * TCP transport
-    TCP (..),
+    -- * TLS 1.3 Transport
+    TLS (..),

    -- * SMP encrypted transport
    THandle (..),
@@ -63,6 +65,8 @@ import Data.Bifunctor (first)
 import Data.ByteArray (xor)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy as BL
+import Data.Default (def)
 import Data.Functor (($>))
 import Data.Maybe (fromMaybe)
 import Data.Set (Set)
@@ -74,11 +78,13 @@ import GHC.IO.Exception (IOErrorType (..))
 import GHC.IO.Handle.Internals (ioe_EOF)
 import Generic.Random (genericArbitraryU)
 import Network.Socket
+import qualified Network.TLS as T
+import qualified Network.TLS.Extra as TE
 import Network.Transport.Internal (decodeNum16, decodeNum32, encodeEnum16, encodeEnum32, encodeWord32)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Parsers (parse, parseAll, parseRead1, parseString)
 import Simplex.Messaging.Util (bshow, liftError)
-import System.IO
+import System.Exit (exitFailure)
 import System.IO.Error
 import Test.QuickCheck (Arbitrary (..))
 import UnliftIO.Concurrent
@@ -94,11 +100,11 @@ class Transport c where

  transportName :: TProxy c -> String

-  -- | Upgrade client socket to connection (used in the server)
-  getServerConnection :: Socket -> IO c
+  -- | Upgrade client TLS context to connection (used in the server)
+  getServerConnection :: TLS -> IO c

-  -- | Upgrade server socket to connection (used in the client)
-  getClientConnection :: Socket -> IO c
+  -- | Upgrade server TLS context to connection (used in the client)
+  getClientConnection :: TLS -> IO c

  -- | Close connection
  closeConnection :: c -> IO ()
@@ -120,18 +126,21 @@ data TProxy c = TProxy

 data ATransport = forall c. Transport c => ATransport (TProxy c)

-- * Transport over TCP
+-- * Transport over TLS 1.3

 -- | Run transport server (plain TCP or WebSockets) on passed TCP port and signal when server started and stopped via passed TMVar.
 --
 -- All accepted connections are passed to the passed function.
-runTransportServer :: (Transport c, MonadUnliftIO m) => TMVar Bool -> ServiceName -> (c -> m ()) -> m ()
-runTransportServer started port server = do
+runTransportServer :: (Transport c, MonadUnliftIO m) => TMVar Bool -> ServiceName -> T.Credential -> (c -> m ()) -> m ()
+runTransportServer started port credential server = do
  clients <- newTVarIO S.empty
-  E.bracket (liftIO $ startTCPServer started port) (liftIO . closeServer clients) $ \sock -> forever $ do
-    c <- liftIO $ acceptConnection sock
-    tid <- forkFinally (server c) (const $ liftIO $ closeConnection c)
-    atomically . modifyTVar clients $ S.insert tid
+  E.bracket
+    (liftIO $ startTCPServer started port)
+    (liftIO . closeServer clients)
+    $ \sock -> forever $ do
+      c <- liftIO $ acceptConnection sock
+      tid <- forkFinally (server c) (const $ liftIO $ closeConnection c)
+      atomically . modifyTVar clients $ S.insert tid
  where
    closeServer :: TVar (Set ThreadId) -> Socket -> IO ()
    closeServer clients sock = do
@@ -139,7 +148,10 @@ runTransportServer started port server = do
      close sock
      void . atomically $ tryPutTMVar started False
    acceptConnection :: Transport c => Socket -> IO c
-    acceptConnection sock = accept sock >>= getServerConnection . fst
+    acceptConnection sock = do
+      (newSock, _) <- accept sock
+      let serverParams = mkServerParams credential
+      connectTLS "server" getServerConnection serverParams newSock

 startTCPServer :: TMVar Bool -> ServiceName -> IO Socket
 startTCPServer started port = withSocketsDo $ resolve >>= open >>= setStarted
@@ -182,28 +194,106 @@ startTCPClient host port = withSocketsDo $ resolve >>= tryOpen err
    open addr = do
      sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
      connect sock $ addrAddress addr
-      getClientConnection sock
+      connectTLS "client" getClientConnection clientParams sock

-- * TCP transport
+-- TODO non lazy
+loadServerCredential :: FilePath -> FilePath -> IO T.Credential
+loadServerCredential privateKeyFile certificateFile =
+  T.credentialLoadX509 certificateFile privateKeyFile >>= \case
+    Right cert -> pure cert
+    Left _ -> putStrLn "invalid credential" >> exitFailure

-newtype TCP = TCP {tcpHandle :: Handle}
+-- * TLS 1.3 Transport

-instance Transport TCP where
-  transportName _ = "TCP"
-  getServerConnection = fmap TCP . getSocketHandle
-  getClientConnection = getServerConnection
-  closeConnection (TCP h) = hClose h `E.catch` \(_ :: E.SomeException) -> pure ()
-  cGet = B.hGet . tcpHandle
-  cPut = B.hPut . tcpHandle
-  getLn = fmap trimCR . B.hGetLine . tcpHandle
+data TLS = TLS {tlsContext :: T.Context, buffer :: TVar ByteString, getLock :: TMVar ()}

-getSocketHandle :: Socket -> IO Handle
-getSocketHandle conn = do
-  h <- socketToHandle conn ReadWriteMode
-  hSetBinaryMode h True
-  hSetNewlineMode h NewlineMode {inputNL = CRLF, outputNL = CRLF}
-  hSetBuffering h LineBuffering
-  return h
+connectTLS :: (T.TLSParams p) => String -> (TLS -> IO c) -> p -> Socket -> IO c
+connectTLS party getPartyConnection params sock =
+  E.bracketOnError (T.contextNew sock params) closeTLS $ \tlsContext -> do
+    T.handshake tlsContext
+    buffer <- newTVarIO ""
+    getLock <- newTMVarIO ()
+    getPartyConnection TLS {tlsContext, buffer, getLock}
+      `E.catch` \(e :: E.SomeException) -> putStrLn (party <> " exception: " <> show e) >> E.throwIO e
+
+closeTLS :: T.Context -> IO ()
+closeTLS ctx =
+  (T.bye ctx >> T.contextClose ctx) -- sometimes socket was closed before 'TLS.bye'
+    `E.catch` (\(_ :: E.SomeException) -> pure ()) -- so we catch the 'Broken pipe' error here
+
+mkServerParams :: T.Credential -> T.ServerParams
+mkServerParams credential =
+  def
+    { T.serverWantClientCert = False,
+      T.serverShared = def {T.sharedCredentials = T.Credentials [credential]},
+      T.serverHooks = def,
+      T.serverSupported = supportedParameters
+    }
+
+clientParams :: T.ClientParams
+clientParams =
+  (T.defaultParamsClient "localhost" "5223")
+    { T.clientShared = def,
+      T.clientHooks = def {T.onServerCertificate = \_ _ _ _ -> pure []},
+      T.clientSupported = supportedParameters
+    }
+
+supportedParameters :: T.Supported
+supportedParameters =
+  def
+    { T.supportedVersions = [T.TLS13],
+      T.supportedCiphers = [TE.cipher_TLS13_CHACHA20POLY1305_SHA256],
+      T.supportedHashSignatures = [(T.HashIntrinsic, T.SignatureEd448), (T.HashIntrinsic, T.SignatureEd25519)],
+      T.supportedSecureRenegotiation = False,
+      T.supportedGroups = [T.X448, T.X25519]
+    }
+
+instance Transport TLS where
+  transportName _ = "TLS 1.3"
+  getServerConnection = pure
+  getClientConnection = pure
+  closeConnection tls = closeTLS $ tlsContext tls
+
+  cGet :: TLS -> Int -> IO ByteString
+  cGet TLS {tlsContext, buffer, getLock} n =
+    E.bracket_
+      (atomically $ takeTMVar getLock)
+      (atomically $ putTMVar getLock ())
+      $ do
+        b <- readChunks =<< readTVarIO buffer
+        let (s, b') = B.splitAt n b
+        atomically $ writeTVar buffer b'
+        pure s
+    where
+      readChunks :: ByteString -> IO ByteString
+      readChunks b
+        | B.length b >= n = pure b
+        | otherwise = readChunks . (b <>) =<< T.recvData tlsContext `E.catch` handleEOF
+      handleEOF = \case
+        T.Error_EOF -> E.throwIO TEBadBlock
+        e -> E.throwIO e
+
+  cPut :: TLS -> ByteString -> IO ()
+  cPut tls = T.sendData (tlsContext tls) . BL.fromStrict
+
+  getLn :: TLS -> IO ByteString
+  getLn TLS {tlsContext, buffer, getLock} = do
+    E.bracket_
+      (atomically $ takeTMVar getLock)
+      (atomically $ putTMVar getLock ())
+      $ do
+        b <- readChunks =<< readTVarIO buffer
+        let (s, b') = B.break (== '\n') b
+        atomically $ writeTVar buffer (B.drop 1 b') -- drop '\n' we made a break at
+        pure $ trimCR s
+    where
+      readChunks :: ByteString -> IO ByteString
+      readChunks b
+        | B.elem '\n' b = pure b
+        | otherwise = readChunks . (b <>) =<< T.recvData tlsContext `E.catch` handleEOF
+      handleEOF = \case
+        T.Error_EOF -> E.throwIO TEBadBlock
+        e -> E.throwIO e

 -- | Trim trailing CR from ByteString.
 trimCR :: ByteString -> ByteString
@@ -13,50 +13,50 @@ import Simplex.Messaging.Transport (TProxy, Transport (..), TransportError (..),

 data WS = WS {wsStream :: Stream, wsConnection :: Connection}

-websocketsOpts :: ConnectionOptions
-websocketsOpts =
-  defaultConnectionOptions
-    { connectionCompressionOptions = NoCompression,
-      connectionFramePayloadSizeLimit = SizeLimit 8192,
-      connectionMessageDataSizeLimit = SizeLimit 65536
-    }
+-- websocketsOpts :: ConnectionOptions
+-- websocketsOpts =
+--   defaultConnectionOptions
+--     { connectionCompressionOptions = NoCompression,
+--       connectionFramePayloadSizeLimit = SizeLimit 8192,
+--       connectionMessageDataSizeLimit = SizeLimit 65536
+--     }

-instance Transport WS where
-  transportName :: TProxy WS -> String
-  transportName _ = "WebSockets"
+-- instance Transport WS where
+--   transportName :: TProxy WS -> String
+--   transportName _ = "WebSockets"

-  getServerConnection :: Socket -> IO WS
-  getServerConnection sock = do
-    s <- S.makeSocketStream sock
-    WS s <$> acceptClientRequest s
-    where
-      acceptClientRequest :: Stream -> IO Connection
-      acceptClientRequest s = makePendingConnectionFromStream s websocketsOpts >>= acceptRequest
+--   getServerConnection :: Socket -> IO WS
+--   getServerConnection sock = do
+--     s <- S.makeSocketStream sock
+--     WS s <$> acceptClientRequest s
+--     where
+--       acceptClientRequest :: Stream -> IO Connection
+--       acceptClientRequest s = makePendingConnectionFromStream s websocketsOpts >>= acceptRequest

-  getClientConnection :: Socket -> IO WS
-  getClientConnection sock = do
-    s <- S.makeSocketStream sock
-    WS s <$> sendClientRequest s
-    where
-      sendClientRequest :: Stream -> IO Connection
-      sendClientRequest s = newClientConnection s "" "/" websocketsOpts []
+--   getClientConnection :: Socket -> IO WS
+--   getClientConnection sock = do
+--     s <- S.makeSocketStream sock
+--     WS s <$> sendClientRequest s
+--     where
+--       sendClientRequest :: Stream -> IO Connection
+--       sendClientRequest s = newClientConnection s "" "/" websocketsOpts []

-  closeConnection :: WS -> IO ()
-  closeConnection = S.close . wsStream
+--   closeConnection :: WS -> IO ()
+--   closeConnection = S.close . wsStream

-  cGet :: WS -> Int -> IO ByteString
-  cGet c n = do
-    s <- receiveData (wsConnection c)
-    if B.length s == n
-      then pure s
-      else E.throwIO TEBadBlock
+--   cGet :: WS -> Int -> IO ByteString
+--   cGet c n = do
+--     s <- receiveData (wsConnection c)
+--     if B.length s == n
+--       then pure s
+--       else E.throwIO TEBadBlock

-  cPut :: WS -> ByteString -> IO ()
-  cPut = sendBinaryData . wsConnection
+--   cPut :: WS -> ByteString -> IO ()
+--   cPut = sendBinaryData . wsConnection

-  getLn :: WS -> IO ByteString
-  getLn c = do
-    s <- trimCR <$> receiveData (wsConnection c)
-    if B.null s || B.last s /= '\n'
-      then E.throwIO TEBadBlock
-      else pure $ B.init s
+--   getLn :: WS -> IO ByteString
+--   getLn c = do
+--     s <- trimCR <$> receiveData (wsConnection c)
+--     if B.null s || B.last s /= '\n'
+--       then E.throwIO TEBadBlock
+--       else pure $ B.init s