Network/HTTP/Lucu/SocketLike.hs

   1 {-# LANGUAGE
   2     CPP
   3   , FlexibleContexts
   4   , FlexibleInstances
   5   , TypeFamilies
   6   , UnicodeSyntax
   7   #-}
   8 -- |Type class for things behaves like a 'So.Socket'.
   9 module Network.HTTP.Lucu.SocketLike
  10     ( SocketLike(..)
  11     )
  12     where
  13 #if defined(HAVE_SSL)
  14 import Control.Exception
  15 #endif
  16 import qualified Network.Socket as So
  17 import Network.HTTP.Lucu.HandleLike
  18 #if defined(HAVE_SSL)
  19 import qualified OpenSSL.Session as SSL
  20 import Prelude hiding (catch)
  21 import Prelude.Unicode
  22 #endif
  23 import qualified System.IO as I
  24
  25 class (HandleLike (Handle s)) ⇒ SocketLike s where
  26     type Handle s ∷ ★
  27     accept        ∷ s → IO (Handle s, So.SockAddr)
  28     socketPort    ∷ s → IO So.PortNumber
  29
  30 instance SocketLike So.Socket where
  31     type Handle So.Socket = I.Handle
  32
  33     accept soSelf
  34         = do (soPeer, addr) ← So.accept soSelf
  35              hPeer          ← So.socketToHandle soPeer I.ReadWriteMode
  36              return (hPeer, addr)
  37
  38     socketPort = So.socketPort
  39
  40 #if defined(HAVE_SSL)
  41 instance SocketLike (SSL.SSLContext, So.Socket) where
  42     type Handle (SSL.SSLContext, So.Socket) = SSL.SSL
  43
  44     accept (ctx, soSelf)
  45         = do (soPeer, addr) ← So.accept soSelf
  46              ssl            ← SSL.connection ctx soPeer
  47              handshake ssl addr `catch` next ssl addr
  48         where
  49           handshake ∷ SSL.SSL → So.SockAddr → IO (SSL.SSL, So.SockAddr)
  50           handshake ssl addr
  51               = do SSL.accept ssl
  52                    return (ssl, addr)
  53
  54           next ∷ SSL.SSL
  55                → So.SockAddr
  56                → SSL.SomeSSLException
  57                → IO (SSL.SSL, So.SockAddr)
  58           next ssl addr e
  59               = do I.hPutStrLn I.stderr
  60                        $ "Lucu: failed to accept an SSL connection from "
  61                        ⧺ show addr
  62                        ⧺ ":"
  63                    I.hPutStrLn I.stderr
  64                        $ show e
  65                    SSL.shutdown ssl SSL.Bidirectional
  66                    accept (ctx, soSelf)
  67
  68     socketPort = So.socketPort ∘ snd
  69 #endif