Network/HTTP/Lucu/HandleLike.hs

   1 module Network.HTTP.Lucu.HandleLike
   2     ( HandleLike(..)
   3     )
   4     where
   5
   6 import qualified Data.ByteString as B
   7 import qualified Data.ByteString.Lazy.Char8 as L
   8 import qualified OpenSSL.Session as SSL
   9 import           OpenSSL.X509
  10 import qualified System.IO as I
  11
  12
  13 class HandleLike h where
  14     hGetLBS :: h -> IO L.ByteString
  15     hPutLBS :: h -> L.ByteString -> IO ()
  16
  17     hGetBS  :: h -> Int -> IO B.ByteString
  18     hPutBS  :: h -> B.ByteString -> IO ()
  19
  20     hPutChar  :: h -> Char -> IO ()
  21
  22     hPutStr   :: h -> String -> IO ()
  23     hPutStrLn :: h -> String -> IO ()
  24
  25     hGetPeerCert :: h -> IO (Maybe X509)
  26     hGetPeerCert = const $ return Nothing
  27
  28     hFlush  :: h -> IO ()
  29     hClose  :: h -> IO ()
  30
  31
  32 instance HandleLike I.Handle where
  33     hGetLBS = L.hGetContents
  34     hPutLBS = L.hPut
  35
  36     hGetBS  = B.hGet
  37     hPutBS  = B.hPut
  38
  39     hPutChar  = I.hPutChar
  40
  41     hPutStr   = I.hPutStr
  42     hPutStrLn = I.hPutStrLn
  43
  44     hFlush  = I.hFlush
  45     hClose  = I.hClose
  46
  47
  48 instance HandleLike SSL.SSL where
  49     hGetLBS   = SSL.lazyRead
  50     hPutLBS   = SSL.lazyWrite
  51
  52     hGetBS    = SSL.read
  53     hPutBS    = SSL.write
  54
  55     hPutChar  s = hPutLBS s . L.singleton
  56
  57     hPutStr   s = hPutLBS s . L.pack
  58     hPutStrLn s = hPutLBS s . L.pack . (++ "\n")
  59
  60     hGetPeerCert s
  61         = do isValid <- SSL.getVerifyResult s
  62              if isValid then
  63                  SSL.getPeerCertificate s
  64                else
  65                  return Nothing
  66
  67     hFlush _  = return () -- unneeded
  68     hClose s  = SSL.shutdown s SSL.Bidirectional