diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Channel.hs | 152 | ||||
| -rw-r--r-- | src/Identity.hs | 8 | ||||
| -rw-r--r-- | src/Main.hs | 6 | ||||
| -rw-r--r-- | src/Network.hs | 213 | ||||
| -rw-r--r-- | src/PubKey.hs | 36 |
5 files changed, 352 insertions, 63 deletions
diff --git a/src/Channel.hs b/src/Channel.hs new file mode 100644 index 0000000..ee10e89 --- /dev/null +++ b/src/Channel.hs @@ -0,0 +1,152 @@ +module Channel ( + Channel, + ChannelRequest, ChannelRequestData(..), + ChannelAccept, ChannelAcceptData(..), + + createChannelRequest, + acceptChannelRequest, + acceptedChannel, + + channelEncrypt, + channelDecrypt, +) where + +import Control.Monad +import Control.Monad.Except +import Control.Monad.Fail + +import Crypto.Cipher.AES +import Crypto.Cipher.Types +import Crypto.Data.Padding +import Crypto.Error +import Crypto.Random + +import Data.ByteArray +import qualified Data.ByteArray as BA +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.List +import qualified Data.Text as T + +import Identity +import PubKey +import Storage + +data Channel = Channel + { chPeers :: [Stored Identity] + , chKey :: ScrubbedBytes + } + deriving (Show) + +type ChannelRequest = Signed ChannelRequestData + +data ChannelRequestData = ChannelRequest + { crPeers :: [Stored Identity] + , crKey :: Stored PublicKexKey + } + +type ChannelAccept = Signed ChannelAcceptData + +data ChannelAcceptData = ChannelAccept + { caRequest :: Stored ChannelRequest + , caKey :: Stored PublicKexKey + } + + +instance Storable Channel where + store' ch = storeRec $ do + mapM_ (storeRef "peer") $ chPeers ch + storeText "enc" $ T.pack "aes-128-gcm" + storeBinary "key" $ chKey ch + + load' = loadRec $ do + enc <- loadText "enc" + guard $ enc == "aes-128-gcm" + Channel + <$> loadRefs "peer" + <*> loadBinary "key" + +instance Storable ChannelRequestData where + store' cr = storeRec $ do + mapM_ (storeRef "peer") $ crPeers cr + storeRef "key" $ crKey cr + + load' = loadRec $ ChannelRequest + <$> loadRefs "peer" + <*> loadRef "key" + +instance Storable ChannelAcceptData where + store' ca = storeRec $ do + storeRef "req" $ caRequest ca + storeText "enc" $ T.pack "aes-128-gcm" + storeRef "key" $ caKey ca + + load' = loadRec $ do + enc <- loadText "enc" + guard $ enc == "aes-128-gcm" + ChannelAccept + <$> loadRef "req" + <*> loadRef "key" + + +createChannelRequest :: Stored Identity -> Stored Identity -> IO (Stored ChannelRequest) +createChannelRequest self peer = do + let st = storedStorage self + (_, xpublic) <- generateKeys st + Just skey <- loadKey $ idKeyMessage $ fromStored $ signedData $ fromStored self + wrappedStore st =<< sign skey =<< wrappedStore st ChannelRequest { crPeers = sort [self, peer], crKey = xpublic } + +acceptChannelRequest :: Stored Identity -> Stored Identity -> Stored ChannelRequest -> ExceptT [String] IO (Stored ChannelAccept, Stored Channel) +acceptChannelRequest self peer req = do + guard $ (crPeers $ fromStored $ signedData $ fromStored req) == sort [self, peer] + guard $ (idKeyMessage $ fromStored $ signedData $ fromStored peer) `elem` (map (sigKey . fromStored) $ signedSignature $ fromStored req) + + let st = storedStorage self + KeySizeFixed ksize = cipherKeySize (undefined :: AES128) + liftIO $ do + (xsecret, xpublic) <- generateKeys st + Just skey <- loadKey $ idKeyMessage $ fromStored $ signedData $ fromStored self + acc <- wrappedStore st =<< sign skey =<< wrappedStore st ChannelAccept { caRequest = req, caKey = xpublic } + ch <- wrappedStore st Channel + { chPeers = crPeers $ fromStored $ signedData $ fromStored req + , chKey = BA.take ksize $ dhSecret xsecret $ + fromStored $ crKey $ fromStored $ signedData $ fromStored req + } + return (acc, ch) + +acceptedChannel :: Stored Identity -> Stored Identity -> Stored ChannelAccept -> ExceptT [String] IO (Stored Channel) +acceptedChannel self peer acc = do + let st = storedStorage self + req = caRequest $ fromStored $ signedData $ fromStored acc + KeySizeFixed ksize = cipherKeySize (undefined :: AES128) + + guard $ (crPeers $ fromStored $ signedData $ fromStored req) == sort [self, peer] + guard $ (idKeyMessage $ fromStored $ signedData $ fromStored peer) `elem` (map (sigKey . fromStored) $ signedSignature $ fromStored acc) + guard $ (idKeyMessage $ fromStored $ signedData $ fromStored self) `elem` (map (sigKey . fromStored) $ signedSignature $ fromStored req) + + Just xsecret <- liftIO $ loadKey $ crKey $ fromStored $ signedData $ fromStored req + liftIO $ wrappedStore st Channel + { chPeers = crPeers $ fromStored $ signedData $ fromStored req + , chKey = BA.take ksize $ dhSecret xsecret $ + fromStored $ caKey $ fromStored $ signedData $ fromStored acc + } + + +channelEncrypt :: (ByteArray ba, MonadRandom m, MonadFail m) => Channel -> ba -> m ba +channelEncrypt ch plain = do + CryptoPassed (cipher :: AES128) <- return $ cipherInit $ chKey ch + let bsize = blockSize cipher + (iv :: ByteString) <- getRandomBytes bsize + CryptoPassed aead <- return $ aeadInit AEAD_GCM cipher iv + let (tag, ctext) = aeadSimpleEncrypt aead B.empty (pad (PKCS7 bsize) plain) bsize + return $ BA.concat [ convert iv, convert tag, ctext ] + +channelDecrypt :: (ByteArray ba, MonadFail m) => Channel -> ba -> m ba +channelDecrypt ch body = do + CryptoPassed (cipher :: AES128) <- return $ cipherInit $ chKey ch + let bsize = blockSize cipher + (iv, body') = BA.splitAt bsize body + (tag, ctext) = BA.splitAt bsize body' + CryptoPassed aead <- return $ aeadInit AEAD_GCM cipher iv + Just plain <- return $ unpad (PKCS7 bsize) =<< aeadSimpleDecrypt aead B.empty ctext (AuthTag $ convert tag) + return plain diff --git a/src/Identity.hs b/src/Identity.hs index 07356d8..c1561b6 100644 --- a/src/Identity.hs +++ b/src/Identity.hs @@ -15,15 +15,17 @@ data IdentityData = Identity , idPrev :: Maybe (Stored Identity) , idOwner :: Maybe (Stored Identity) , idKeyIdentity :: Stored PublicKey + , idKeyMessage :: Stored PublicKey } deriving (Show) -emptyIdentity :: Stored PublicKey -> IdentityData -emptyIdentity key = Identity +emptyIdentity :: Stored PublicKey -> Stored PublicKey -> IdentityData +emptyIdentity key kmsg = Identity { idName = Nothing , idPrev = Nothing , idOwner = Nothing , idKeyIdentity = key + , idKeyMessage = kmsg } instance Storable IdentityData where @@ -32,9 +34,11 @@ instance Storable IdentityData where storeMbRef "prev" $ idPrev idt storeMbRef "owner" $ idOwner idt storeRef "key-id" $ idKeyIdentity idt + storeRef "key-msg" $ idKeyMessage idt load' = loadRec $ Identity <$> loadMbText "name" <*> loadMbRef "prev" <*> loadMbRef "owner" <*> loadRef "key-id" + <*> loadRef "key-msg" diff --git a/src/Main.hs b/src/Main.hs index 40540fe..2a4dc4e 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -26,11 +26,13 @@ main = do name <- T.getLine (secret, public) <- generateKeys st + (_secretMsg, publicMsg) <- generateKeys st (devSecret, devPublic) <- generateKeys st + (_devSecretMsg, devPublicMsg) <- generateKeys st - owner <- wrappedStore st =<< sign secret =<< wrappedStore st (emptyIdentity public) { idName = Just name } + owner <- wrappedStore st =<< sign secret =<< wrappedStore st (emptyIdentity public publicMsg) { idName = Just name } base <- signAdd devSecret =<< sign secret =<< - wrappedStore st (emptyIdentity devPublic) { idOwner = Just owner } + wrappedStore st (emptyIdentity devPublic devPublicMsg) { idOwner = Just owner } Right h <- replaceHead base (Left (st, "identity")) return h diff --git a/src/Network.hs b/src/Network.hs index f294835..1056265 100644 --- a/src/Network.hs +++ b/src/Network.hs @@ -11,12 +11,15 @@ import Control.Monad.Except import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as BL +import qualified Data.Map as M import qualified Data.Text as T import Network.Socket import Network.Socket.ByteString (recvFrom, sendTo) +import Channel import Identity +import PubKey import Storage @@ -25,8 +28,9 @@ discoveryPort = "29665" data Peer = Peer - { peerIdentity :: Stored Identity - , peerAddress :: PeerAddress + { peerAddress :: PeerAddress + , peerIdentity :: Maybe (Stored Identity) + , peerChannels :: [Channel] } deriving (Show) @@ -37,6 +41,8 @@ data PeerAddress = DatagramAddress SockAddr data TransportHeader = AnnouncePacket Ref | IdentityRequest Ref Ref | IdentityResponse Ref + | TrChannelRequest Ref + | TrChannelAccept Ref transportToObject :: TransportHeader -> Object transportToObject = \case @@ -53,6 +59,14 @@ transportToObject = \case [ (BC.pack "TRANS", RecText $ T.pack "idresp") , (BC.pack "identity", RecRef ref) ] + TrChannelRequest ref -> Rec + [ (BC.pack "TRANS", RecText $ T.pack "chreq") + , (BC.pack "req", RecRef ref) + ] + TrChannelAccept ref -> Rec + [ (BC.pack "TRANS", RecText $ T.pack "chacc") + , (BC.pack "acc", RecRef ref) + ] transportFromObject :: Object -> Maybe TransportHeader transportFromObject (Rec items) @@ -69,71 +83,152 @@ transportFromObject (Rec items) , Just (RecRef ref) <- lookup (BC.pack "identity") items = Just $ IdentityResponse ref + | Just (RecText trans) <- lookup (BC.pack "TRANS") items, trans == T.pack "chreq" + , Just (RecRef ref) <- lookup (BC.pack "req") items + = Just $ TrChannelRequest ref + + | Just (RecText trans) <- lookup (BC.pack "TRANS") items, trans == T.pack "chacc" + , Just (RecRef ref) <- lookup (BC.pack "acc") items + = Just $ TrChannelAccept ref + transportFromObject _ = Nothing peerDiscovery :: String -> Stored Identity -> IO (Chan Peer) peerDiscovery bhost sidentity = do - chan <- newChan + chanPeer <- newChan + peers <- newMVar M.empty + + let open addr = do + sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) + setSocketOption sock ReuseAddr 1 + setSocketOption sock Broadcast 1 + setCloseOnExecIfNeeded =<< fdSocket sock + bind sock (addrAddress addr) + return sock + + loop sock = do + baddr:_ <- getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just bhost) (Just discoveryPort) + void $ sendTo sock (BL.toStrict $ serializeObject $ transportToObject $ AnnouncePacket $ storedRef sidentity) (addrAddress baddr) + forever $ do + (msg, paddr) <- recvFrom sock 4096 + let packet' = packet sock paddr + case runExcept $ deserializeObjects (storedStorage sidentity) $ BL.fromStrict msg of + Left err -> putStrLn $ show paddr ++ ": " ++ err + Right (obj:objs) | Just tpack <- transportFromObject obj -> packet' tpack objs + _ -> putStrLn $ show paddr ++ ": invalid transport packet" + + packet sock paddr (AnnouncePacket ref) _ = do + putStrLn $ "Got announce: " ++ show ref ++ " from " ++ show paddr + when (ref /= storedRef sidentity) $ void $ sendTo sock (BL.toStrict $ BL.concat + [ serializeObject $ transportToObject $ IdentityRequest ref (storedRef sidentity) + , BL.concat $ map (lazyLoadBytes . storedRef) $ collectStoredObjects $ wrappedLoad $ storedRef sidentity + ]) paddr + + packet _ paddr (IdentityRequest ref from) [] = do + putStrLn $ "Got identity request: for " ++ show ref ++ " by " ++ show from ++ " from " ++ show paddr ++ " without content" + + packet sock paddr (IdentityRequest ref from) (obj:objs) = do + putStrLn $ "Got identity request: for " ++ show ref ++ " by " ++ show from ++ " from " ++ show paddr + print (obj:objs) + from' <- store (storedStorage sidentity) obj + if from == from' + then do forM_ objs $ store $ storedStorage sidentity + let peer = Peer (DatagramAddress paddr) (Just $ wrappedLoad from) [] + modifyMVar_ peers $ return . M.insert paddr peer + writeChan chanPeer peer + void $ sendTo sock (BL.toStrict $ BL.concat + [ serializeObject $ transportToObject $ IdentityResponse (storedRef sidentity) + , BL.concat $ map (lazyLoadBytes . storedRef) $ collectStoredObjects $ wrappedLoad $ storedRef sidentity + ]) paddr + else putStrLn $ "Mismatched content" + + packet _ paddr (IdentityResponse ref) [] = do + putStrLn $ "Got identity response: by " ++ show ref ++ " from " ++ show paddr ++ " without content" + + packet sock paddr (IdentityResponse ref) (obj:objs) = do + putStrLn $ "Got identity response: by " ++ show ref ++ " from " ++ show paddr + print (obj:objs) + ref' <- store (storedStorage sidentity) obj + if ref == ref' + then do forM_ objs $ store $ storedStorage sidentity + let pidentity = wrappedLoad ref + peer = Peer (DatagramAddress paddr) (Just pidentity) [] + modifyMVar_ peers $ return . M.insert paddr peer + writeChan chanPeer peer + req <- createChannelRequest sidentity pidentity + void $ sendTo sock (BL.toStrict $ BL.concat + [ serializeObject $ transportToObject $ TrChannelRequest (storedRef req) + , lazyLoadBytes $ storedRef req + , lazyLoadBytes $ storedRef $ signedData $ fromStored req + , lazyLoadBytes $ storedRef $ crKey $ fromStored $ signedData $ fromStored req + , BL.concat $ map (lazyLoadBytes . storedRef) $ signedSignature $ fromStored req + ]) paddr + else putStrLn $ "Mismatched content" + + packet _ paddr (TrChannelRequest _) [] = do + putStrLn $ "Got channel request: from " ++ show paddr ++ " without content" + + packet sock paddr (TrChannelRequest ref) (obj:objs) = do + putStrLn $ "Got channel request: from " ++ show paddr + print (obj:objs) + ref' <- store (storedStorage sidentity) obj + if ref == ref' + then do forM_ objs $ store $ storedStorage sidentity + let request = wrappedLoad ref :: Stored ChannelRequest + modifyMVar_ peers $ \pval -> case M.lookup paddr pval of + Just peer | Just pid <- peerIdentity peer -> + runExceptT (acceptChannelRequest sidentity pid request) >>= \case + Left errs -> do mapM_ putStrLn ("Invalid channel request" : errs) + return pval + Right (acc, channel) -> do + putStrLn $ "Got channel: " ++ show (storedRef channel) + let peer' = peer { peerChannels = fromStored channel : peerChannels peer } + writeChan chanPeer peer' + void $ sendTo sock (BL.toStrict $ BL.concat + [ serializeObject $ transportToObject $ TrChannelAccept (storedRef acc) + , lazyLoadBytes $ storedRef acc + , lazyLoadBytes $ storedRef $ signedData $ fromStored acc + , lazyLoadBytes $ storedRef $ caKey $ fromStored $ signedData $ fromStored acc + , BL.concat $ map (lazyLoadBytes . storedRef) $ signedSignature $ fromStored acc + ]) paddr + return $ M.insert paddr peer' pval + + _ -> do putStrLn $ "Invalid channel request - no peer identity" + return pval + else putStrLn $ "Mismatched content" + + packet _ paddr (TrChannelAccept _) [] = do + putStrLn $ "Got channel accept: from " ++ show paddr ++ " without content" + + packet _ paddr (TrChannelAccept ref) (obj:objs) = do + putStrLn $ "Got channel accept: from " ++ show paddr + print (obj:objs) + ref' <- store (storedStorage sidentity) obj + if ref == ref' + then do forM_ objs $ store $ storedStorage sidentity + let accepted = wrappedLoad ref :: Stored ChannelAccept + modifyMVar_ peers $ \pval -> case M.lookup paddr pval of + Just peer | Just pid <- peerIdentity peer -> + runExceptT (acceptedChannel sidentity pid accepted) >>= \case + Left errs -> do mapM_ putStrLn ("Invalid channel accept" : errs) + return pval + Right channel -> do + putStrLn $ "Got channel: " ++ show (storedRef channel) + let peer' = peer { peerChannels = fromStored channel : peerChannels peer } + writeChan chanPeer peer' + return $ M.insert paddr peer' pval + _ -> do putStrLn $ "Invalid channel accept - no peer identity" + return pval + + else putStrLn $ "Mismatched content" + void $ forkIO $ withSocketsDo $ do let hints = defaultHints { addrFlags = [AI_PASSIVE] , addrSocketType = Datagram } addr:_ <- getAddrInfo (Just hints) Nothing (Just discoveryPort) - bracket (open addr) close (loop chan) - return chan - where - open addr = do - sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) - setSocketOption sock ReuseAddr 1 - setSocketOption sock Broadcast 1 - setCloseOnExecIfNeeded =<< fdSocket sock - bind sock (addrAddress addr) - return sock - - loop chan sock = do - baddr:_ <- getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just bhost) (Just discoveryPort) - void $ sendTo sock (BL.toStrict $ serializeObject $ transportToObject $ AnnouncePacket $ storedRef sidentity) (addrAddress baddr) - forever $ do - (msg, peer) <- recvFrom sock 4096 - let packet' = packet chan sock peer - case runExcept $ deserializeObjects (storedStorage sidentity) $ BL.fromStrict msg of - Left err -> putStrLn $ show peer ++ ": " ++ err - Right (obj:objs) | Just tpack <- transportFromObject obj -> packet' tpack objs - _ -> putStrLn $ show peer ++ ": invalid transport packet" - - packet _ sock peer (AnnouncePacket ref) _ = do - putStrLn $ "Got announce: " ++ show ref ++ " from " ++ show peer - when (ref /= storedRef sidentity) $ void $ sendTo sock (BL.toStrict $ BL.concat - [ serializeObject $ transportToObject $ IdentityRequest ref (storedRef sidentity) - , BL.concat $ map (lazyLoadBytes . storedRef) $ collectStoredObjects $ wrappedLoad $ storedRef sidentity - ]) peer - - packet _ _ peer (IdentityRequest ref from) [] = do - putStrLn $ "Got identity request: for " ++ show ref ++ " by " ++ show from ++ " from " ++ show peer ++ " without content" - - packet chan sock peer (IdentityRequest ref from) (obj:objs) = do - putStrLn $ "Got identity request: for " ++ show ref ++ " by " ++ show from ++ " from " ++ show peer - print (obj:objs) - from' <- store (storedStorage sidentity) obj - if from == from' - then do forM_ objs $ store $ storedStorage sidentity - writeChan chan $ Peer (wrappedLoad from) (DatagramAddress peer) - void $ sendTo sock (BL.toStrict $ BL.concat - [ serializeObject $ transportToObject $ IdentityResponse (storedRef sidentity) - , BL.concat $ map (lazyLoadBytes . storedRef) $ collectStoredObjects $ wrappedLoad $ storedRef sidentity - ]) peer - else putStrLn $ "Mismatched content" - - packet _ _ peer (IdentityResponse ref) [] = do - putStrLn $ "Got identity response: by " ++ show ref ++ " from " ++ show peer ++ " without content" - - packet chan _ peer (IdentityResponse ref) (obj:objs) = do - putStrLn $ "Got identity response: by " ++ show ref ++ " from " ++ show peer - print (obj:objs) - ref' <- store (storedStorage sidentity) obj - if ref == ref' - then do forM_ objs $ store $ storedStorage sidentity - writeChan chan $ Peer (wrappedLoad ref) (DatagramAddress peer) - else putStrLn $ "Mismatched content" + bracket (open addr) close loop + + return chanPeer diff --git a/src/PubKey.hs b/src/PubKey.hs index 0022343..6dc8080 100644 --- a/src/PubKey.hs +++ b/src/PubKey.hs @@ -3,6 +3,9 @@ module PubKey ( KeyPair(generateKeys), loadKey, Signature(sigKey), Signed, signedData, signedSignature, sign, signAdd, + + PublicKexKey, SecretKexKey, + dhSecret, ) where import Control.Monad @@ -10,6 +13,7 @@ import Control.Monad.Except import Crypto.Error import qualified Crypto.PubKey.Ed25519 as ED +import qualified Crypto.PubKey.Curve25519 as CX import Data.ByteArray import Data.ByteString (ByteString) @@ -98,3 +102,35 @@ signAdd (SecretKey secret spublic) (Signed val sigs) = do sig = ED.sign secret public $ storedRef val ssig <- wrappedStore (storedStorage val) $ Signature spublic sig return $ Signed val (ssig : sigs) + + +data PublicKexKey = PublicKexKey CX.PublicKey + deriving (Show) + +data SecretKexKey = SecretKexKey CX.SecretKey (Stored PublicKexKey) + +instance KeyPair SecretKexKey PublicKexKey where + keyGetPublic (SecretKexKey _ pub) = pub + keyGetData (SecretKexKey sec _) = convert sec + keyFromData kdata spub = SecretKexKey <$> maybeCryptoError (CX.secretKey kdata) <*> pure spub + generateKeys st = do + secret <- CX.generateSecretKey + public <- wrappedStore st $ PublicKexKey $ CX.toPublic secret + let pair = SecretKexKey secret public + storeKey pair + return (pair, public) + +instance Storable PublicKexKey where + store' (PublicKexKey pk) = storeRec $ do + storeText "type" $ T.pack "x25519" + storeBinary "pubkey" pk + + load' = loadRec $ do + ktype <- loadText "type" + guard $ ktype == "x25519" + maybe (throwError "public key decoding failed") (return . PublicKexKey) . + maybeCryptoError . (CX.publicKey :: ScrubbedBytes -> CryptoFailable CX.PublicKey) =<< + loadBinary "pubkey" + +dhSecret :: SecretKexKey -> PublicKexKey -> ScrubbedBytes +dhSecret (SecretKexKey secret _) (PublicKexKey public) = convert $ CX.dh public secret |