diff --git a/Network/Secure.hs b/Network/Secure.hs --- a/Network/Secure.hs +++ b/Network/Secure.hs @@ -20,16 +20,10 @@ -- $internals -- * Managing identities - - -- ** Authenticating peers - PeerIdentity - , writePeerIdentity - , readPeerIdentity - - -- ** Authenticating to peers + Identity(..) + , PeerIdentity , LocalIdentity - , writeLocalIdentity - , readLocalIdentity + , toPeerIdentity , newLocalIdentity @@ -66,7 +60,7 @@ -- -- > do -- > id <- newLocalIdentity "server1.domain.com" 365 --- > writeLocalIdentity id >>= writeFile "server.key" +-- > writeIdentity id >>= writeFile "server.key" -- -- The name is not used at all by the library, it just allows you to -- identify the key later on if you need to. @@ -76,8 +70,8 @@ -- that can be given to other hosts. -- -- > do --- > id <- readFile "server.key" >>= readLocalIdentity --- > writePeerIdentity (toPeerIdentity id) >>= writeFile "server.pub" +-- > id <- readFile "server.key" >>= readIdentity +-- > writeIdentity (toPeerIdentity id) >>= writeFile "server.pub" -- -- This public file should be distributed to the servers with whom you -- want to communicate. Once everyone has the public identities of @@ -85,16 +79,16 @@ -- start listening for connections. -- -- > do --- > me <- readFile "a.key" >>= readLocalIdentity --- > you <- readFile "b.pub" >>= readPeerIdentity +-- > me <- readFile "a.key" >>= readIdentity +-- > you <- readFile "b.pub" >>= readIdentity -- > server <- newServer (Nothing, "4242") -- > conn <- accept me [you] server -- -- Then, another host needs to connect. -- -- > do --- > me <- readFile "b.key" >>= readLocalIdentity --- > you <- readFile "a.pub" >>= readPeerIdentity +-- > me <- readFile "b.key" >>= readIdentity +-- > you <- readFile "a.pub" >>= readIdentity -- > conn <- connect me you ("a.com", "4242") -- -- Et voila! From there on, you can communicate using the usual diff --git a/Network/Secure/Identity.hs b/Network/Secure/Identity.hs --- a/Network/Secure/Identity.hs +++ b/Network/Secure/Identity.hs @@ -1,12 +1,9 @@ module Network.Secure.Identity ( - PeerIdentity - , readPeerIdentity - , writePeerIdentity - + Identity(..) + , PeerIdentity , LocalIdentity - , readLocalIdentity - , writeLocalIdentity + , toPeerIdentity , newLocalIdentity @@ -19,6 +16,7 @@ import Control.Applicative ((<$>)) import Control.Exception (bracket) import Control.Monad (when) +import Control.Monad.IO.Class (MonadIO, liftIO) import Data.ByteString (ByteString, append, hPut) import Data.ByteString.Char8 (pack, unpack) import Data.Maybe (fromJust, isNothing) @@ -34,6 +32,18 @@ import System.IO (openBinaryTempFile, hFlush) import System.IO.Unsafe (unsafePerformIO) +-- |An identity, public or private. +class Identity a where + -- |Return the description that was associated with the identity + -- when it was created. + identityName :: a -> String + -- |Serialize an identity to a 'ByteString' for storage or + -- transmission. + writeIdentity :: (Functor m, MonadIO m) => a -> m ByteString + -- |Read back an identity previously serialized with + -- writeIdentity. + readIdentity :: (Functor m, MonadIO m) => ByteString -> m a + -- |The public identity of a peer. This kind of identity can be used -- to authenticate the remote ends of connections. data PeerIdentity = PI @@ -42,18 +52,6 @@ , _piCN :: String } --- |Serialize a 'PeerIdentity' to a 'ByteString' for storage or --- transmission. -writePeerIdentity :: PeerIdentity -> IO ByteString -writePeerIdentity (PI cert _) = pack <$> writeX509 cert - --- |Read back a 'PeerIdentity' previously serialized with --- 'writePeerIdentity'. -readPeerIdentity :: ByteString -> IO PeerIdentity -readPeerIdentity b = do - cert <- readX509 (unpack b) - PI cert <$> getCN cert - instance Eq PeerIdentity where a == b = compare a b == EQ @@ -63,6 +61,13 @@ instance Show PeerIdentity where show (PI _ cn) = "PeerIdentity " ++ cn +instance Identity PeerIdentity where + identityName (PI _ cn) = cn + writeIdentity (PI cert _) = liftIO $ pack <$> writeX509 cert + readIdentity b = do + cert <- liftIO $ readX509 (unpack b) + PI cert <$> getCN cert + fromX509 :: X509 -> IO PeerIdentity fromX509 cert = PI cert <$> getCN cert @@ -86,26 +91,22 @@ LT -> LT instance Show LocalIdentity where - show (LI _ _ cn) = "LocalIdentity " ++ cn - --- |Serialize a 'LocalIdentity' to a 'ByteString' for storage. -writeLocalIdentity :: LocalIdentity -> IO ByteString -writeLocalIdentity (LI cert key _) = do - c <- writeX509 cert - k <- writePKCS8PrivateKey key Nothing - return $ pack (c ++ k) + show (LI _ _ cn) = cn --- |Read back a 'LocalIdentity' previously serialized with --- 'writeLocalIdentity'. -readLocalIdentity :: ByteString -> IO LocalIdentity -readLocalIdentity b = do - (PI cert cn) <- readPeerIdentity b - key <- toKeyPair <$> readPrivateKey (unpack b) PwNone - when (isNothing key) $ fail "Bad private key" - certMatchesKey cert (fromJust key) >>= \r -> - if r - then return $ LI cert (fromJust key) cn - else fail "Cert and key don't match" +instance Identity LocalIdentity where + identityName (LI _ _ cn) = cn + writeIdentity (LI cert key _) = do + c <- liftIO $ writeX509 cert + k <- liftIO $ writePKCS8PrivateKey key Nothing + return $ pack (c ++ k) + readIdentity b = do + (PI cert cn) <- readIdentity b + key <- liftIO $ toKeyPair <$> readPrivateKey (unpack b) PwNone + when (isNothing key) $ fail "Bad private key" + liftIO (certMatchesKey cert $ fromJust key) >>= \r -> + if r + then return $ LI cert (fromJust key) cn + else fail "Cert and key don't match" -- |Extract the public parts of a 'LocalIdentity' into a -- 'PeerIdentity' suitable for sharing with peers. The resulting @@ -119,12 +120,13 @@ -- -- Note that this function may take quite a while to execute, as it is -- generating key material for the identity. -newLocalIdentity :: String -> Int -> IO LocalIdentity -newLocalIdentity commonName days = bracket mkKeyFile rmKeyFile $ \(p,h) -> do - key <- run genKey - hPut h key >> hFlush h - cert <- run $ genCert p - readLocalIdentity $ append key cert +newLocalIdentity :: (MonadIO m) => String -> Int -> m LocalIdentity +newLocalIdentity commonName days = + liftIO $ bracket mkKeyFile rmKeyFile $ \(p,h) -> do + key <- run genKey + hPut h key >> hFlush h + cert <- run $ genCert p + readIdentity $ append key cert where mkKeyFile = getTemporaryDirectory >>= flip openBinaryTempFile "key.pem" rmKeyFile = removeFile . fst @@ -141,5 +143,5 @@ contextSetCertificate ctx cert contextCheckPrivateKey ctx -getCN :: X509 -> IO String -getCN cert = fromJust . lookup "CN" <$> getSubjectName cert False +getCN :: MonadIO m => X509 -> m String +getCN cert = liftIO $ fromJust . lookup "CN" <$> getSubjectName cert False diff --git a/secure-sockets.cabal b/secure-sockets.cabal --- a/secure-sockets.cabal +++ b/secure-sockets.cabal @@ -1,5 +1,5 @@ Name: secure-sockets -Version: 1.0.1 +Version: 1.1.0 Synopsis: Secure point-to-point connectivity library Description: This library simplifies the task of securely connecting two @@ -25,7 +25,8 @@ directory ==1.0.*, HSH ==2.0.*, HsOpenSSL ==0.8.*, - network ==2.* + network ==2.*, + transformers ==0.2.* ghc-prof-options: -auto-all ghc-options: -Wall -funbox-strict-fields -fwarn-tabs