Network/HTTP/Lucu/HandleLike.hs

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