Signed identities using ED25519

6 files changed, 113 insertions, 10 deletions

diff --git a/erebos.cabal b/erebos.cabal
index fad6b90..8d7e62f 100644
--- a/erebos.cabal
+++ b/erebos.cabal
@@ -20,6 +20,7 @@ executable erebos
   main-is:             Main.hs
   other-modules:       Identity,
                        Network,
+                       PubKey,
                        Storage
 
   default-extensions:  FlexibleContexts,
diff --git a/src/Identity.hs b/src/Identity.hs
index 76d0c97..65fec8a 100644
--- a/src/Identity.hs
+++ b/src/Identity.hs
@@ -1,22 +1,28 @@
 module Identity (
-    Identity(..),
+    Identity, IdentityData(..),
 ) where
 
 import Data.Text (Text)
 
+import PubKey
 import Storage
 
-data Identity = Identity
+type Identity = Signed IdentityData
+
+data IdentityData = Identity
     { idName :: Text
     , idPrev :: Maybe (Stored Identity)
+    , idKeyIdentity :: Stored PublicKey
     }
     deriving (Show)
 
-instance Storable Identity where
+instance Storable IdentityData where
     store' idt = storeRec $ do
         storeText "name" $ idName idt
         storeMbRef "prev" $ idPrev idt
+        storeRef "key-id" $ idKeyIdentity idt
 
     load' = loadRec $ Identity
         <$> loadText "name"
         <*> loadMbRef "prev"
+        <*> loadRef "key-id"
diff --git a/src/Main.hs b/src/Main.hs
index 017d70d..9f6cade 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -12,6 +12,7 @@ import System.IO.Error
 
 import Identity
 import Network
+import PubKey
 import Storage
 
 
@@ -23,7 +24,9 @@ main = do
         putStr "Name: "
         hFlush stdout
         name <- T.getLine
-        let base = Identity name Nothing
+        (secret, public) <- generateKeys st
+
+        base <- sign secret =<< wrappedStore st (Identity name Nothing public)
         Right h <- replaceHead base (Left (st, "identity"))
         return h
     let sidentity = wrappedLoad (headRef idhead) :: Stored Identity
diff --git a/src/Network.hs b/src/Network.hs
index 6609667..44f27e7 100644
--- a/src/Network.hs
+++ b/src/Network.hs
@@ -17,6 +17,7 @@ import Network.Socket
 import Network.Socket.ByteString (recvFrom, sendTo)
 
 import Identity
+import PubKey
 import Storage
 
 
@@ -108,30 +109,38 @@ peerDiscovery bhost sidentity = do
         void $ sendTo sock (BL.toStrict $ BL.concat
             [ serializeObject $ transportToObject $ IdentityRequest ref (storedRef sidentity)
             , lazyLoadBytes $ storedRef sidentity
+            , lazyLoadBytes $ storedRef $ signedData $ fromStored sidentity
+            , lazyLoadBytes $ storedRef $ idKeyIdentity $ fromStored $ signedData $ fromStored sidentity
+            , lazyLoadBytes $ storedRef $ signedSignature $ fromStored 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) objs@(obj:_) = do
+    packet chan sock peer (IdentityRequest ref from) (obj:objs) = do
         putStrLn $ "Got identity request: for " ++ show ref ++ " by " ++ show from ++ " from " ++ show peer
-        print objs
+        print (obj:objs)
         from' <- store (storedStorage sidentity) obj
         if from == from'
-           then do writeChan chan $ Peer (wrappedLoad from) (DatagramAddress peer)
+           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)
                        , lazyLoadBytes $ storedRef sidentity
+                       , lazyLoadBytes $ storedRef $ signedData $ fromStored sidentity
+                       , lazyLoadBytes $ storedRef $ idKeyIdentity $ fromStored $ signedData $ fromStored sidentity
+                       , lazyLoadBytes $ storedRef $ signedSignature $ fromStored 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) objs@(obj:_) = do
+    packet chan _ peer (IdentityResponse ref) (obj:objs) = do
         putStrLn $ "Got identity response: by " ++ show ref ++ " from " ++ show peer
