HTTP Signature verification: RSA-SHA256 and PEM/ASN1 support

Before, things worked like this:

* Only signatures of Ed25519 keys could be verified
* Key encoding placed the plain binary Ed25519 key in the PEM, instead of the
  key's ASN1 encoding

With this patch it now works like this:

* Ed25519 signatures are supported as before
* RSA keys are now supported too, assuming RSA-SHA256 signatures
* Both Ed25519 and RSA keys are encoded and decoded using actual PEM with ASN1

config/models

@@ -43,7 +43,7 @@ VerifKey
     ident    LocalURI
     instance InstanceId
     expires  UTCTime Maybe
-    public   PublicKey
+    public   PublicVerifKey
     sharer   RemoteSharerId Maybe
 
     UniqueVerifKey instance ident

src/Crypto/PubKey/Encoding.hs

@@ -0,0 +1,79 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Crypto.PubKey.Encoding
+    ( -- * Plain binary ASN1 encoding
+      --
+      -- These functions decode and encode a key using binary BER/DER ASN1
+      -- encoding. Use them if you need a way to serialize keys and don't care
+      -- about the format or the fact it's binary and not textual.
+      decodePubKeyASN1
+    , encodePubKeyASN1
+
+      -- * Textual PEM encoding
+      --
+      -- PEM is essentially a Base64 textual representation of ASN1 encoding.
+      -- It's a common standard format. Use these functions if you need to
+      -- serialize keys and you prefer a textual format or need
+      -- interoperability with cryptography related tools that expect PEM
+      -- files.
+    , decodePubKeyPEM
+    , encodePubKeyPEM
+    )
+where
+
+import Prelude
+
+import Control.Exception
+import Control.Monad
+import Data.ASN1.BinaryEncoding
+import Data.ASN1.Encoding
+import Data.ASN1.Types
+import Data.Bifunctor
+import Data.ByteString (ByteString)
+import Data.List
+import Data.Text (Text)
+import Data.PEM
+import Data.Text.Encoding
+import Data.X509
+
+decodePubKeyASN1 :: ByteString -> Either String PubKey
+decodePubKeyASN1 b = do
+    asn1s <- first displayException $ decodeASN1' BER b
+    (pkey, rest) <- fromASN1 asn1s
+    unless (null rest) $ Left "Remaining ASN1 stream isn't empty"
+    Right pkey
+
+encodePubKeyASN1 :: PubKey -> ByteString
+encodePubKeyASN1 pkey = encodeASN1' DER $ toASN1 pkey []
+
+decodePubKeyPEM :: Text -> Either String PubKey
+decodePubKeyPEM t = do
+    pems <- pemParseBS $ encodeUtf8 t
+    pem <-
+        case pems of
+            []  -> Left "Empty PEM"
+            [x] -> Right x
+            _   -> Left "Multiple PEM sections"
+    let name = pemName pem
+    unless
+        ("PUBLIC KEY" `isSuffixOf` name && not ("PRIVATE" `isInfixOf` name)) $
+            Left "PEM name suggests it isn't a public key"
+    unless (null $ pemHeader pem) $ Left "PEM headers found"
+    decodePubKeyASN1 $ pemContent pem
+
+encodePubKeyPEM :: PubKey -> Text
+encodePubKeyPEM =
+    decodeUtf8 . pemWriteBS . PEM "PUBLIC KEY" [] . encodePubKeyASN1

src/Crypto/PublicVerifKey.hs

