Network/HTTP/Lucu/HandleLike.hs

   1 {-# LANGUAGE
   2     UnicodeSyntax
   3   #-}
   4 module Network.HTTP.Lucu.HandleLike
   5     ( HandleLike(..)
   6     )
   7     where
   8 import qualified Data.ByteString as B
   9 import qualified Data.ByteString.Lazy.Char8 as L
  10 import qualified OpenSSL.Session as SSL
  11 import OpenSSL.X509
  12 import qualified System.IO as I
  13
  14 class HandleLike h where
  15     hGetLBS ∷ h → IO L.ByteString
  16     hPutLBS ∷ h → L.ByteString → IO ()
  17
  18     hGetBS  ∷ h → Int → IO B.ByteString
  19     hPutBS  ∷ h → B.ByteString → IO ()
  20
  21     hGetPeerCert ∷ h → IO (Maybe X509)
  22     hGetPeerCert = const $ return Nothing
  23
  24     hFlush  ∷ h → IO ()
  25     hClose  ∷ h → IO ()
  26
  27
  28 instance HandleLike I.Handle where
  29     hGetLBS = L.hGetContents
  30     hPutLBS = L.hPut
  31
  32     hGetBS  = B.hGet
  33     hPutBS  = B.hPut
  34
  35     hFlush  = I.hFlush
  36     hClose  = I.hClose
  37
  38
  39 instance HandleLike SSL.SSL where
  40     hGetLBS   = SSL.lazyRead
  41     hPutLBS   = SSL.lazyWrite
  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 () -- unneeded
  54     hClose s  = SSL.shutdown s SSL.Bidirectional