Still working on Router arrow

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

diff --git a/Network/HTTP/Lucu/HandleLike.hs b/Network/HTTP/Lucu/HandleLike.hs
index f58264d9c6abd2b3fd5761c7fc0bd6cdfd5782e1..65d99f40c60aa42f4be092527914e5f6d8d64bed 100644 (file)
--- a/Network/HTTP/Lucu/HandleLike.hs
+++ b/Network/HTTP/Lucu/HandleLike.hs
@@ -1,33 +1,43 @@
 {-# LANGUAGE
-    UnicodeSyntax
+    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
+#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 ()
 
+#if defined(HAVE_SSL)
     hGetPeerCert ∷ h → IO (Maybe X509)
     hGetPeerCert = const $ return Nothing
+#endif
+    hIsSSL ∷ h → Bool
+    hIsSSL _ = False
 
     hFlush  ∷ h → IO ()
     hClose  ∷ h → IO ()
 
-
 instance HandleLike I.Handle where
     hGetLBS = L.hGetContents
-    hPutLBS = L.hPut
 
     hGetBS  = B.hGet
     hPutBS  = B.hPut
@@ -35,20 +45,25 @@ instance HandleLike I.Handle where
     hFlush  = I.hFlush
     hClose  = I.hClose
 
-
+#if defined(HAVE_SSL)
 instance HandleLike SSL.SSL where
-    hGetLBS   = SSL.lazyRead
-    hPutLBS   = SSL.lazyWrite
+    hGetLBS = SSL.lazyRead
 
-    hGetBS    = SSL.read
-    hPutBS    = SSL.write
+    hGetBS  = SSL.read
+    hPutBS  = SSL.write
 
     hGetPeerCert s
         = do isValid <- SSL.getVerifyResult s
              if isValid then
                  SSL.getPeerCertificate s
-               else
+             else
                  return Nothing
+    hIsSSL _ = True
+
+    hFlush _ = return () -- No need to do anything.
+    hClose s = SSL.shutdown s SSL.Bidirectional
+#endif
 
-    hFlush _  = return () -- unneeded
-    hClose s  = SSL.shutdown s SSL.Bidirectional
+hPutBuilder ∷ HandleLike h ⇒ h → Builder → IO ()
+{-# INLINE hPutBuilder #-}
+hPutBuilder = BB.toByteStringIO ∘ hPutBS