{-# LANGUAGE
    CPP
  , FlexibleContexts
  , FlexibleInstances
  , TypeFamilies
  , UnicodeSyntax
  #-}
-- |Type class for things behaves like a 'So.Socket'.
module Network.HTTP.Lucu.SocketLike
    ( SocketLike(..)
    )
    where
#if defined(HAVE_SSL)
import Control.Exception
#endif
import qualified Network.Socket as So
import Network.HTTP.Lucu.HandleLike
#if defined(HAVE_SSL)
import qualified OpenSSL.Session as SSL
import Prelude hiding (catch)
import Prelude.Unicode
#endif
import qualified System.IO as I

class (HandleLike (Handle s)) ⇒ SocketLike s where
    type Handle s ∷ ★
    accept        ∷ s → IO (Handle s, So.SockAddr)
    socketPort    ∷ s → IO So.PortNumber

instance SocketLike So.Socket where
    type Handle So.Socket = I.Handle

    accept soSelf
        = do (soPeer, addr) ← So.accept soSelf
             hPeer          ← So.socketToHandle soPeer I.ReadWriteMode
             return (hPeer, addr)

    socketPort = So.socketPort

#if defined(HAVE_SSL)
instance SocketLike (SSL.SSLContext, So.Socket) where
    type Handle (SSL.SSLContext, So.Socket) = SSL.SSL

    accept (ctx, soSelf)
        = do (soPeer, addr) ← So.accept soSelf
             ssl            ← SSL.connection ctx soPeer
             handshake ssl addr `catch` next ssl addr
        where
          handshake ∷ SSL.SSL → So.SockAddr → IO (SSL.SSL, So.SockAddr)
          handshake ssl addr
              = do SSL.accept ssl
                   return (ssl, addr)

          next ∷ SSL.SSL
               → So.SockAddr
               → SSL.SomeSSLException
               → IO (SSL.SSL, So.SockAddr)
          next ssl addr e
              = do I.hPutStrLn I.stderr
                       $ "Lucu: failed to accept an SSL connection from "
                       ⧺ show addr
                       ⧺ ":"
                   I.hPutStrLn I.stderr
                       $ show e
                   SSL.shutdown ssl SSL.Bidirectional
                   accept (ctx, soSelf)

    socketPort = So.socketPort ∘ snd
#endif