TLSTalk.hs

   1 -- This file is part of htalkat
   2 -- Copyright (C) 2021 Martin Bays <mbays@sdf.org>
   3 --
   4 -- This program is free software: you can redistribute it and/or modify
   5 -- it under the terms of version 3 of the GNU General Public License as
   6 -- published by the Free Software Foundation, or any later version.
   7 --
   8 -- You should have received a copy of the GNU General Public License
   9 -- along with this program.  If not, see http://www.gnu.org/licenses/.
  10
  11 {-# LANGUAGE LambdaCase        #-}
  12 {-# LANGUAGE OverloadedStrings #-}
  13
  14 module TLSTalk
  15     ( SocksProxy(..)
  16     , answerLast
  17     , connect
  18     , serve
  19     , spawnDefaultInteractiveClient
  20     ) where
  21
  22 import           Control.Concurrent
  23 import           Control.Exception
  24 import           Control.Monad            (void, (<=<))
  25 import           Data.Default.Class       (def)
  26 import           Data.X509.Validation     (FailedReason (..), defaultChecks,
  27                                            defaultHooks, validate)
  28 import           Network.Simple.TCP       (connectSock, connectSockSOCKS5)
  29 import           Network.TLS              as TLS
  30 import           Network.TLS.Extra.Cipher
  31 import           System.Directory         (createDirectoryIfMissing)
  32 import           System.Exit              (exitFailure)
  33 import           System.FileLock          (SharedExclusive (..), withFileLock,
  34                                            withTryFileLock)
  35 import           System.FilePath
  36 import           System.IO                (IOMode (..), openFile)
  37 import           System.IO.Temp           (withSystemTempDirectory)
  38 import           System.Process           (rawSystem)
  39 import           Time.System              (timeCurrent)
  40 import           Time.Types               (Elapsed (..), Seconds (..))
  41
  42 import qualified Data.ByteString          as BS
  43
  44 import qualified Data.Text                as TS
  45 import qualified Data.Text.Encoding       as TS
  46 import qualified Data.X509                as X
  47 import qualified Network.Simple.TCP       as TCP
  48 import qualified Network.Socket           as S
  49
  50 import           Certificate
  51 import           Config
  52 import           Fingerprint
  53 import           Host
  54 import           Incoming
  55 import           LookupPetname
  56 import           Notify
  57 import           Petname
  58 import           RelayStream
  59
  60 #ifdef CURSES
  61 import           CursesClient
  62 #endif
  63 import           DumbClient
  64
  65 #if !(MIN_VERSION_base(4,11,0))
  66 import           Data.Semigroup
  67 #endif
  68
  69 bindingNamedSocket :: FilePath -> (S.Socket -> IO a) -> IO a
  70 bindingNamedSocket path =
  71     (`bracket` S.close) $ do
  72         sock <- S.socket S.AF_UNIX S.Stream 0
  73         S.bind sock $ S.SockAddrUnix path
  74         S.listen sock 1
  75         pure sock
  76
  77 serve :: FilePath -> Config -> Credential -> IO ()
  78 serve ddir conf cred = errorOnNoLock <=< withTryFileLock listenLockPath Exclusive $ \_ -> do
  79     let params = def
  80                 { serverShared = def { sharedCredentials = Credentials [cred] }
  81                 , serverSupported = def
  82                     { supportedCiphers = talkatCiphersuite
  83                     , supportedVersions = [TLS13] }
  84                 , serverHooks = def
  85                     { onUnverifiedClientCert = pure True
  86                     , onClientCertificate = \_ -> pure CertificateUsageAccept
  87                     }
  88                 , serverWantClientCert = True
  89                 }
  90     let port = show $ listen_port conf
  91         hostPref = case listen_host conf of
  92             [] -> TCP.HostAny
  93             h  -> TCP.Host h
  94         Just fp = spkiFingerprint <$> takeTailCert (fst cred)
  95     putStrLn $ "Listening on "
  96         <> (case hostPref of
  97             TCP.Host h -> "host " <> h
  98             _          -> "all available hosts")
  99         <> ", port " <> port <> "."
 100     putStrLn $ "URI: talkat:"
 101         <> showFingerprint fp <> "@"
 102         <> (let portBit = if port /= show defaultTalkatPort
 103                     then ":" <> port else ""
 104             in case hostPref of
 105                 TCP.Host h -> h <> portBit
 106                 _          -> "[host]" <> portBit <>
 107                     "\n       (replace [host] with your hostname or IP address)")
 108     cleanAllIncoming ddir
 109     serialMVar <- newMVar 0
 110     TCP.serve hostPref port $ \(sock,_) -> do
 111         S.setSocketOption sock S.NoDelay 1
 112         context <- contextNew sock params
 113         handshake context
 114         mCert <- (takeTailCert =<<) <$> getClientCertificateChain context
 115         case mCert of
 116             Nothing -> pure ()
 117             Just cert -> (if accept_unnamed conf
 118                     then ((Just <$>) .) . lookupOrAddPetname else lookupPetname)
 119                         ddir (spkiFingerprint cert) >>= \case
 120                 Nothing -> pure ()
 121                 Just petname -> withSystemTempDirectory "htalkat" $ \tdir -> do
 122                     let sockPath = tdir </> "sock"
 123                     bindingNamedSocket sockPath $ \dSock -> do
 124                         -- Serial numbers ensure we don't delete the wrong dir
 125                         serial <- modifyMVar serialMVar $ \n -> pure (n+1,n)
 126                         incoming <- addIncoming ddir cert sockPath serial
 127                         notifyOfIncoming ddir cert petname
 128                         relayStream context WriteFirst dSock
 129                         withFileLock (incomingDir ddir </> ".lock") Exclusive $ \_ ->
 130                             cleanIncoming ddir (Just serial) incoming
 131     where
 132     listenLockPath = ddir </> ".listen_lock"
 133     errorOnNoLock :: Maybe a -> IO ()
 134     errorOnNoLock Nothing = do
 135         putStrLn $ "Error: " <> listenLockPath <> " locked by another process."
 136         exitFailure
 137     errorOnNoLock _ = pure ()
 138
 139 data SocksProxy
 140     = NoSocksProxy
 141     | Socks5Proxy String String
 142
 143 connect :: FilePath -> Config -> Credential -> String -> SocksProxy -> Host -> Fingerprint -> IO ()
 144 connect ddir conf cred name socksProxy (Host hostname port) fp = do
 145     let serverId = if port == defaultTalkatPort
 146             then BS.empty
 147             else TS.encodeUtf8 . TS.pack . (':':) $ show port
 148         params = (TLS.defaultParamsClient hostname serverId)
 149             { clientSupported = def
 150                 { supportedCiphers = talkatCiphersuite
 151                 , supportedVersions = [TLS13] }
 152             , clientHooks = def
 153                 { onServerCertificate = checkServerCert
 154                 , onCertificateRequest = \(_,_,_) ->
 155                     pure $ Just cred
 156                 }
 157             }
 158     context <- do
 159         sock <- openSocket
 160         S.setSocketOption sock S.NoDelay 1
 161         c <- TLS.contextNew sock params
 162         handshake c >> pure c
 163     withSystemTempDirectory "htalkat" $ \tdir -> do
 164         let path = tdir </> "sock"
 165         bindingNamedSocket path $ \dSock -> do
 166             _ <- forkIO $ relayStream context WriteSecond dSock
 167             spawnInteractiveClient ddir conf name path
 168     where
 169     openSocket :: IO S.Socket
 170     openSocket = case socksProxy of
 171         NoSocksProxy -> fst <$> connectSock hostname (show port)
 172         Socks5Proxy socksHostname socksPort -> do
 173             sock <- fst <$> connectSock socksHostname socksPort
 174             _ <- connectSockSOCKS5 sock hostname (show port)
 175             pure sock
 176
 177     checkServerCert store cache service chain | Just cert <- takeTailCert chain = do
 178         errors <- filter (not . ignoreError) <$> validate X.HashSHA256 defaultHooks
 179             (defaultChecks { checkExhaustive = True , checkLeafV3 = False }) store cache service chain
 180         if fp == spkiFingerprint cert then pure errors
 181             else do
 182                 putStrLn "Server provides an unexpected certificate!"
 183                 putStrLn $ "Expected: " <> showFingerprint fp
 184                 putStrLn $ "Received: " <> showFingerprint (spkiFingerprint cert)
 185                 pure $ UnknownCA : errors
 186         where
 187         ignoreError UnknownCA        = True
 188         ignoreError SelfSigned       = True
 189         ignoreError NotAnAuthority   = True
 190         ignoreError (NameMismatch _) = True
 191         ignoreError _                = False
 192     checkServerCert _ _ _ _ = pure [ EmptyChain ]
 193
 194 talkatCiphersuite :: [Cipher]
 195 talkatCiphersuite =
 196     [ cipher_TLS13_AES128GCM_SHA256
 197     , cipher_TLS13_AES256GCM_SHA384
 198     , cipher_TLS13_CHACHA20POLY1305_SHA256
 199     , cipher_TLS13_AES128CCM_SHA256
 200     ]
 201
 202 answerLast :: FilePath -> Config -> Maybe Fingerprint -> IO ()
 203 answerLast ddir conf mFp = do
 204     mInfo <- withFileLock (incomingDir ddir </> ".lock") Exclusive $ \_ -> do
 205         lastIncoming ddir mFp >>= \case
 206             Just incoming -> do
 207                 petname <- incomingPetname ddir incoming
 208                 sockPath <- readFile (incomingPath ddir incoming </> "sock")
 209                 cleanIncoming ddir Nothing incoming
 210                 pure $ Just (petname, sockPath)
 211             Nothing -> pure Nothing
 212     case mInfo of
 213         Just (petname, sockPath) -> do
 214             spawnInteractiveClient ddir conf (showPetname petname) sockPath
 215         Nothing -> putStrLn "Nothing to answer."
 216
 217 spawnInteractiveClient :: FilePath -> Config -> String -> FilePath -> IO ()
 218 spawnInteractiveClient ddir conf name sockPath
 219     | command:args <- interactive_client conf =
 220         void . rawSystem command $ args ++ [name, sockPath]
 221     | otherwise =
 222 #ifdef CURSES
 223         if not $ use_dumb_client conf then do
 224             mLog <- if curses_log conf
 225                 then do
 226                     createDirectoryIfMissing True $ ddir </> "logs"
 227                     Elapsed (Seconds epochSecs) <- timeCurrent
 228                     Just <$> openFile (ddir </> "logs" </> name <>
 229                         "-" <> show epochSecs <.> "log") AppendMode
 230                 else pure Nothing
 231             cursesClient (curses_local_top conf) mLog name sockPath
 232         else
 233 #endif
 234         dumbClient sockPath
 235
 236 spawnDefaultInteractiveClient :: FilePath -> Config -> String -> FilePath -> IO ()
 237 spawnDefaultInteractiveClient ddir conf name sockPath = do
 238     spawnInteractiveClient ddir (conf { interactive_client = [] })
 239         name sockPath