Network/HTTP/Lucu/SocketLike.hs

   1 {-# LANGUAGE
   2     FlexibleContexts
   3   , FlexibleInstances
   4   , TypeFamilies
   5   , UnicodeSyntax
   6   #-}
   7 -- |Type class for things behaves like a 'So.Socket'.
   8 module Network.HTTP.Lucu.SocketLike
   9     ( SocketLike(..)
  10     )
  11     where
  12 import qualified Network.Socket as So
  13 import Network.HTTP.Lucu.HandleLike
  14 import qualified OpenSSL.Session as SSL
  15 import Prelude.Unicode
  16 import qualified System.IO as I
  17
  18 class (HandleLike (Handle s)) ⇒ SocketLike s where
  19     type Handle s ∷ ★
  20     accept        ∷ s → IO (Handle s, So.SockAddr)
  21     socketPort    ∷ s → IO So.PortNumber
  22
  23 instance SocketLike So.Socket where
  24     type Handle So.Socket = I.Handle
  25
  26     accept soSelf
  27         = do (soPeer, addr) ← So.accept soSelf
  28              hPeer          ← So.socketToHandle soPeer I.ReadWriteMode
  29              return (hPeer, addr)
  30
  31     socketPort = So.socketPort
  32
  33 instance SocketLike (SSL.SSLContext, So.Socket) where
  34     type Handle (SSL.SSLContext, So.Socket) = SSL.SSL
  35
  36     accept (ctx, soSelf)
  37         = do (soPeer, addr) ← So.accept soSelf
  38              ssl            ← SSL.connection ctx soPeer
  39              SSL.accept ssl
  40              return (ssl, addr)
  41
  42     socketPort = So.socketPort ∘ snd