@@ -0,0 +1,82 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Crypto.PublicVerifKey
+    ( PublicVerifKey (..)
+    , fromEd25519
+    , decodePublicVerifKeyASN1
+    , encodePublicVerifKeyASN1
+    , decodePublicVerifKeyPEM
+    , encodePublicVerifKeyPEM
+    , verifySignature
+    )
+where
+
+import Prelude
+
+import Control.Exception
+import Control.Monad
+import Crypto.Error
+import Crypto.Hash.Algorithms
+import Data.ByteString (ByteString)
+import Data.Text (Text)
+import Data.X509
+
+import qualified Crypto.PubKey.Ed25519 as E
+import qualified Crypto.PubKey.RSA as R
+import qualified Crypto.PubKey.RSA.PKCS15 as R
+
+import Crypto.PubKey.Encoding
+
+data PublicVerifKey
+    = PublicVerifKeyEd25519 E.PublicKey
+    | PublicVerifKeyRSA R.PublicKey
+
+fromEd25519 :: E.PublicKey -> PublicVerifKey
+fromEd25519 = PublicVerifKeyEd25519
+
+fromPubKey :: PubKey -> Either String PublicVerifKey
+fromPubKey (PubKeyRSA k)         = Right $ PublicVerifKeyRSA k
+fromPubKey (PubKeyEd25519 k)     = Right $ PublicVerifKeyEd25519 k
+fromPubKey (PubKeyUnknown oid _) = Left $ "Unrecognized key type " ++ show oid
+fromPubKey pkey                  =
+    Left $ "Unsupported key type " ++ takeWhile (/= ' ') (take 12 $ show pkey)
+
+toPubKey :: PublicVerifKey -> PubKey
+toPubKey (PublicVerifKeyEd25519 k) = PubKeyEd25519 k
+toPubKey (PublicVerifKeyRSA k)     = PubKeyRSA k
+
+decodePublicVerifKeyASN1 :: ByteString -> Either String PublicVerifKey
+decodePublicVerifKeyASN1 = fromPubKey <=< decodePubKeyASN1
+
+encodePublicVerifKeyASN1 :: PublicVerifKey -> ByteString
+encodePublicVerifKeyASN1 = encodePubKeyASN1 . toPubKey
+
+decodePublicVerifKeyPEM :: Text -> Either String PublicVerifKey
+decodePublicVerifKeyPEM = fromPubKey <=< decodePubKeyPEM
+
+encodePublicVerifKeyPEM :: PublicVerifKey -> Text
+encodePublicVerifKeyPEM = encodePubKeyPEM . toPubKey
+
+verifySignature
+    :: PublicVerifKey -> ByteString -> ByteString -> Either String Bool
+verifySignature (PublicVerifKeyEd25519 pk) msg sig = do
+    sig' <-
+        case E.signature sig of
+            CryptoFailed e -> Left $ displayException e
+            CryptoPassed s -> Right s
+    Right $ E.verify pk msg sig'
+verifySignature (PublicVerifKeyRSA pk) msg sig =
+    Right $ R.verify (Just SHA256) pk msg sig

src/Database/Persist/Class/Local.hs

@@ -20,32 +20,21 @@ where
 
 import Prelude
 
-import Control.Exception (displayException)
+import Control.Monad
-import Control.Monad ((<=<))
+import Data.Bifunctor
-import Crypto.Error (CryptoFailable, eitherCryptoError)
-import Crypto.PubKey.Ed25519 (PublicKey, publicKey)
-import Data.Bifunctor (first)
-import Data.ByteArray (convert)
-import Data.ByteString (ByteString)
 import Data.CaseInsensitive (CI)
 import Database.Persist.Class
-import Network.URI (URI, uriScheme, parseURI)
 
 import qualified Data.CaseInsensitive as CI
-import qualified Data.Text as T (pack)
+import qualified Data.Text as T
+
+import Crypto.PublicVerifKey
 
 instance (PersistField s, CI.FoldCase s) => PersistField (CI s) where
     toPersistValue = toPersistValue . CI.original
     fromPersistValue = fmap CI.mk . fromPersistValue
 
-instance PersistField PublicKey where
+instance PersistField PublicVerifKey where
-    toPersistValue = toPersistValue . convert'
+    toPersistValue = toPersistValue . encodePublicVerifKeyASN1
-        where
+    fromPersistValue =
-        convert' :: PublicKey -> ByteString
+        first T.pack . decodePublicVerifKeyASN1 <=< fromPersistValue
-        convert' = convert
-    fromPersistValue = toKey <=< fromPersistValue
-        where
-        publicKey' :: ByteString -> CryptoFailable PublicKey
-        publicKey' = publicKey
-        toKey =
-            first (T.pack . displayException) . eitherCryptoError . publicKey'

src/Database/Persist/Sql/Local.hs

@@ -20,21 +20,16 @@ where
 
 import Prelude
 
-import Crypto.PubKey.Ed25519 (PublicKey)
-import Data.ByteArray (convert)
-import Data.ByteString (ByteString)
 import Data.CaseInsensitive (CI)
 import Database.Persist.Sql
 
 import qualified Data.CaseInsensitive as CI
 
+import Crypto.PublicVerifKey
 import Database.Persist.Class.Local ()
 
 instance (PersistFieldSql s, CI.FoldCase s) => PersistFieldSql (CI s) where
     sqlType = sqlType . fmap CI.original
 
