Permalink
Browse files

initial import (mostly imported from tls 0.4)

  • Loading branch information...
0 parents commit bd3c9546a45aba814c5e5119e9cdd9e63ebf7d97 @vincenthz committed Mar 19, 2011
Showing with 1,137 additions and 0 deletions.
  1. +123 −0 Examples/CheckCiphers.hs
  2. +258 −0 Examples/Stunnel.hs
  3. +27 −0 LICENSE
  4. +5 −0 Network/TLS/Extra.hs
  5. +234 −0 Network/TLS/Extra/Cipher.hs
  6. +2 −0 Setup.hs
  7. +8 −0 Tests.hs
  8. +48 −0 Tests/Certificate.hs
  9. +42 −0 Tests/Ciphers.hs
  10. +33 −0 Tests/Common.hs
  11. +180 −0 Tests/Connection.hs
  12. +99 −0 Tests/Marshal.hs
  13. +78 −0 tls-extra.cabal
@@ -0,0 +1,123 @@
+{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}
+
+import Network.TLS.Internal
+import Network.TLS.Cipher
+import Network.TLS
+
+import qualified Data.ByteString as B
+import Data.Word
+import Data.Char
+
+import Network.Socket
+import Network.BSD
+import System.IO
+import Control.Monad
+import Control.Applicative ((<$>))
+import Control.Concurrent
+import Control.Exception (catch, SomeException(..))
+import Prelude hiding (catch)
+
+import Text.Printf
+
+import System.Console.CmdArgs
+
+fakeCipher cid = Cipher
+ { cipherID = cid
+ , cipherName = "cipher-" ++ show cid
+ , cipherDigestSize = 0
+ , cipherKeySize = 0
+ , cipherIVSize = 0
+ , cipherKeyBlockSize = 0
+ , cipherPaddingSize = 0
+ , cipherKeyExchange = CipherKeyExchangeRSA
+ , cipherMACHash = (\_ -> undefined)
+ , cipherF = undefined
+ , cipherMinVer = Nothing
+ }
+
+clienthello ciphers = ClientHello TLS10 (ClientRandom $ B.pack [0..31]) (Session Nothing) ciphers [0] Nothing
+
+openConnection :: String -> String -> [Word16] -> IO (Maybe Word16)
+openConnection s p ciphers = do
+ pn <- if and $ map isDigit $ p
+ then return $ fromIntegral $ (read p :: Int)
+ else do
+ service <- getServiceByName p "tcp"
+ return $ servicePort service
+ he <- getHostByName s
+ sock <- socket AF_INET Stream defaultProtocol
+ connect sock (SockAddrInet pn (head $ hostAddresses he))
+ handle <- socketToHandle sock ReadWriteMode
+
+ (Right rng) <- makeSRandomGen
+ let params = defaultParams { pCiphers = map fakeCipher ciphers }
+ ctx <- client params rng handle
+ sendPacket ctx $ Handshake $ clienthello ciphers
+ catch (do
+ rpkt <- recvPacket ctx
+ ccid <- case rpkt of
+ Right (h:_) -> case h of
+ (Handshake (ServerHello _ _ _ i _ _)) -> return i
+ _ -> error "didn't received serverhello"
+ _ -> error ("packet received: " ++ show rpkt)
+ bye ctx
+ hClose handle
+ return $ Just ccid
+ ) (\(_ :: SomeException) -> return Nothing)
+
+connectRange :: String -> String -> Int -> [Word16] -> IO (Int, [Word16])
+connectRange d p v r = do
+ ccidopt <- openConnection d p r
+ threadDelay v
+ case ccidopt of
+ Nothing -> return (1, [])
+ Just ccid -> do
+ {-divide and conquer TLS-}
+ let newr = filter ((/=) ccid) r
+ let (lr, rr) = if length newr > 2
+ then splitAt (length newr `div` 2) newr
+ else (newr, [])
+ (lc, ls) <- if length lr > 0
+ then connectRange d p v lr
+ else return (0,[])
+ (rc, rs) <- if length rr > 0
+ then connectRange d p v rr
+ else return (0,[])
+ return (1 + lc + rc, [ccid] ++ ls ++ rs)
+
+connectBetween d p v chunkSize ep sp = concat <$> loop sp where
+ loop a = liftM2 (:) (snd <$> connectRange d p v range)
+ (if a + chunkSize > ep then return [] else loop (a+64))
+ where
+ range = if a + chunkSize > ep
+ then [a..ep]
+ else [a..sp+chunkSize]
+
+data PArgs = PArgs
+ { destination :: String
+ , port :: String
+ , speed :: Int
+ , start :: Int
+ , end :: Int
+ , nb :: Int
+ } deriving (Show, Data, Typeable)
+
+progArgs = PArgs
+ { destination = "localhost" &= help "destination address to connect to" &= typ "address"
+ , port = "443" &= help "destination port to connect to" &= typ "port"
+ , speed = 100 &= help "speed between queries, in milliseconds" &= typ "speed"
+ , start = 0 &= help "starting cipher number (between 0 and 65535)" &= typ "cipher"
+ , end = 0xff &= help "end cipher number (between 0 and 65535)" &= typ "cipher"
+ , nb = 64 &= help "number of cipher to include per query " &= typ "range"
+ } &= summary "CheckCiphers -- SSL/TLS remotely check supported cipher"
+ &= details
+ [ "check the supported cipher of a remote destination."
+ , "Beware: this program make multiple connections to the destination"
+ , "which might be taken by the remote side as aggressive behavior"
+ ]
+
+main = do
+ a <- cmdArgs progArgs
+ _ <- printf "connecting to %s on port %s ...\n" (destination a) (port a)
+ supported <- connectBetween (destination a) (port a) (speed a) (fromIntegral $ nb a) (fromIntegral $ end a) (fromIntegral $ start a)
+ putStrLn $ show supported
@@ -0,0 +1,258 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+import Network.BSD
+import Network.Socket
+import System.IO
+import System.IO.Error hiding (try)
+import System.Console.CmdArgs
+
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as L
+
+import Control.Concurrent (forkIO)
+import Control.Exception (finally, try, throw)
+import Control.Monad (when, forever)
+
+import Data.Char (isDigit)
+
+import Data.Certificate.PEM
+import Data.Certificate.X509
+import qualified Data.Certificate.KeyRSA as KeyRSA
+import qualified Crypto.Cipher.RSA as RSA
+
+import Network.TLS
+import Network.TLS.Extra
+
+ciphers :: [Cipher]
+ciphers =
+ [ cipher_AES128_SHA1
+ , cipher_AES256_SHA1
+ , cipher_RC4_128_MD5
+ , cipher_RC4_128_SHA1
+ ]
+
+loopUntil :: Monad m => m Bool -> m ()
+loopUntil f = f >>= \v -> if v then return () else loopUntil f
+
+readOne h = do
+ r <- try $ hWaitForInput h (-1)
+ case r of
+ Left err -> if isEOFError err then return B.empty else throw err
+ Right True -> B.hGetNonBlocking h 4096
+ Right False -> return B.empty
+
+tlsclient :: Handle -> TLSCtx -> IO ()
+tlsclient srchandle dsthandle = do
+ hSetBuffering srchandle NoBuffering
+
+ handshake dsthandle
+
+ loopUntil $ do
+ b <- readOne srchandle
+ putStrLn ("sending " ++ show b)
+ if B.null b
+ then do
+ bye dsthandle
+ return True
+ else do
+ sendData dsthandle (L.fromChunks [b])
+ return False
+ return ()
+
+getRandomGen :: IO SRandomGen
+getRandomGen = makeSRandomGen >>= either (fail . show) (return . id)
+
+tlsserver srchandle dsthandle = do
+ hSetBuffering dsthandle NoBuffering
+
+ handshake srchandle
+
+ loopUntil $ do
+ d <- recvData srchandle
+ putStrLn ("received: " ++ show d)
+ sendData srchandle (L.pack $ map (toEnum . fromEnum) "this is some data")
+ hFlush (ctxHandle srchandle)
+ return False
+ putStrLn "end"
+
+clientProcess certs handle dsthandle _ = do
+ rng <- getRandomGen
+
+ let serverstate = defaultParams
+ { pAllowedVersions = [SSL3,TLS10,TLS11]
+ , pCiphers = ciphers
+ , pCertificates = certs
+ , pWantClientCert = False
+ }
+ ctx <- server serverstate rng handle
+ tlsserver ctx dsthandle
+
+readCertificate :: FilePath -> IO X509
+readCertificate filepath = do
+ content <- B.readFile filepath
+ let certdata = case parsePEMCert content of
+ Nothing -> error ("no valid certificate section")
+ Just x -> x
+ let cert = case decodeCertificate $ L.fromChunks [certdata] of
+ Left err -> error ("cannot decode certificate: " ++ err)
+ Right x -> x
+ return cert
+
+readPrivateKey :: FilePath -> IO PrivateKey
+readPrivateKey filepath = do
+ content <- B.readFile filepath
+ let pkdata = case parsePEMKeyRSA content of
+ Nothing -> error ("no valid RSA key section")
+ Just x -> L.fromChunks [x]
+ let pk = case KeyRSA.decodePrivate pkdata of
+ Left err -> error ("cannot decode key: " ++ err)
+ Right x -> PrivRSA $ RSA.PrivateKey
+ { RSA.private_sz = fromIntegral $ KeyRSA.lenmodulus x
+ , RSA.private_n = KeyRSA.modulus x
+ , RSA.private_d = KeyRSA.private_exponant x
+ , RSA.private_p = KeyRSA.p1 x
+ , RSA.private_q = KeyRSA.p2 x
+ , RSA.private_dP = KeyRSA.exp1 x
+ , RSA.private_dQ = KeyRSA.exp2 x
+ , RSA.private_qinv = KeyRSA.coef x
+ }
+ return pk
+
+data Stunnel =
+ Client
+ { destinationType :: String
+ , destination :: String
+ , sourceType :: String
+ , source :: String }
+ | Server
+ { destinationType :: String
+ , destination :: String
+ , sourceType :: String
+ , source :: String
+ , certificate :: FilePath
+ , key :: FilePath }
+ deriving (Show, Data, Typeable)
+
+clientOpts = Client
+ { destinationType = "tcp" &= help "type of source (tcp, unix, fd)" &= typ "DESTTYPE"
+ , destination = "localhost:6061" &= help "destination address influenced by destination type" &= typ "ADDRESS"
+ , sourceType = "tcp" &= help "type of source (tcp, unix, fd)" &= typ "SOURCETYPE"
+ , source = "localhost:6060" &= help "source address influenced by source type" &= typ "ADDRESS"
+ }
+ &= help "connect to a remote destination that use SSL/TLS"
+
+serverOpts = Server
+ { destinationType = "tcp" &= help "type of source (tcp, unix, fd)" &= typ "DESTTYPE"
+ , destination = "localhost:6060" &= help "destination address influenced by destination type" &= typ "ADDRESS"
+ , sourceType = "tcp" &= help "type of source (tcp, unix, fd)" &= typ "SOURCETYPE"
+ , source = "localhost:6061" &= help "source address influenced by source type" &= typ "ADDRESS"
+ , certificate = "certificate.pem" &= help "X509 public certificate to use" &= typ "FILE"
+ , key = "certificate.key" &= help "private key linked to the certificate" &= typ "FILE"
+ }
+ &= help "listen for connection that use SSL/TLS and relay it to a different connection"
+
+mode = cmdArgsMode $ modes [clientOpts,serverOpts]
+ &= help "create SSL/TLS tunnel in client or server mode" &= program "stunnel" &= summary "Stunnel v0.1 (Haskell TLS)"
+
+data StunnelAddr =
+ AddrSocket Family SockAddr
+ | AddrFD Handle Handle
+
+data StunnelHandle =
+ StunnelSocket Socket
+ | StunnelFd Handle Handle
+
+getAddressDescription :: String -> String -> IO StunnelAddr
+getAddressDescription "tcp" desc = do
+ let (s, p) = break ((==) ':') desc
+ when (p == "") (error "missing port: expecting [source]:port")
+ pn <- if and $ map isDigit $ drop 1 p
+ then return $ fromIntegral $ (read (drop 1 p) :: Int)
+ else do
+ service <- getServiceByName (drop 1 p) "tcp"
+ return $ servicePort service
+ he <- getHostByName s
+ return $ AddrSocket AF_INET (SockAddrInet pn (head $ hostAddresses he))
+
+getAddressDescription "unix" desc = do
+ return $ AddrSocket AF_UNIX (SockAddrUnix desc)
+
+getAddressDescription "fd" _ =
+ return $ AddrFD stdin stdout
+
+getAddressDescription _ _ = error "unrecognized source type (expecting tcp/unix/fd)"
+
+connectAddressDescription (AddrSocket family sockaddr) = do
+ sock <- socket family Stream defaultProtocol
+ catch (connect sock sockaddr)
+ (\_ -> sClose sock >> error ("cannot open socket " ++ show sockaddr))
+ return $ StunnelSocket sock
+
+connectAddressDescription (AddrFD h1 h2) = do
+ return $ StunnelFd h1 h2
+
+listenAddressDescription (AddrSocket family sockaddr) = do
+ sock <- socket family Stream defaultProtocol
+ catch (bindSocket sock sockaddr >> listen sock 10 >> setSocketOption sock ReuseAddr 1)
+ (\_ -> sClose sock >> error ("cannot open socket " ++ show sockaddr))
+ return $ StunnelSocket sock
+
+listenAddressDescription (AddrFD _ _) = do
+ error "cannot listen on fd"
+
+doClient :: Stunnel -> IO ()
+doClient pargs = do
+ srcaddr <- getAddressDescription (sourceType pargs) (source pargs)
+ dstaddr <- getAddressDescription (destinationType pargs) (destination pargs)
+
+ let clientstate = defaultParams
+ { pConnectVersion = TLS10
+ , pAllowedVersions = [ TLS10, TLS11 ]
+ , pCiphers = ciphers
+ , pCertificates = []
+ }
+
+ case srcaddr of
+ AddrSocket _ _ -> do
+ (StunnelSocket srcsocket) <- listenAddressDescription srcaddr
+ forever $ do
+ (s, _) <- accept srcsocket
+ rng <- getRandomGen
+ srch <- socketToHandle s ReadWriteMode
+
+ (StunnelSocket dst) <- connectAddressDescription dstaddr
+
+ dsth <- socketToHandle dst ReadWriteMode
+ dstctx <- client clientstate rng dsth
+ _ <- forkIO $ finally
+ (tlsclient srch dstctx)
+ (hClose srch >> hClose dsth)
+ return ()
+ AddrFD _ _ -> error "bad error fd. not implemented"
+
+doServer :: Stunnel -> IO ()
+doServer pargs = do
+ cert <- readCertificate $ certificate pargs
+ pk <- readPrivateKey $ key pargs
+ srcaddr <- getAddressDescription (sourceType pargs) (source pargs)
+ dstaddr <- getAddressDescription (destinationType pargs) (destination pargs)
+
+ case srcaddr of
+ AddrSocket _ _ -> do
+ (StunnelSocket srcsocket) <- listenAddressDescription srcaddr
+ forever $ do
+ (s, addr) <- accept srcsocket
+ srch <- socketToHandle s ReadWriteMode
+ (StunnelSocket dst) <- connectAddressDescription dstaddr
+ dsth <- socketToHandle dst ReadWriteMode
+ _ <- forkIO $ finally
+ (clientProcess [(cert, Just pk)] srch dsth addr >> return ())
+ (hClose srch >> hClose dsth)
+ return ()
+ AddrFD _ _ -> error "bad error fd. not implemented"
+
+main :: IO ()
+main = do
+ x <- cmdArgsRun mode
+ case x of
+ Client _ _ _ _ -> doClient x
+ Server _ _ _ _ _ _ -> doServer x
Oops, something went wrong.

0 comments on commit bd3c954

Please sign in to comment.