+{-# LANGUAGE
+ CPP
+ , DoAndIfThenElse
+ , UnicodeSyntax
+ #-}
+-- |Type class for things behaves like a 'I.Handle'.
module Network.HTTP.Lucu.HandleLike
( HandleLike(..)
+ , hPutBuilder
)
where
-
+import Blaze.ByteString.Builder (Builder)
+import qualified Blaze.ByteString.Builder as BB
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy.Char8 as L
+#if defined(HAVE_SSL)
import qualified OpenSSL.Session as SSL
-import OpenSSL.X509
+import OpenSSL.X509
+#endif
+import Prelude.Unicode
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 ()
+ hGetLBS ∷ h → IO L.ByteString
- hPutChar :: h -> Char -> IO ()
+ hGetBS ∷ h → Int → IO B.ByteString
+ hPutBS ∷ h → B.ByteString → IO ()
- hPutStr :: h -> String -> IO ()
- hPutStrLn :: h -> String -> IO ()
-
- hGetPeerCert :: h -> IO (Maybe X509)
+#if defined(HAVE_SSL)
+ hGetPeerCert ∷ h → IO (Maybe X509)
hGetPeerCert = const $ return Nothing
+#endif
- hFlush :: h -> IO ()
- hClose :: h -> IO ()
-
+ 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
-
+#if defined(HAVE_SSL)
instance HandleLike SSL.SSL where
- hGetLBS = SSL.lazyRead
- hPutLBS = SSL.lazyWrite
-
- hGetBS = SSL.read
- hPutBS = SSL.write
+ hGetLBS = SSL.lazyRead
- hPutChar s = hPutLBS s . L.singleton
-
- hPutStr s = hPutLBS s . L.pack
- hPutStrLn s = hPutLBS s . L.pack . (++ "\n")
+ hGetBS = SSL.read
+ hPutBS = SSL.write
hGetPeerCert s
= do isValid <- SSL.getVerifyResult s
if isValid then
SSL.getPeerCertificate s
- else
+ else
return Nothing
- hFlush _ = return () -- unneeded
- hClose s = SSL.shutdown s SSL.Bidirectional
+ hFlush _ = return () -- No need to do anything.
+ hClose s = SSL.shutdown s SSL.Bidirectional
+#endif
+
+hPutBuilder ∷ HandleLike h ⇒ h → Builder → IO ()
+{-# INLINE hPutBuilder #-}
+hPutBuilder = BB.toByteStringIO ∘ hPutBS