Network/HTTP/Lucu/HandleLike.hs

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