-- ghci -hide-package monads-tf Server.hs

module Main where

import qualified Control.Monad.Trans as Trans
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import qualified Data.Certificate.PEM as PEM
import qualified Data.Certificate.Key as Key
import qualified Data.Certificate.X509 as X509

import qualified Network.TLS.Server as S
import qualified Network.TLS.Struct as Struct
import qualified Network.TLS.Cipher as Cipher
import qualified Network.TLS.SRandom as SRandom

import qualified Control.Exception as E
import qualified Network as Net
import qualified Network.Socket as Socket
import qualified IO as IO
import qualified Control.Concurrent as Concurrent

main :: IO ()
main = do
  pk <- readPrivateKey "privkey.pem"
  (certdata, cert) <- readCertificate "cacert.pem"
  listenForClients (certdata, cert, snd pk)
  return ()

type SpCert = (B.ByteString, X509.Certificate, Key.PrivateKey)

listenForClients :: SpCert -> IO ()
listenForClients spCert
    = Net.withSocketsDo $ E.bracket aquireSocket Net.sClose loop where
   aquireSocket =
       do socket <- Net.listenOn $ Net.PortNumber 8000
          Socket.setSocketOption socket Socket.ReuseAddr 1
          return socket
   loop socket =
       do (handle, _, _) <- Net.accept socket
          sslListen spCert handle
          loop socket

sslListen :: SpCert -> IO.Handle -> IO ()
sslListen spCert handle = do
  serverRNG <- getRandomGen
  let serverState = makeValidParams spCert
  let tlsServer = do
         S.listen handle
         d <- S.recvData handle
         Trans.lift $ print d
         return ()
  Concurrent.forkIO (S.runTLSServer tlsServer serverState serverRNG >> return ())
  return ()

getRandomGen :: IO SRandom.SRandomGen
getRandomGen = SRandom.makeSRandomGen >>= either (fail . show) (return . id)


makeValidParams :: SpCert -> S.TLSServerParams
makeValidParams spCert =
  S.TLSServerParams
         supportedVersions
         [] -- session
         supportedCiphers
         (Just spCert) -- server certificate
         False -- check for client certificate
         (S.TLSServerCallbacks { S.cbCertificates = Nothing })

supportedVersions :: [Struct.Version]
supportedVersions = [Struct.SSL3, Struct.TLS10, Struct.TLS11]

supportedCiphers :: [Cipher.Cipher]
supportedCiphers =
    [ Cipher.cipher_AES128_SHA1
    , Cipher.cipher_AES256_SHA1
    , Cipher.cipher_RC4_128_MD5
    , Cipher.cipher_RC4_128_SHA1
    ]

readCertificate :: FilePath -> IO (B.ByteString, X509.Certificate)
readCertificate filepath = do
  content <- B.readFile filepath
  let certdata = case PEM.parsePEMCert content of
                   Nothing -> error ("no valid certificate section")
                   Just x -> x
  let cert = case X509.decodeCertificate $ L.fromChunks [certdata] of
               Left err -> error ("cannot decode certificate: " ++ err)
               Right x -> x
  return (certdata, cert)

readPrivateKey :: FilePath -> IO (L.ByteString, Key.PrivateKey)
readPrivateKey filepath = do
  content <- B.readFile filepath
  let pkdata = case PEM.parsePEMKeyRSA content of
                 Nothing -> error ("no valid RSA key section")
                 Just x -> L.fromChunks [x]
  let pk = case Key.decodePrivateKey pkdata of
             Left err -> error ("cannot decode key: " ++ err)
             Right x -> x
  return (pkdata, pk)