-instance PersistFieldSql PublicKey where
+instance PersistFieldSql PublicVerifKey where
-    sqlType = sqlType . fmap convert'
+    sqlType = sqlType . fmap encodePublicVerifKeyASN1
-        where
-        convert' :: PublicKey -> ByteString
-        convert' = convert

src/Vervis/ActorKey.hs

@@ -35,11 +35,13 @@ import Data.ByteArray (convert)
 import Data.ByteString (ByteString)
 import Data.Time.Interval (TimeInterval, microseconds)
 import Data.PEM
+import Data.X509
 import Network.HTTP.Signature (Signature (..))
 import System.Directory (doesFileExist)
 
 import qualified Data.ByteString as B (writeFile, readFile)
 
+import Crypto.PublicVerifKey
 import Data.KeyFile
 
 -- | Ed25519 signing key, we generate it on the server and use for signing. We
@@ -172,14 +174,8 @@ actorKeyRotator interval keys =
                 error $
                     "actorKeyRotator: interval out of range: " ++ show micros
 
--- | The public key in PEM format, can be directly placed in responses.
+actorKeyPublicBin :: ActorKey -> PublicVerifKey
---
+actorKeyPublicBin = fromEd25519 . actorKeyPublic
--- Well, right now it's actually just the public key in binary form, because
--- the type of publicKeyPem is PEM, so, I need to figure out etc. to see if
--- there's a nice way to reuse the PEM that is worth it. Even if not, that's
--- probably okay because the PEM rendering is hopefully trivial.
-actorKeyPublicBin :: ActorKey -> ByteString
-actorKeyPublicBin = convert . actorKeyPublic
 
 actorKeySign :: ActorKey -> ByteString -> Signature
 actorKeySign (ActorKey sec pub) = Signature . convert . sign sec pub

src/Vervis/Foundation.hs

@@ -63,6 +63,7 @@ import Yesod.Mail.Send
 
 import qualified Network.HTTP.Signature as S (Algorithm (..))
 
+import Crypto.PublicVerifKey
 import Network.FedURI
 import Web.ActivityAccess
 import Web.ActivityPub hiding (PublicKey)
@@ -604,12 +605,9 @@ instance YesodHttpSig App where
         where
         toSeconds :: TimeInterval -> Second
         toSeconds = toTimeUnit
-    httpVerifySig (Verification malgo (KeyId keyid) input (Signature sig)) = fmap HttpSigVerResult $ runExceptT $ do
+    httpVerifySig (Verification malgo (KeyId keyid) input (Signature signature)) = fmap HttpSigVerResult $ runExceptT $ do
-        verifySigAlgo malgo
         (host, luKey) <- f2l <$> parseKeyId keyid
-        signature <- parseSig sig
         mluActorHeader <- getActorHeader host
-        let sigAlgo = isJust malgo
         manager <- getsYesod appHttpManager
         (inboxOrVkid, vkd) <- do
             ments <- lift $ runDB $ do
@@ -647,16 +645,17 @@ instance YesodHttpSig App where
                             , vkdShared    = s
                             }
                         )
-                Nothing -> fetched2vkd luKey <$> fetchUnknownKey manager sigAlgo host mluActorHeader luKey
+                Nothing -> fetched2vkd luKey <$> fetchUnknownKey manager malgo host mluActorHeader luKey
-        let verify' k = verify k input signature
+        let verify k = ExceptT . pure $ verifySignature k input signature
-            errSig1 = throwE "Fetched fresh key; Ed25519 sig verification says not valid"
+            errSig1 = throwE "Fetched fresh key; Crypto sig verification says not valid"
-            errSig2 = throwE "Used key from DB; Ed25519 sig verification says not valid; fetched fresh key; still not valid"
+            errSig2 = throwE "Used key from DB; Crypto sig verification says not valid; fetched fresh key; still not valid"
             errTime = throwE "Key expired"
         now <- liftIO getCurrentTime
         let stillValid Nothing        = True
             stillValid (Just expires) = expires > now
 
-        if verify' (vkdKey vkd) && stillValid (vkdExpires vkd)
+        valid1 <- verify $ vkdKey vkd
+        if valid1 && stillValid (vkdExpires vkd)
             then case inboxOrVkid of
                 Left uinb -> ExceptT $ withHostLock host $ runDB $ runExceptT $ addVerifKey host uinb vkd
                 Right _ids -> return ()
