SSL Support

[Lucu.git] / Network / HTTP / Lucu / HandleLike.hs

diff --git a/Network/HTTP/Lucu/HandleLike.hs b/Network/HTTP/Lucu/HandleLike.hs
new file mode 100644 (file)
index 0000000..aa4dacb
--- /dev/null
+++ b/Network/HTTP/Lucu/HandleLike.hs
@@ -0,0 +1,68 @@
+module Network.HTTP.Lucu.HandleLike
+    ( HandleLike(..)
+    )
+    where
+
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy.Char8 as L
+import qualified OpenSSL.Session as SSL
+import           OpenSSL.X509
+import qualified System.IO as I
+
+
+class HandleLike h where
+    hGetLBS :: h -> IO L.ByteString
+    hPutLBS :: h -> L.ByteString -> IO ()
+
+    hGetBS  :: h -> Int -> IO B.ByteString
+    hPutBS  :: h -> B.ByteString -> IO ()
+
+    hPutChar  :: h -> Char -> IO ()
+
+    hPutStr   :: h -> String -> IO ()
+    hPutStrLn :: h -> String -> IO ()
+
+    hGetPeerCert :: h -> IO (Maybe X509)
+    hGetPeerCert = const $ return Nothing
+
+    hFlush  :: h -> IO ()
+    hClose  :: h -> IO ()
+
+
+instance HandleLike I.Handle where
+    hGetLBS = L.hGetContents
+    hPutLBS = L.hPut
+
+    hGetBS  = B.hGet
+    hPutBS  = B.hPut
+
+    hPutChar  = I.hPutChar
+
+    hPutStr   = I.hPutStr
+    hPutStrLn = I.hPutStrLn
+
+    hFlush  = I.hFlush
+    hClose  = I.hClose
+
+
+instance HandleLike SSL.SSL where
+    hGetLBS   = SSL.lazyRead
+    hPutLBS   = SSL.lazyWrite
+
+    hGetBS    = SSL.read
+    hPutBS    = SSL.write
+
+    hPutChar  s = hPutLBS s . L.singleton
+
+    hPutStr   s = hPutLBS s . L.pack
+    hPutStrLn s = hPutLBS s . L.pack . (++ "\n")
+
+    hGetPeerCert s
+        = do isValid <- SSL.getVerifyResult s
+             if isValid then
+                 SSL.getPeerCertificate s
+               else
+                 return Nothing
+
+    hFlush _  = return () -- unneeded
+    hClose s  = SSL.shutdown s SSL.Bidirectional