-
Notifications
You must be signed in to change notification settings - Fork 6
/
SSL.hs
106 lines (90 loc) · 3.22 KB
/
SSL.hs
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
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
--------------------------------------------------------------------------------
-- |
-- Module : Network.OpenID.HTTP
-- Copyright : (c) Trevor Elliott, 2008
-- License : BSD3
--
-- Maintainer : Trevor Elliott <trevor@geekgateway.com>
-- Stability :
-- Portability :
--
module Network.OpenID.SSL (
SSLHandle,
sslConnect
) where
import OpenSSL.Session as Session
import qualified Control.Exception as E
import Network.Socket
import Network.Stream
import qualified Data.ByteString as B
import Control.Applicative
import Data.ByteString.Internal (w2c, c2w)
import Data.Word
data SSLHandle = SSLHandle SSLContext SSL
wrap :: IO a -> IO (Either ConnError a)
wrap m = Right `fmap` m `E.catch` handler
where
handler :: E.SomeException -> IO (Either ConnError a)
handler err = return $ Left $ ErrorMisc $ "write: " ++ show err
wrapRead :: IO String -> IO (Either ConnError String)
wrapRead m = Right `fmap` m `E.catches` handlers
where
handlers :: [E.Handler (Either ConnError String)]
handlers =
[ E.Handler ((\_ -> return $ Right "")
:: (ConnectionAbruptlyTerminated -> IO (Either ConnError String)))
, E.Handler ((\x -> return $ Left $ ErrorMisc $ "read: " ++ show x)
:: (E.SomeException -> IO (Either ConnError String)))
]
-- The problem is that the OpenSSL library doesn't know that in some
-- cases, the HTTP server will rudely close its side of the write
-- socket once a complete HTTP response has been transmitted. In fact,
-- the server will also terminate its read end once we've sent a
-- complete header, but the HTTP driver doesn't seem to mind about
-- that bit. All this seems to be standard practice (regardless of
-- whether it is considered correct by SSL or not), so we should just
-- treat it as an EOF.
--
-- In the meantime, the Network.HTTP driver will stop reading on an
-- empty input (NOT an empty line terminated by a "\n"), so we should
-- return that.
instance Stream SSLHandle where
readLine sh =
wrapRead (upd `fmap` sslReadWhile (/= c) sh)
where
c = toEnum (fromEnum '\n')
upd bs = map (toEnum . fromEnum) bs ++ "\n"
readBlock (SSLHandle _ ssl) n =
wrapRead ((map w2c . B.unpack) <$> Session.read ssl n)
writeBlock (SSLHandle _ ssl) bs
| not (null bs) = wrap $ Session.write ssl $ B.pack $ map c2w bs
| otherwise = return $ Right ()
-- should this really ignore all exceptions?
close (SSLHandle _ ssl) = Session.shutdown ssl Bidirectional
`E.catch` ((\_ -> return ()) :: E.SomeException -> IO ())
closeOnEnd _ _ = return ()
sslConnect :: Socket -> IO (Maybe SSLHandle)
sslConnect sock = body `E.catch` handler
where
body = do
ctx <- Session.context
ssl <- Session.connection ctx sock
Session.connect ssl
return $ Just $ SSLHandle ctx ssl
handler :: E.SomeException -> IO (Maybe SSLHandle)
handler _ = return Nothing
sslReadWhile :: (Word8 -> Bool) -> SSLHandle -> IO [Word8]
sslReadWhile p (SSLHandle _ ssl) = loop
where
loop = do
txt <- Session.read ssl 1
if B.null txt
then return []
else do
let c = B.head txt
if p c
then do
cs <- loop
return (c:cs)
else
return []