Network/HTTP/Lucu/HandleLike.hs

   1 {-# LANGUAGE
   2     UnicodeSyntax
   3   #-}
   4 module Network.HTTP.Lucu.HandleLike
   5     ( HandleLike(..)
   6     , hPutBuilder
   7     )
   8     where
   9 import Blaze.ByteString.Builder (Builder)
  10 import qualified Blaze.ByteString.Builder as BB
  11 import qualified Data.ByteString as B
  12 import qualified Data.ByteString.Lazy.Char8 as L
  13 import qualified OpenSSL.Session as SSL
  14 import OpenSSL.X509
  15 import Prelude.Unicode
  16 import qualified System.IO as I
  17
  18 class HandleLike h where
  19     hGetLBS ∷ h → IO L.ByteString
  20     hPutLBS ∷ h → L.ByteString → IO ()
  21
  22     hGetBS  ∷ h → Int → IO B.ByteString
  23     hPutBS  ∷ h → B.ByteString → IO ()
  24
  25     hGetPeerCert ∷ h → IO (Maybe X509)
  26     hGetPeerCert = const $ return Nothing
  27
  28     hFlush  ∷ h → IO ()
  29     hClose  ∷ h → IO ()
  30
  31
  32 instance HandleLike I.Handle where
  33     hGetLBS = L.hGetContents
  34     hPutLBS = L.hPut
  35
  36     hGetBS  = B.hGet
  37     hPutBS  = B.hPut
  38
  39     hFlush  = I.hFlush
  40     hClose  = I.hClose
  41
  42
  43 instance HandleLike SSL.SSL where
  44     hGetLBS   = SSL.lazyRead
  45     hPutLBS   = SSL.lazyWrite
  46
  47     hGetBS    = SSL.read
  48     hPutBS    = SSL.write
  49
  50     hGetPeerCert s
  51         = do isValid <- SSL.getVerifyResult s
  52              if isValid then
  53                  SSL.getPeerCertificate s
  54                else
  55                  return Nothing
  56
  57     hFlush _  = return () -- No need to do anything.
  58     hClose s  = SSL.shutdown s SSL.Bidirectional
  59
  60 hPutBuilder ∷ HandleLike h ⇒ h → Builder → IO ()
  61 {-# INLINE hPutBuilder #-}
  62 hPutBuilder = BB.toByteStringIO ∘ hPutBS