diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/acid-state-tls.cabal b/acid-state-tls.cabal new file mode 100644 --- /dev/null +++ b/acid-state-tls.cabal @@ -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 +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 diff --git a/examples/RemoteClientTLS.hs b/examples/RemoteClientTLS.hs new file mode 100644 --- /dev/null +++ b/examples/RemoteClientTLS.hs @@ -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 [ "] diff --git a/examples/RemoteCommon.hs b/examples/RemoteCommon.hs new file mode 100644 --- /dev/null +++ b/examples/RemoteCommon.hs @@ -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]) diff --git a/examples/RemoteServerTLS.hs b/examples/RemoteServerTLS.hs new file mode 100644 --- /dev/null +++ b/examples/RemoteServerTLS.hs @@ -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)) diff --git a/examples/ssl/test.crt b/examples/ssl/test.crt new file mode 100644 --- /dev/null +++ b/examples/ssl/test.crt @@ -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----- diff --git a/examples/ssl/test.csr b/examples/ssl/test.csr new file mode 100644 --- /dev/null +++ b/examples/ssl/test.csr @@ -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----- diff --git a/examples/ssl/test.key b/examples/ssl/test.key new file mode 100644 --- /dev/null +++ b/examples/ssl/test.key @@ -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----- diff --git a/examples/ssl/test.key.org b/examples/ssl/test.key.org new file mode 100644 --- /dev/null +++ b/examples/ssl/test.key.org @@ -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----- diff --git a/src/Data/Acid/Remote/TLS.hs b/src/Data/Acid/Remote/TLS.hs new file mode 100644 --- /dev/null +++ b/src/Data/Acid/Remote/TLS.hs @@ -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 + ) +