Network/HTTP/Lucu/HandleLike.hs

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