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
  34     hFlush  ∷ h → IO ()
  35     hClose  ∷ h → IO ()
  36
  37 instance HandleLike I.Handle where
  38     hGetLBS = L.hGetContents
  39
  40     hGetBS  = B.hGet
  41     hPutBS  = B.hPut
  42
  43     hFlush  = I.hFlush
  44     hClose  = I.hClose
  45
  46 #if defined(HAVE_SSL)
  47 instance HandleLike SSL.SSL where
  48     hGetLBS = SSL.lazyRead
  49
  50     hGetBS  = SSL.read
  51     hPutBS  = SSL.write
  52
  53     hGetPeerCert s
  54         = do isValid <- SSL.getVerifyResult s
  55              if isValid then
  56                  SSL.getPeerCertificate s
  57              else
  58                  return Nothing
  59
  60     hFlush _ = return () -- No need to do anything.
  61     hClose s = SSL.shutdown s SSL.Bidirectional
  62 #endif
  63
  64 hPutBuilder ∷ HandleLike h ⇒ h → Builder → IO ()
  65 {-# INLINE hPutBuilder #-}
  66 hPutBuilder = BB.toByteStringIO ∘ hPutBS