From ab105cb6047dcf21c712437c6e65e63e2f07cdf0 Mon Sep 17 00:00:00 2001
From: fr33domlover <fr33domlover@riseup.net>
Date: Sun, 25 Sep 2022 12:29:53 +0000
Subject: [PATCH] Crypto: PersistField instance for ActorKey, preparing to
 support per-actor keys

Like the KeyFile instance, it stores just the secret key, in a plain
ByteString, and generates the public key from it when decoding from the DB
---
 src/Vervis/ActorKey.hs | 29 +++++++++++++++++++++++++++--
 1 file changed, 27 insertions(+), 2 deletions(-)

diff --git a/src/Vervis/ActorKey.hs b/src/Vervis/ActorKey.hs
index e375744..cc0b05d 100644
--- a/src/Vervis/ActorKey.hs
+++ b/src/Vervis/ActorKey.hs
@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -23,21 +23,27 @@ module Vervis.ActorKey
     )
 where
 
+import Control.Exception.Base
 import Control.Concurrent (threadDelay)
 import Control.Concurrent.STM (TVar, modifyTVar')
 import Control.Monad (forever)
 import Control.Monad.STM (atomically)
-import Crypto.Error (throwCryptoErrorIO)
+import Crypto.Error
 import Crypto.PubKey.Ed25519 hiding (Signature)
+import Data.Bifunctor
 import Data.ByteArray (convert)
 import Data.ByteString (ByteString)
+import Data.Text (Text)
 import Data.Time.Interval (TimeInterval, microseconds)
 import Data.PEM
 import Data.X509
+import Database.Persist
+import Database.Persist.Sql
 import Network.HTTP.Signature (Signature (..))
 import System.Directory (doesFileExist)
 
 import qualified Data.ByteString as B (writeFile, readFile)
+import qualified Data.Text as T
 
 import Crypto.PublicVerifKey
 import Data.KeyFile
@@ -69,6 +75,25 @@ instance KeyFile ActorKey where
             }
     renderKey = convert . actorKeySecret
 
+actorKeySecretBin :: ActorKey -> ByteString
+actorKeySecretBin = convert . actorKeySecret
+
+instance PersistField ActorKey where
+    toPersistValue = toPersistValue . actorKeySecretBin
+    fromPersistValue v = do
+        b <- fromPersistValue v :: Either Text ByteString
+        secret <- bimap showError id $ eitherCryptoError $ secretKey b
+        return ActorKey
+            { actorKeySecret = secret
+            , actorKeyPublic = toPublic secret
+            }
+        where
+        showError e =
+            "Parsing ActorKey from DB failed: " <> T.pack (displayException e)
+
+instance PersistFieldSql ActorKey where
+    sqlType = sqlType . fmap actorKeySecretBin
+
 {-
 -- | Ed25519 public key for signature verification. We receive these public
 -- keys from other servers and we use them to verify HTTP request signatures.