-        print objs
+        print (obj:objs)
         ref' <- store (storedStorage sidentity) obj
         if ref == ref'
-           then writeChan chan $ Peer (wrappedLoad ref) (DatagramAddress peer)
+           then do forM_ objs $ store $ storedStorage sidentity
+                   writeChan chan $ Peer (wrappedLoad ref) (DatagramAddress peer)
            else putStrLn $ "Mismatched content"
diff --git a/src/PubKey.hs b/src/PubKey.hs
new file mode 100644
index 0000000..d89747a
--- /dev/null
+++ b/src/PubKey.hs
@@ -0,0 +1,80 @@
+module PubKey (
+    PublicKey, SecretKey,
+    Signature(sigKey), Signed(..),
+    generateKeys,
+    sign,
+) where
+
+import Control.Monad
+import Control.Monad.Except
+
+import Crypto.Error
+import qualified Crypto.PubKey.Ed25519 as ED
+
+import Data.ByteString (ByteString)
+import qualified Data.Text as T
+
+import Storage
+
+data PublicKey = PublicKey ED.PublicKey
+    deriving (Show)
+
+data SecretKey = SecretKey ED.SecretKey (Stored PublicKey)
+
+data Signature = Signature
+    { sigKey :: Stored PublicKey
+    , sigSignature :: ED.Signature
+    }
+    deriving (Show)
+
+data Signed a = Signed
+    { signedData :: Stored a
+    , signedSignature :: Stored Signature
+    }
+    deriving (Show)
+
+instance Storable PublicKey where
+    store' (PublicKey pk) = storeRec $ do
+        storeText "type" $ T.pack "ed25519"
+        storeBinary "pubkey" pk
+
+    load' = loadRec $ do
+        ktype <- loadText "type"
+        guard $ ktype == "ed25519"
+        maybe (throwError "Public key decoding failed") (return . PublicKey) .
+            maybeCryptoError . (ED.publicKey :: ByteString -> CryptoFailable ED.PublicKey) =<<
+                loadBinary "pubkey"
+
+instance Storable Signature where
+    store' sig = storeRec $ do
+        storeRef "key" $ sigKey sig
+        storeBinary "sig" $ sigSignature sig
+
+    load' = loadRec $ Signature
+        <$> loadRef "key"
+        <*> loadSignature "sig"
+        where loadSignature = maybe (throwError "Signature decoding failed") return .
+                  maybeCryptoError . (ED.signature :: ByteString -> CryptoFailable ED.Signature) <=< loadBinary
+
+instance Storable a => Storable (Signed a) where
+    store' sig = storeRec $ do
+        storeRef "data" $ signedData sig
+        storeRef "sig" $ signedSignature sig
+
+    load' = loadRec $ Signed
+        <$> loadRef "data"
+        <*> loadRef "sig"
+
+
+generateKeys :: Storage -> IO (SecretKey, Stored PublicKey)
+generateKeys st = do
+    secret <- ED.generateSecretKey
+    public <- wrappedStore st $ PublicKey $ ED.toPublic secret
+    return (SecretKey secret public, public)
+
+sign :: SecretKey -> Stored a -> IO (Signed a)
+sign (SecretKey secret spublic) val = do
+    let PublicKey public = fromStored spublic
+        sig = ED.sign secret public $ storedRef val
+    ssig <- wrappedStore (storedStorage val) $ Signature spublic sig
+    return $ Signed val ssig
diff --git a/src/Storage.hs b/src/Storage.hs
index f9d302e..c31230e 100644
--- a/src/Storage.hs
+++ b/src/Storage.hs
@@ -107,6 +107,10 @@ data Ref = Ref Storage (Digest Blake2b_256)
 instance Show Ref where
     show ref@(Ref (Storage path) _) = path ++ ":" ++ BC.unpack (showRef ref)
 
+instance BA.ByteArrayAccess Ref where
+    length (Ref _ dgst) = BA.length dgst
+    withByteArray (Ref _ dgst) = BA.withByteArray dgst
+
 zeroRef :: Storage -> Ref
 zeroRef s = Ref s h
     where h = case digestFromByteString $ B.replicate (BA.length h) 0 of