acid-state-tls (empty) → 0.9.0
raw patch · 10 files changed
+467/−0 lines, 10 filesdep +HsOpenSSLdep +acid-statedep +basesetup-changed
Dependencies added: HsOpenSSL, acid-state, base, directory, network, safecopy
Files
- Setup.hs +2/−0
- acid-state-tls.cabal +36/−0
- examples/RemoteClientTLS.hs +80/−0
- examples/RemoteCommon.hs +36/−0
- examples/RemoteServerTLS.hs +22/−0
- examples/ssl/test.crt +16/−0
- examples/ssl/test.csr +13/−0
- examples/ssl/test.key +15/−0
- examples/ssl/test.key.org +18/−0
- src/Data/Acid/Remote/TLS.hs +229/−0
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ acid-state-tls.cabal view
@@ -0,0 +1,36 @@+Name: acid-state-tls+Version: 0.9.0+Synopsis: Add TLS support for Data.Acid.Remote+Description: Adds TLS support for connections to remote AcidState databases+Homepage: http://acid-state.seize.it/+License: PublicDomain+Author: David Himmelstrup, Jeremy Shaw+Maintainer: Lemmih <lemmih@gmail.com>+Copyright: 2013, David Himmelstrup, Jeremy Shaw+Category: Database+Build-type: Simple+Cabal-version: >=1.6+Extra-source-files:+ examples/*.hs+ examples/ssl/test.crt+ examples/ssl/test.key+ examples/ssl/test.csr+ examples/ssl/test.key.org++Source-repository head+ type: git+ location: https://github.com/acid-state/acid-state-tls++Library+ Hs-Source-Dirs: src++ Exposed-Modules: Data.Acid.Remote.TLS++ Build-depends: acid-state >= 0.9 && < 0.13,+ base >= 4 && < 5,+ directory < 1.3,+ HsOpenSSL < 0.11,+ network < 2.5,+ safecopy >= 0.6 && < 0.9++ GHC-Options: -fwarn-unused-imports -fwarn-unused-binds
+ examples/RemoteClientTLS.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell #-}+module Main (main) where++import Control.Monad ( replicateM_ )+import Data.Acid ( AcidState, createCheckpoint, query, update )+import Data.Acid.Advanced ( scheduleUpdate )+import Data.Acid.Remote ( sharedSecretPerform )+import Data.Acid.Remote.TLS ( openRemoteStateTLS )+import Data.ByteString.Char8 ( pack )+import Network ( PortID(..) )+import RemoteCommon ( StressState(..), ClearState(..), PokeState(..), QueryState(..) )+import System.Environment ( getArgs )+import System.IO ( hFlush, stdout )++------------------------------------------------------+-- printHelp++printHelp :: IO ()+printHelp+ = do putStrLn $ "Commands:"+ putStrLn $ " query Prints out the current state."+ putStrLn $ " poke Spawn 100k transactions."+ putStrLn $ " checkpoint Create a new checkpoint."+ putStrLn $ " clear Clear the state and create a new checkpoint."+ putStrLn $ " quit Exit with out creating a checkpoint."++------------------------------------------------------+-- interactive command loop++commandLoop :: AcidState StressState -> IO ()+commandLoop acid+ = do printHelp+ go+ where+ go = do+ putStr "> "+ hFlush stdout+ cmd <- getLine+ case cmd of+ "checkpoint"+ -> do createCheckpoint acid+ go+ "query"+ -> do n <- query acid QueryState+ putStrLn $ "State value: " ++ show n+ go+ "poke"+ -> do putStr "Issuing 100k transactions... "+ hFlush stdout+ replicateM_ (100000-1) (scheduleUpdate acid PokeState)+ update acid PokeState+ putStrLn "Done"+ go+ "clear"+ -> do update acid ClearState+ createCheckpoint acid+ go+ "quit"+ -> return ()++ _+ -> do printHelp+ go++------------------------------------------------------+-- connect to remote server and start command-loop++main :: IO ()+main+ = do args <- getArgs+ case args of+ [] ->+ do acid <- openRemoteStateTLS (sharedSecretPerform $ (pack "12345")) "localhost" (PortNumber 8080)+ commandLoop acid++ [hostname, port] ->+ do acid <- openRemoteStateTLS (sharedSecretPerform $ (pack "12345")) hostname (PortNumber $ fromIntegral $ read port)+ commandLoop acid++ _ -> putStrLn "Usage: RemoteClientTLS [<hostname> <port>"]
+ examples/RemoteCommon.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, TypeFamilies #-}+module RemoteCommon where++import Data.Acid++import Control.Monad.State+import Control.Monad.Reader+import System.Environment+import System.IO+import Data.SafeCopy++import Data.Typeable++------------------------------------------------------+-- The Haskell structure that we want to encapsulate++data StressState = StressState !Int+ deriving (Typeable)++$(deriveSafeCopy 0 'base ''StressState)++------------------------------------------------------+-- The transaction we will execute over the state.++pokeState :: Update StressState ()+pokeState = do StressState i <- get+ put (StressState (i+1))++queryState :: Query StressState Int+queryState = do StressState i <- ask+ return i++clearState :: Update StressState ()+clearState = put $ StressState 0++$(makeAcidic ''StressState ['pokeState, 'queryState, 'clearState])
+ examples/RemoteServerTLS.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell #-}+module Main (main) where++import Control.Exception ( bracket )+import Data.Acid ( openLocalState, closeAcidState )+import Data.Acid.Remote ( sharedSecretCheck )+import Data.Acid.Remote.TLS ( acidServerTLS )+import Data.ByteString.Char8 ( pack )+import Data.Set ( singleton )+import Network ( PortID(..) )+import Network.Socket ( PortNumber(PortNum) )+import RemoteCommon ( StressState(..) )++-- | open a server on port 8080+main :: IO ()+main =+ let secrets = singleton $ pack "12345" in+ bracket+ (openLocalState $ StressState 0)+ closeAcidState+ -- do not use the provided 'ssl/test.crt' and 'ssl/test.key' in your real application.+ (acidServerTLS "ssl/test.crt" "ssl/test.key" (sharedSecretCheck secrets) (PortNumber 8080))
+ examples/ssl/test.crt view
@@ -0,0 +1,16 @@+-----BEGIN CERTIFICATE-----+MIICiTCCAfICCQDHSqF1duBmujANBgkqhkiG9w0BAQUFADCBiDELMAkGA1UEBhMC+VVMxETAPBgNVBAgTCElsbGlub2lzMREwDwYDVQQHEwhFdmFuc3RvbjEWMBQGA1UE+ChMNaGFwcHN0YWNrLmNvbTEWMBQGA1UEAxMNaGFwcHN0YWNrLmNvbTEjMCEGCSqG+SIb3DQEJARYUamVyZW15QGhhcHBzdGFjay5jb20wHhcNMTIwMTE1MDE1ODM5WhcN+MTMwMTE0MDE1ODM5WjCBiDELMAkGA1UEBhMCVVMxETAPBgNVBAgTCElsbGlub2lz+MREwDwYDVQQHEwhFdmFuc3RvbjEWMBQGA1UEChMNaGFwcHN0YWNrLmNvbTEWMBQG+A1UEAxMNaGFwcHN0YWNrLmNvbTEjMCEGCSqGSIb3DQEJARYUamVyZW15QGhhcHBz+dGFjay5jb20wgZ8wDQYJKoZIhvcNAQEBBQADgY0AMIGJAoGBALjSDPy2Vub56A/G+DmVef/V6l+/dtBd+lJaEy1IW4Qy8pWIB4vG/wpSIshRdRk+G6xB6pamo0nP4cH8m+qrOlQXCyJz6Bd2aY2eJJ0s2sWagEFz1FRZT1Igj+RtnkNrBmBRvv0w41n4tZrcsi+39Z4szh3QkcCwpPFbsVtYmHx4sr1AgMBAAEwDQYJKoZIhvcNAQEFBQADgYEAbBp0+VmLnErEEJ97EmNN/D9mQNbJFVUMtYjTpfDaAmhuLIDjHSqWSKIVr2HE4ClJtzYGc+VOBr816LOYClESC2sbqcuwIWLqm8+eFc3VKf3pAp8zKxrQya+0sIdLSm2f2PYwvg+s3DfqUlPdCXCZgDU9dHE9i4KawNQZC5JdD2saNQ=+-----END CERTIFICATE-----
+ examples/ssl/test.csr view
@@ -0,0 +1,13 @@+-----BEGIN CERTIFICATE REQUEST-----+MIIB3jCCAUcCAQAwgYgxCzAJBgNVBAYTAlVTMREwDwYDVQQIEwhJbGxpbm9pczER+MA8GA1UEBxMIRXZhbnN0b24xFjAUBgNVBAoTDWhhcHBzdGFjay5jb20xFjAUBgNV+BAMTDWhhcHBzdGFjay5jb20xIzAhBgkqhkiG9w0BCQEWFGplcmVteUBoYXBwc3Rh+Y2suY29tMIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQC40gz8tlbm+egPxg5l+Xn/1epfv3bQXfpSWhMtSFuEMvKViAeLxv8KUiLIUXUZPhusQeqWpqNJz+HB/Jqqz+pUFwsic+gXdmmNniSdLNrFmoBBc9RUWU9SII/kbZ5DawZgUb79MONZ+LWa3LIt/W+eLM4d0JHAsKTxW7FbWJh8eLK9QIDAQABoBUwEwYJKoZIhvcNAQkHMQYTBDEyMzQw+DQYJKoZIhvcNAQEFBQADgYEAB/ejt7aB1NDoNOyVEQxXeQyglQodZcJ5/fdtiOkc+mw6YcWoQMir76pIDVA0ywdvb/p9RdKYlVOCnPkCZVG4H7RMRufaxFwKS3K8vBsh++1F7jGBk+0qMdqIAtR8YYnJs+jXermDybf2z/5kSQloR+iFKIPASTLt1LkpyzrAuT+pGY=+-----END CERTIFICATE REQUEST-----
+ examples/ssl/test.key view
@@ -0,0 +1,15 @@+-----BEGIN RSA PRIVATE KEY-----+MIICXAIBAAKBgQC40gz8tlbm+egPxg5lXn/1epfv3bQXfpSWhMtSFuEMvKViAeLx+v8KUiLIUXUZPhusQeqWpqNJz+HB/JqqzpUFwsic+gXdmmNniSdLNrFmoBBc9RUWU+9SII/kbZ5DawZgUb79MONZ+LWa3LIt/WeLM4d0JHAsKTxW7FbWJh8eLK9QIDAQAB+AoGBAIZQwPd3XDiILcoo2ZV50+yGp5y+tn7MkxfAcjK6RduHzXkofdHK1pIztZdv+IgXxuytCttpRwoBdcQQ3CZ983czYWIW6BF3Gz9mG/YMpKAjj2clxyLiqmEoiH8Sq+EjIXpShVSQmG1PHdxI8wQaBSYCZtQxzWEZ5Yn5G6CnF0nj8BAkEA5PZ6itklpowc+2y4ko+F7vOFII9IM3BCSV4sYhMLOCg3mu1nZYzl5AwvdG1NRxl4RpbvtxU2XJwee+lxD0EOK/0QJBAM6lJ7WiUXwAlaTfCuh11wgNDsLL/aRRfIeBWLOAi/voan2AX0j1+K+4mtVnpLhhC6lTcGcQOFfSFfzyBqAUUJeUCQAW6xUZEONT6HJ6/gNs5AUewu4Vp+9DhtkbvvFyX7WfyWbHezv+Tjw0t4OIg+hYVZRUfIdCLD1kx7vFQ7cGAbzIECQG9L+khyIZLyVkAMxQa27sembJsURmvVCEgDlUEG1TS+KmLgpSKiBq3xjiq73IKVefNjh+hlsKfxaoQ8PxzO2XUWUCQGrCJ91qayZsvMeP8GQYR4s87PVEeZ1mg37GmTCpe2LS++0zx4DNXMf6ViPbWNDYDyaxiRR3iKG/FFFBUrm5MUnU=+-----END RSA PRIVATE KEY-----
+ examples/ssl/test.key.org view
@@ -0,0 +1,18 @@+-----BEGIN RSA PRIVATE KEY-----+Proc-Type: 4,ENCRYPTED+DEK-Info: DES-EDE3-CBC,6B91961E798459C4++TQRgOqwNHbReJYutPLerPhCuXhIIlA2Sup83px9KhMD+kGfEYaJfDsbPYnHJ4LYE+x24mDrW81Bh9u+4JX72NBhJmGL3X3E7d69DH2QA4f6m5y+SpobPKnWSvb81qRKpp+zP4xl7F8395sm6S2DDNNNJKiXAOHSw5SnOo7Vr+gE0PQMG5j6n4X91QSj8FPpQS6+x4+LzdE3rm/GoNDUTUZYogQT5KCDtjdrlHOV4K6hZ1XpUsArtGT2Oi8KWu2Cb4Zm+drm+Jff0WFftCW8tAIOuqexq0KK80HIou6D0I+i3mQ7PX7Sp+M3iFEH62w5wqYHB+TMlseDCsZ9wZr/0xaR2z9KSv9W/jddMd7Tg3nToZ1FA9OoCFTUChQtLsBAadI993+FXaUZlkPZwOA8q1KIWowNecKrC5y3CQNGNT22LAlaubwH6fSkDE5ZvaB45snifWm+UcrE4ax3W4syJ6CxT7gCpqCaSAmHOK1Tjd58ASHayhdbTMLOizZHLRpmsfq2Iw2R+iHgn+rohNyAcAxl8LJFFEsmYjErJLn3uRSDTkf5DdwuOmiFX+Lip/UJ41ROlwwlz+TO6TqQid0QG9nUS28socRg2tPar+n2kjXZ+iqFljfLCRGwDu9cdFCFnq1Yl5G3h4+SivtCINOl0fLQ8zrY7x2h30DtmdQ/JfT80ecvnb8QmT1M7niym4qlpLc9vFic2Lv+WGlwOvZJHKq9yLiJ+NSK6xDbsY5AOcFE/mvs1WBzs25VcGLS9tg5L6WZRnChfgr6+8faRmGF5/1gxTQBiMBpp7u63dXlg24av7+JNKsTVnj2W9QeQdHTWqQ==+-----END RSA PRIVATE KEY-----
+ src/Data/Acid/Remote/TLS.hs view
@@ -0,0 +1,229 @@+{-# LANGUAGE CPP, DeriveDataTypeable, RecordWildCards, ScopedTypeVariables #-}+-----------------------------------------------------------------------------+{- |+ Module : Data.Acid.Remote.TLS+ Copyright : PublicDomain++ Maintainer : lemmih@gmail.com, jeremy@n-heptane.com+ Portability : non-portable (uses GHC extensions)++This module provides the same functionality as "Data.Acid.Remote" but+over a secured TLS socket.++-}+module Data.Acid.Remote.TLS+ (+ -- * Server/Client+ acidServerTLS+ , openRemoteStateTLS+ -- * Authentication+ , skipAuthenticationCheck+ , skipAuthenticationPerform+ , sharedSecretCheck+ , sharedSecretPerform++ ) where++import Control.Concurrent ( forkIO, threadDelay )+import Control.Exception ( Handler(..), IOException, SomeException, catch, catches, handle+ , finally, throwIO )+import Control.Monad ( forever, when )+import Data.Acid ( AcidState, IsAcidic )+import Data.Acid.Remote ( CommChannel(..), process, processRemoteState, skipAuthenticationCheck+ , skipAuthenticationPerform, sharedSecretCheck, sharedSecretPerform )+import Data.SafeCopy ( SafeCopy )+import GHC.IO.Exception ( IOErrorType(..) )+import OpenSSL ( withOpenSSL )+import OpenSSL.Session ( SomeSSLException, SSL, SSLContext )+import qualified OpenSSL.Session as SSL+import Network ( HostName, PortID(..), Socket, listenOn, sClose, withSocketsDo )+import Network.Socket as Socket ( Family(..), SockAddr(..), SocketType(..), accept, socket, connect )+import Network.BSD ( getHostByName, getProtocolNumber, getServicePortNumber, hostAddress )+import System.Directory ( removeFile )+import System.IO.Error ( ioeGetErrorType, isFullError, isDoesNotExistError )++debugStrLn :: String -> IO ()+debugStrLn s =+ do putStrLn s -- uncomment to enable debugging+ return ()++initSSLContext :: FilePath -- ^ path to ssl certificate+ -> FilePath -- ^ path to ssl private key+ -> IO SSLContext+initSSLContext cert key =+ do ctx <- SSL.context+ SSL.contextSetPrivateKeyFile ctx key+ SSL.contextSetCertificateFile ctx cert+ SSL.contextSetDefaultCiphers ctx++ certOk <- SSL.contextCheckPrivateKey ctx+ when (not certOk) $ error $ "OpenTLS certificate and key do not match."++ return ctx++-- | accept a TLS connection+acceptTLS :: SSLContext -> Socket -> IO (Socket, SSL, SockAddr)+acceptTLS ctx sck' =+ do -- do normal accept+ (sck, sockAddr) <- accept sck'+ -- then TLS accept+ handle (\ (e :: SomeException) -> sClose sck >> throwIO e) $ do+ ssl <- SSL.connection ctx sck+ SSL.accept ssl+ return (sck, ssl, sockAddr)++{- | Accept connections on @port@ and handle requests using the given 'AcidState'.+ This call doesn't return.++ The connection is secured using TLS/SSL.++ On Unix®-like systems you can use 'UnixSocket' to communicate+ using a socket file. To control access, you can set the permissions of+ the parent directory which contains the socket file.++ see also: 'openRemoteStateTLS' and 'sharedSecretCheck'.+ -}+acidServerTLS :: SafeCopy st =>+ FilePath -- ^ path to ssl certificate+ -> FilePath -- ^ path to ssl private key+ -> (CommChannel -> IO Bool) -- ^ authorization function+ -> PortID -- ^ port to list on+ -> AcidState st -- ^ 'AcidState' to serve+ -> IO ()+acidServerTLS sslCert sslKey checkAuth port acidState+ = withSocketsDo $+ do withOpenSSL $ return ()+ debugStrLn $ "acidServerTLS: listenOn " ++ show port+ tlsSocket <- listenOn port+ debugStrLn $ "acidServerTLS: initSSLContext"+ ctx <- initSSLContext sslCert sslKey+ let worker :: (Socket, SSL, SockAddr) -> IO ()+ worker (socket, ssl, _sockAddr) =+ do -- TODO: log this connection, sockAddr+ let socketCommChannel :: CommChannel+ socketCommChannel = CommChannel+ { ccPut = SSL.write ssl+ , ccGetSome = SSL.read ssl+ , ccClose = shutdownClose socket ssl+ }+ forkIO $ (do authorized <- checkAuth socketCommChannel+ when authorized $+ ignoreSome $ (process socketCommChannel acidState)+ ccClose socketCommChannel) `catch` (\(e::SomeException) -> do+ shutdownClose socket ssl+ throwIO e)+ return ()+ loop :: IO ()+ loop = do ignoreSome $ (forever $ worker =<< acceptTLS ctx tlsSocket)+ loop+ loop `finally` (cleanup tlsSocket `catch` ignoreException)++ where+ cleanup tlsSocket+ = do debugStrLn "acidServerTLS: cleanup."+ sClose tlsSocket+#if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) && !defined(_WIN32)+ case port of+ (UnixSocket path) ->+ removeFile path `catch` (\e -> if isDoesNotExistError e then return () else throwIO e)+ _ -> return ()+#endif++ -- exception handlers+ ignoreConnectionAbruptlyTerminated :: SSL.ConnectionAbruptlyTerminated -> IO ()+ ignoreConnectionAbruptlyTerminated _ = return ()++ ignoreSSLException :: SSL.SomeSSLException -> IO ()+ ignoreSSLException _ = return ()++ ignoreException :: SomeException -> IO ()+ ignoreException _ = return ()++ shutdownClose :: Socket -> SSL -> IO ()+ shutdownClose socket ssl =+ do debugStrLn "acidServerTLS: shutdownClose."+ SSL.shutdown ssl SSL.Unidirectional `catch` ignoreException+ sClose socket `catch` ignoreException++ ignoreSome op =+ op `catches` [ Handler $ ignoreSSLException+ , Handler $ ignoreConnectionAbruptlyTerminated+ , Handler $ \(e :: IOException) ->+ if isFullError e || isDoesNotExistError e || isResourceVanishedError e+ then return ()+ else throwIO e+ ]++ isResourceVanishedError :: IOException -> Bool+ isResourceVanishedError = isResourceVanishedType . ioeGetErrorType++ isResourceVanishedType :: IOErrorType -> Bool+ isResourceVanishedType ResourceVanished = True+ isResourceVanishedType _ = False++{- | Connect to an acid-state server which is sharing an 'AcidState'.++The connection is secured using SSL/TLS.+ -}+openRemoteStateTLS :: IsAcidic st =>+ (CommChannel -> IO ()) -- ^ authentication function, see 'sharedSecretPerform'+ -> HostName -- ^ remote host to connect to (ignored when 'PortID' is 'UnixSocket')+ -> PortID -- ^ remote port to connect to+ -> IO (AcidState st)+openRemoteStateTLS performAuthorization host port+ = do withOpenSSL $ return ()+ processRemoteState reconnect+ where+ sslCommChannel ssl =+ CommChannel { ccGetSome = SSL.read ssl+ , ccPut = SSL.write ssl+ , ccClose = do SSL.shutdown ssl SSL.Unidirectional+ -- close ssl+ }++ -- | reconnect+ reconnect :: IO CommChannel+ reconnect+ = (do ssl <- connectToTLS host port+ let cc = sslCommChannel ssl+ performAuthorization cc+ return cc+ )+ `catch`+ ((\e -> threadDelay 1000000 >> reconnect) :: IOError -> IO CommChannel)++-- IPV4 support only, sorry+connectToTLS :: HostName+ -> PortID+ -> IO SSL+connectToTLS hostName (Service serv)+ = do port <- getServicePortNumber serv+ connectToTLS hostName (PortNumber port)++connectToTLS hostName (PortNumber port)+ = do proto <- getProtocolNumber "tcp"+ sock <- socket AF_INET Stream proto+ (do he <- getHostByName hostName+ Socket.connect sock (SockAddrInet port (hostAddress he))+ ctx <- SSL.context+ ssl <- SSL.connection ctx sock+ SSL.connect ssl+ return ssl) `catch` (\e -> do print (e :: SomeSSLException)+ sClose sock+ throwIO e+ )+connectToTLS _hostName p@(UnixSocket path)+ = do debugStrLn $ "connectToTLS: " ++ show p+ sock <- socket AF_UNIX Stream 0+ (do debugStrLn $ "connectToTLS: connect."+ Socket.connect sock (SockAddrUnix path)+ ctx <- SSL.context+ ssl <- SSL.connection ctx sock+ debugStrLn $ "connectToTLS: connect ssl."+ SSL.connect ssl+ debugStrLn $ "connectToTLS: done."+ return ssl) `catch` (\e -> do print (e :: SomeSSLException)+ sClose sock+ throwIO e+ )+