1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
-- Copyright (C) 2010 John Millikin <jmillikin@gmail.com>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE OverloadedStrings #-}
module Network.Protocol.XMPP.Handle
( Handle (..)
, startTLS
, hPutBytes
, hGetChar
) where
import Control.Monad (when)
import qualified Control.Monad.Error as E
import Control.Monad.Trans (liftIO)
import qualified Data.ByteString as B
import qualified Data.ByteString.Unsafe as B
import qualified Data.Text as T
import qualified System.IO as IO
import qualified Network.GnuTLS as GnuTLS
import Network.GnuTLS (AttrOp (..))
import Foreign (allocaBytes, plusPtr)
import Foreign.C (peekCAStringLen)
import Network.Protocol.XMPP.ErrorT
data Handle =
PlainHandle IO.Handle
| SecureHandle IO.Handle (GnuTLS.Session GnuTLS.Client)
startTLS :: Handle -> ErrorT T.Text IO Handle
startTLS (SecureHandle _ _) = E.throwError "Can't start TLS on a secure handle"
startTLS (PlainHandle h) = liftIO $ do
session <- GnuTLS.tlsClient
[ GnuTLS.handle := h
, GnuTLS.priorities := [GnuTLS.CrtX509]
, GnuTLS.credentials := GnuTLS.certificateCredentials
]
GnuTLS.handshake session
return $ SecureHandle h session
hPutBytes :: Handle -> B.ByteString -> ErrorT T.Text IO ()
hPutBytes (PlainHandle h) bytes = liftIO $ B.hPut h bytes
hPutBytes (SecureHandle _ session) bytes = liftIO useLoop where
useLoop = B.unsafeUseAsCStringLen bytes $ uncurry loop
loop ptr len = do
r <- GnuTLS.tlsSend session ptr len
case len - r of
x | x > 0 -> loop (plusPtr ptr r) x
| otherwise -> return ()
hGetChar :: Handle -> ErrorT T.Text IO Char
hGetChar (PlainHandle h) = liftIO $ IO.hGetChar h
hGetChar (SecureHandle h session) = liftIO $ allocaBytes 1 $ \ptr -> do
pending <- GnuTLS.tlsCheckPending session
when (pending == 0) $ do
IO.hWaitForInput h (-1)
return ()
len <- GnuTLS.tlsRecv session ptr 1
[char] <- peekCAStringLen (ptr, len)
return char