@@ -670,12 +669,13 @@ instance YesodHttpSig App where
                         listed = withHostLock' host $ keyListedByActorShared iid vkid host luKey ua
                     (newKey, newExp) <-
                         if vkdShared vkd
-                            then fetchKnownSharedKey manager listed sigAlgo host ua luKey
+                            then fetchKnownSharedKey manager listed malgo host ua luKey
-                            else fetchKnownPersonalKey manager sigAlgo host ua luKey
+                            else fetchKnownPersonalKey manager malgo host ua luKey
                     if stillValid newExp
                         then return ()
                         else errTime
-                    if verify' newKey
+                    valid2 <- verify newKey
+                    if valid2
                         then lift $ runDB $ updateVerifKey vkid vkd
                                 { vkdKey     = newKey
                                 , vkdExpires = newExp
@@ -684,18 +684,10 @@ instance YesodHttpSig App where
 
         return $ l2f host $ vkdActorId vkd
         where
-        verifySigAlgo = traverse_ $ \ algo ->
-            case algo of
-                S.AlgorithmEd25519 -> return ()
-                S.AlgorithmOther _ -> throwE "Unsupported algo in Sig header"
         parseKeyId k =
             case parseFedURI =<< (first displayException . decodeUtf8') k of
                 Left e -> throwE $ "keyId in Sig header isn't a valid FedURI: " ++ e
                 Right u -> return u
-        parseSig b =
-            case signature b of
-                CryptoPassed s -> return s
-                CryptoFailed e -> throwE "Parsing Ed25519 signature failed"
         getActorHeader host = do
             bs <- lookupHeaders hActivityPubActor
             case bs of

src/Vervis/Handler/Inbox.hs

@@ -288,11 +288,11 @@ getActorKey choose route = do
     let (host, id_) = f2l $ route2uri route
     selectRep $
         provideAP $ Doc host PublicKey
-            { publicKeyId      = id_
+            { publicKeyId       = id_
-            , publicKeyExpires = Nothing
+            , publicKeyExpires  = Nothing
-            , publicKeyOwner   = OwnerInstance
+            , publicKeyOwner    = OwnerInstance
-            , publicKeyPem     = PEM "PUBLIC KEY" [] actorKey
+            , publicKeyMaterial = actorKey
-            , publicKeyAlgo    = Just AlgorithmEd25519
+            --, publicKeyAlgo    = Just AlgorithmEd25519
             }
 
 getActorKey1R :: Handler TypedContent

src/Vervis/Migration.hs

@@ -189,6 +189,10 @@ changes =
     , removeEntity "RepoRole"
       -- 41
     , addEntities model_2019_02_03_verifkey
+      -- 42
+    , unchecked $ lift $ do
+        deleteWhere ([] :: [Filter (VerifKeySharedUsage2019Generic SqlBackend)])
+        deleteWhere ([] :: [Filter (VerifKey2019Generic SqlBackend)])
     ]
 
 migrateDB :: MonadIO m => ReaderT SqlBackend m (Either Text (Int, Int))

src/Vervis/Migration/Model.hs

@@ -21,6 +21,8 @@ module Vervis.Migration.Model
     , Workflow2016
     , model_2016_09_01_rest
     , model_2019_02_03_verifkey
+    , VerifKey2019Generic (..)
+    , VerifKeySharedUsage2019Generic (..)
     )
 where
 
@@ -61,3 +63,6 @@ makeEntitiesMigration "2018"
 
 model_2019_02_03_verifkey :: [Entity SqlBackend]
 model_2019_02_03_verifkey = $(schema "2019_02_03_verifkey")
+
+makeEntitiesMigration "2019"
+    $(modelFile "migrations/2019_02_03_verifkey.model")

src/Vervis/Model.hs

@@ -20,12 +20,12 @@ module Vervis.Model where
 import ClassyPrelude.Conduit
 import Yesod hiding (Header, parseTime)
 
-import Crypto.PubKey.Ed25519 (PublicKey)
 import Database.Persist.Quasi
 import Database.Persist.Sql (fromSqlKey)
 import Text.Email.Validate (EmailAddress)
 import Yesod.Auth.Account (PersistUserCredentials (..))
 
+import Crypto.PublicVerifKey
 import Database.Persist.EmailAddress
 import Database.Persist.Graph.Class
 import Network.FedURI (FedURI, LocalURI)

src/Vervis/RemoteActorStore.hs

@@ -46,9 +46,9 @@ import UnliftIO.MVar (withMVar)
 import Yesod.Core
 import Yesod.Persist.Core
 
-import qualified Crypto.PubKey.Ed25519 as E
 import qualified Data.HashMap.Strict as M
 
+import Crypto.PublicVerifKey
 import Database.Persist.Local
 import Network.FedURI
 import Web.ActivityPub
@@ -357,7 +357,7 @@ keyListedByActorShared iid vkid host luKey luActor = do
 
 data VerifKeyDetail = VerifKeyDetail
     { vkdKeyId     :: LocalURI
-    , vkdKey       :: E.PublicKey
+    , vkdKey       :: PublicVerifKey
     , vkdExpires   :: Maybe UTCTime
     , vkdActorId   :: LocalURI
     , vkdShared    :: Bool

src/Web/ActivityPub.hs

@@ -27,7 +27,7 @@ module Web.ActivityPub
       -- ActivityPub actor document including a public key, with a 'FromJSON'
       -- instance for fetching and a 'ToJSON' instance for publishing.
     , ActorType (..)
-    , Algorithm (..)
+    --, Algorithm (..)
     , Owner (..)
     , PublicKey (..)
     , Actor (..)
@@ -61,7 +61,6 @@ import Control.Monad (when, unless, (<=<), join)
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Except
 import Control.Monad.Trans.Writer (Writer)
-import Crypto.Error (CryptoFailable (..))
 import Data.Aeson
 import Data.Aeson.Encoding (pair)
 import Data.Aeson.Types (Parser, typeMismatch, listEncoding)
@@ -79,18 +78,19 @@ import Data.Time.Clock (UTCTime)
 import Network.HTTP.Client hiding (Proxy, proxy)
 import Network.HTTP.Client.Conduit.ActivityPub (httpAPEither)
 import Network.HTTP.Client.Signature (signRequest)
-import Network.HTTP.Signature (KeyId, Signature, HttpSigGenError)
 import Network.HTTP.Simple (JSONException)
 import Network.HTTP.Types.Header (HeaderName, hContentType)
 import Network.URI
 import Yesod.Core.Content (ContentType)
 import Yesod.Core.Handler (ProvidedRep, provideRepType)
 
-import qualified Crypto.PubKey.Ed25519 as E (PublicKey, publicKey)
+import qualified Data.ByteString.Char8 as BC
 import qualified Data.HashMap.Strict as M (lookup)
 import qualified Data.Text as T (pack, unpack)
 import qualified Data.Vector as V (fromList, toList)
+import qualified Network.HTTP.Signature as S
 
+import Crypto.PublicVerifKey
 import Network.FedURI
 
 import Data.Aeson.Local
@@ -163,20 +163,23 @@ instance ToJSON ActorType where
             ActorTypePerson  -> "Person"
             ActorTypeOther t -> t
 
-data Algorithm = AlgorithmEd25519 | AlgorithmOther Text
+{-
+data Algorithm = AlgorithmEd25519 | AlgorithmRsaSha256 | AlgorithmOther Text
 
 instance FromJSON Algorithm where
-    parseJSON = withText "Algorithm" $ \ t ->
+    parseJSON = withText "Algorithm" $ \ t -> pure
-        pure $ if t == frg <> "ed25519"
+        | t == frg <> "ed25519"    = AlgorithmEd25519
-            then AlgorithmEd25519
+        | t == frg <> "rsa-sha256" = AlgorithmRsaSha256
-            else AlgorithmOther t
+        | otherwise                = AlgorithmOther t
 
 instance ToJSON Algorithm where
     toJSON = error "toJSON Algorithm"
     toEncoding algo =
         toEncoding $ case algo of
-            AlgorithmEd25519 -> frg <> "ed25519"
+            AlgorithmEd25519   -> frg <> "ed25519"
-            AlgorithmOther t -> t
+            AlgorithmRsaSha256 -> frg <> "rsa-sha256"
+            AlgorithmOther t   -> t
+-}
 
 data Owner = OwnerInstance | OwnerActor LocalURI
 
@@ -185,11 +188,11 @@ ownerShared OwnerInstance  = True
 ownerShared (OwnerActor _) = False
 
 data PublicKey = PublicKey
-    { publicKeyId      :: LocalURI
+    { publicKeyId       :: LocalURI
-    , publicKeyExpires :: Maybe UTCTime
+    , publicKeyExpires  :: Maybe UTCTime
-    , publicKeyOwner   :: Owner
+    , publicKeyOwner    :: Owner
-    , publicKeyPem     :: PEM
+    , publicKeyMaterial :: PublicVerifKey
-    , publicKeyAlgo    :: Maybe Algorithm
+    --, publicKeyAlgo     :: Maybe Algorithm
     }
 
 instance ActivityPub PublicKey where
@@ -205,8 +208,10 @@ instance ActivityPub PublicKey where
             PublicKey id_
                 <$> o .:? "expires"
                 <*> (mkOwner shared =<< withHost host o "owner")
-                <*> (parsePEM =<< o .: "publicKeyPem")
+                <*> (either fail return . decodePublicVerifKeyPEM =<<
-                <*> o .:? (frg <> "algorithm")
+                        o .: "publicKeyPem"
+                    )
+                -- <*> o .:? (frg <> "algorithm")
         where
         withHost h o t = do
             (h', lu) <- f2l <$> o .: t
@@ -216,20 +221,12 @@ instance ActivityPub PublicKey where
         mkOwner True  (LocalURI "" "") = return OwnerInstance
         mkOwner True  _                = fail "Shared key but owner isn't instance URI"
         mkOwner False lu               = return $ OwnerActor lu
-        parsePEM t =
+    toSeries host (PublicKey id_ mexpires owner mat)
-            case pemParseBS $ encodeUtf8 t of
-                Left e   -> fail $ "PEM parsing failed: " ++ e
-                Right xs ->
-                    case xs of
-                        []  -> fail "Empty PEM"
-                        [x] -> pure x
-                        _   -> fail "Multiple PEM sections"
-    toSeries host (PublicKey id_ mexpires owner pem malgo)
         =  "@id"                .=  l2f host id_
         <> "expires"            .=? mexpires
         <> "owner"              .=  mkOwner host owner
-        <> "publicKeyPem"       .=  decodeUtf8 (pemWriteBS pem)
+        <> "publicKeyPem"       .=  encodePublicVerifKeyPEM mat
-        <> (frg <> "algorithm") .=? malgo
+        -- <> (frg <> "algorithm") .=? malgo
         <> (frg <> "isShared")  .=  ownerShared owner
         where
         mkOwner h OwnerInstance   = FedURI h "" ""
@@ -430,7 +427,7 @@ httpGetAP manager uri =
             _   -> Left $ APGetErrorContentType "Multiple Content-Type"
 
 data APPostError
-    = APPostErrorSig HttpSigGenError
+    = APPostErrorSig S.HttpSigGenError
     | APPostErrorHTTP HttpException
     deriving Show
 
@@ -449,7 +446,7 @@ httpPostAP
     => Manager
     -> FedURI
     -> NonEmpty HeaderName
-    -> (ByteString -> (KeyId, Signature))
+    -> (ByteString -> (S.KeyId, S.Signature))
     -> Text
     -> a
     -> m (Either APPostError (Response ()))
@@ -474,8 +471,8 @@ httpPostAP manager uri headers sign uActor value = liftIO $ do
 
 -- | Result of GETing the keyId URI and processing the JSON document.
 data Fetched = Fetched
-    { fetchedPublicKey  :: E.PublicKey
+    { fetchedPublicKey  :: PublicVerifKey
-      -- ^ The Ed25519 public key corresponding to the URI we requested.
+      -- ^ The Ed25519 or RSA public key corresponding to the URI we requested.
     , fetchedKeyExpires :: Maybe UTCTime
       -- ^ Optional expiration time declared for the key we received.
     , fetchedActorId    :: LocalURI
@@ -559,33 +556,38 @@ matchKeyObj luKey es =
             then Just pk
             else Nothing
 
-verifyAlgo sigAlgo Nothing =
+verifyAlgo :: Maybe S.Algorithm -> PublicVerifKey -> Either String ()
-    Left $
+verifyAlgo Nothing  _ = Right ()
-    if sigAlgo
+verifyAlgo (Just a) k =
-        then "Algo mismatch, Ed25519 in Sig but none in actor"
+    case a of
-        else "Algo not given in Sig nor actor"
+        S.AlgorithmEd25519 ->
-verifyAlgo sigAlgo (Just algo) =
+            case k of
-    case algo of
+                PublicVerifKeyEd25519 _ -> Right ()
-        AlgorithmEd25519 -> Right ()
+                PublicVerifKeyRSA _ ->
-        AlgorithmOther _ ->
+                    Left "Algo mismatch, algo is Ed25519 but actual key is RSA"
-            Left $
+        S.AlgorithmRsaSha256 ->
-            if sigAlgo
+            case k of
-                then "Algo mismatch, Ed25519 in Sig but unsupported algo in actor"
+                PublicVerifKeyEd25519 _ ->
-                else "No algo in Sig, unsupported algo in actor"
+                    Left
-
+                        "Algo mismatch, algo is RSA-SHA256 but actual key is \
-parseKey pem =
+                        \Ed25519"
-    case E.publicKey $ pemContent pem of
+                PublicVerifKeyRSA _ -> Right ()
-        CryptoPassed k -> Right k
+        S.AlgorithmOther b -> Left $ concat
-        CryptoFailed _ -> Left "Parsing Ed25519 public key failed"
+            [ "Unrecognized algo "
+            , BC.unpack b
+            , ", actual key is "
+            , case k of
+                PublicVerifKeyEd25519 _ -> "Ed25519"
+                PublicVerifKeyRSA     _ -> "RSA"
+            ]
 
 -- | Fetch a key we don't have cached locally.
 fetchUnknownKey
     :: MonadIO m
     => Manager
     -- ^ Manager for making HTTP requests
-    -> Bool
+    -> Maybe S.Algorithm
-    -- ^ Whether the Ed25519 algorithm is specified explicitly in the HTTP
+    -- ^ Signature algorithm possibly specified in the HTTP signature header
-    -- signature header
     -> Text
     -- ^ Instance host
     -> Maybe LocalURI
@@ -593,9 +595,9 @@ fetchUnknownKey
     -> LocalURI
     -- ^ Key URI provided in HTTP signature header
     -> ExceptT String m Fetched
-fetchUnknownKey manager sigAlgo host mluActor luKey = do
+fetchUnknownKey manager malgo host mluActor luKey = do
     obj <- fetchAPIDOrH manager publicKeyId host luKey
-    (pem, mkFetched, malgo) <-
+    fetched <-
         case obj of
             Left pkey -> do
                 (oi, luActor) <-
@@ -611,18 +613,13 @@ fetchUnknownKey manager sigAlgo host mluActor luKey = do
                                     else throwE "Key's owner doesn't match actor header"
                             return (False, owner)
                 inbox <- actorInbox <$> ExceptT (keyListedByActor manager host luKey luActor)
-                return
+                return Fetched
-                    ( publicKeyPem pkey
+                    { fetchedPublicKey  = publicKeyMaterial pkey
-                    , \ k ->
+                    , fetchedKeyExpires = publicKeyExpires pkey
-                        Fetched
+                    , fetchedActorId    = luActor
-                            { fetchedPublicKey  = k
+                    , fetchedActorInbox = inbox
-                            , fetchedKeyExpires = publicKeyExpires pkey
+                    , fetchedKeyShared  = oi
-                            , fetchedActorId    = luActor
+                    }
-                            , fetchedActorInbox = inbox
-                            , fetchedKeyShared  = oi
-                            }
-                    , publicKeyAlgo pkey
-                    )
             Right actor -> do
                 if actorId actor == luKey { luriFragment = "" }
                     then return ()
@@ -638,23 +635,17 @@ fetchUnknownKey manager sigAlgo host mluActor luKey = do
                         if owner == actorId actor
                             then return owner
                             else throwE "Actor's publicKey's owner doesn't match the actor's ID"
-                return
+                return Fetched
-                    ( publicKeyPem pk
+                    { fetchedPublicKey  = publicKeyMaterial pk
-                    , \ k ->
+                    , fetchedKeyExpires = publicKeyExpires pk
-                        Fetched
+                    , fetchedActorId    = owner
-                            { fetchedPublicKey  = k
+                    , fetchedActorInbox = actorInbox actor
-                            , fetchedKeyExpires = publicKeyExpires pk
+                    , fetchedKeyShared  = False
-                            , fetchedActorId    = owner
+                    }
-                            , fetchedActorInbox = actorInbox actor
+    ExceptT . pure $ verifyAlgo malgo $ fetchedPublicKey fetched
-                            , fetchedKeyShared  = False
+    return fetched
-                            }
-                    , publicKeyAlgo pk
-                    )
-    ExceptT . pure $ do
-        verifyAlgo sigAlgo malgo
-        mkFetched <$> parseKey pem
 
-keyDetail pk = (publicKeyPem pk, publicKeyExpires pk, publicKeyAlgo pk)
+keyDetail pk = (publicKeyMaterial pk, publicKeyExpires pk)
 
 -- | Fetch a personal key we already have cached locally, but we'd like to
 -- refresh the local copy by fetching the key again from the server.
@@ -662,19 +653,18 @@ fetchKnownPersonalKey
     :: MonadIO m
     => Manager
     -- ^ Manager for making HTTP requests
-    -> Bool
+    -> Maybe S.Algorithm
-    -- ^ Whether the Ed25519 algorithm is specified explicitly in the HTTP
+    -- ^ Signature algorithm possibly specified in the HTTP signature header
-    -- signature header
     -> Text
     -- ^ Instance host
     -> LocalURI
     -- ^ Key owner actor ID URI
     -> LocalURI
     -- ^ Key URI
-    -> ExceptT String m (E.PublicKey, Maybe UTCTime)
+    -> ExceptT String m (PublicVerifKey, Maybe UTCTime)
-fetchKnownPersonalKey manager sigAlgo host luOwner luKey = do
+fetchKnownPersonalKey manager malgo host luOwner luKey = do
     obj <- fetchAPIDOrH manager publicKeyId host luKey
-    (pem, mexpires, malgo) <-
+    (material, mexpires) <-
         case obj of
             Left pkey -> do
                 case publicKeyOwner pkey of
@@ -694,9 +684,8 @@ fetchKnownPersonalKey manager sigAlgo host luOwner luKey = do
                         when (owner /= luOwner) $
                             throwE "Actor's publicKey's owner doesn't match the actor's ID"
                 return $ keyDetail pk
-    ExceptT . pure $ do
+    ExceptT . pure $ verifyAlgo malgo material
-        verifyAlgo sigAlgo malgo
+    return (material, mexpires)
-        (, mexpires) <$> parseKey pem
 
 -- | Fetch a shared key we already have cached locally, but we'd like to
 -- refresh the local copy by fetching the key again from the server.
@@ -707,17 +696,16 @@ fetchKnownSharedKey
     -> ExceptT String m ()
     -- ^ Action which checks whether the actor from HTTP actor header lists the
     -- key, potentually updating our local cache if needed.
-    -> Bool
+    -> Maybe S.Algorithm
-    -- ^ Whether the Ed25519 algorithm is specified explicitly in the HTTP
+    -- ^ Signature algorithm possibly specified in the HTTP signature header
-    -- signature header
     -> Text
     -- ^ Instance host
     -> LocalURI
     -- ^ Actor ID from HTTP actor header
     -> LocalURI
     -- ^ Key URI
-    -> ExceptT String m (E.PublicKey, Maybe UTCTime)
+    -> ExceptT String m (PublicVerifKey, Maybe UTCTime)
-fetchKnownSharedKey manager listed sigAlgo host luActor luKey = do
+fetchKnownSharedKey manager listed malgo host luActor luKey = do
     obj <- fetchAPIDOrH manager publicKeyId host luKey
     pkey <-
         case obj :: Either PublicKey Actor of
@@ -727,7 +715,6 @@ fetchKnownSharedKey manager listed sigAlgo host luActor luKey = do
         OwnerInstance -> return ()
         OwnerActor _owner -> throwE "Shared key became personal"
     listed
-    let (pem, mexpires, malgo) = keyDetail pkey
+    let (material, mexpires) = keyDetail pkey
-    ExceptT . pure $ do
+    ExceptT . pure $ verifyAlgo malgo material
-        verifyAlgo sigAlgo malgo
+    return (material, mexpires)
-        (, mexpires) <$> parseKey pem

vervis.cabal

@@ -40,6 +40,8 @@ flag library-only
 library
   exposed-modules:     Control.Applicative.Local
                        Control.Concurrent.Local
+                       Crypto.PubKey.Encoding
+                       Crypto.PublicVerifKey
                        Darcs.Local.Repository
                        Data.Aeson.Encode.Pretty.ToEncoding
                        Data.Aeson.Local
@@ -208,6 +210,9 @@ library
   build-depends:       aeson
                        -- For activity JSOn display in /inbox test page
                      , aeson-pretty
+                       -- for encoding and decoding of crypto public keys
+                     , asn1-encoding
+                     , asn1-types
                        -- for parsing commands sent over SSH and Darcs patch
                        -- metadata
                      , attoparsec
@@ -336,6 +341,8 @@ library
                      , wai-extra
                      , wai-logger
                      , warp
+                       -- for encoding and decoding of crypto public keys
+                     , x509
                      , xss-sanitize
                      , yaml
                      , yesod