forge/Vervis
1
0
Fork 0
Code Pull requests Activity

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

Browse source 
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
This commit is contained in:
fr33domlover 2019-03-10 23:15:42 +00:00
parent ef57f29a54
commit 2a39378468
14 changed files with 303 additions and 167 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
config/models
View file

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

79
src/Crypto/PubKey/Encoding.hs Normal file
View file

@ -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

82
src/Crypto/PublicVerifKey.hs Normal file
View file

@ -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

29
src/Database/Persist/Class/Local.hs
View file

@ -20,32 +20,21 @@ where
import Prelude
import Control.Exception (displayException)
import Control.Monad ((<=<))
import Crypto.Error (CryptoFailable, eitherCryptoError)
import Crypto.PubKey.Ed25519 (PublicKey, publicKey)
import Data.Bifunctor (first)
import Data.ByteArray (convert)
import Data.ByteString (ByteString)
import Control.Monad
import Data.Bifunctor
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
toPersistValue = toPersistValue . convert'
where
convert' :: PublicKey -> ByteString
convert' = convert
fromPersistValue = toKey <=< fromPersistValue
where
publicKey' :: ByteString -> CryptoFailable PublicKey
publicKey' = publicKey
toKey =
first (T.pack . displayException) . eitherCryptoError . publicKey'
instance PersistField PublicVerifKey where
toPersistValue = toPersistValue . encodePublicVerifKeyASN1
fromPersistValue =
first T.pack . decodePublicVerifKeyASN1 <=< fromPersistValue

11
src/Database/Persist/Sql/Local.hs
View file

@ -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
sqlType = sqlType . fmap convert'
where
convert' :: PublicKey -> ByteString
convert' = convert
instance PersistFieldSql PublicVerifKey where
sqlType = sqlType . fmap encodePublicVerifKeyASN1

12
src/Vervis/ActorKey.hs
View file

@ -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.
--
-- 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
actorKeyPublicBin :: ActorKey -> PublicVerifKey
actorKeyPublicBin = fromEd25519 . actorKeyPublic
actorKeySign :: ActorKey -> ByteString -> Signature
actorKeySign (ActorKey sec pub) = Signature . convert . sign sec pub

32
src/Vervis/Foundation.hs
View file

@ -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
verifySigAlgo malgo
httpVerifySig (Verification malgo (KeyId keyid) input (Signature signature)) = fmap HttpSigVerResult $ runExceptT $ do
(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
let verify' k = verify k input signature
errSig1 = throwE "Fetched fresh key; Ed25519 sig verification says not valid"
errSig2 = throwE "Used key from DB; Ed25519 sig verification says not valid; fetched fresh key; still not valid"
Nothing -> fetched2vkd luKey <$> fetchUnknownKey manager malgo host mluActorHeader luKey
let verify k = ExceptT . pure $ verifySignature k input signature
errSig1 = throwE "Fetched fresh key; Crypto sig verification says 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
else fetchKnownPersonalKey manager sigAlgo host ua luKey
then fetchKnownSharedKey manager listed malgo 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

10
src/Vervis/Handler/Inbox.hs
View file

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

4
src/Vervis/Migration.hs
View file

@ -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))

5
src/Vervis/Migration/Model.hs
View file

@ -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")

2
src/Vervis/Model.hs
View file

@ -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)

4
src/Vervis/RemoteActorStore.hs
View file

@ -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

191
src/Web/ActivityPub.hs
View file

@ -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 ->
pure $ if t == frg <> "ed25519"
then AlgorithmEd25519
else AlgorithmOther t
parseJSON = withText "Algorithm" $ \ t -> pure
| t == frg <> "ed25519" = AlgorithmEd25519
| t == frg <> "rsa-sha256" = AlgorithmRsaSha256
| otherwise = AlgorithmOther t
instance ToJSON Algorithm where
toJSON = error "toJSON Algorithm"
toEncoding algo =
toEncoding $ case algo of
AlgorithmEd25519 -> frg <> "ed25519"
AlgorithmOther t -> t
AlgorithmEd25519 -> frg <> "ed25519"
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
, publicKeyExpires :: Maybe UTCTime
, publicKeyOwner :: Owner
, publicKeyPem :: PEM
, publicKeyAlgo :: Maybe Algorithm
{ publicKeyId :: LocalURI
, publicKeyExpires :: Maybe UTCTime
, publicKeyOwner :: Owner
, publicKeyMaterial :: PublicVerifKey
--, 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")
<*> o .:? (frg <> "algorithm")
<*> (either fail return . decodePublicVerifKeyPEM =<<
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 =
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)
toSeries host (PublicKey id_ mexpires owner mat)
= "@id" .= l2f host id_
<> "expires" .=? mexpires
<> "owner" .= mkOwner host owner
<> "publicKeyPem" .= decodeUtf8 (pemWriteBS pem)
<> (frg <> "algorithm") .=? malgo
<> "publicKeyPem" .= encodePublicVerifKeyPEM mat
-- <> (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
-- ^ The Ed25519 public key corresponding to the URI we requested.
{ fetchedPublicKey :: PublicVerifKey
-- ^ 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 =
Left $
if sigAlgo
then "Algo mismatch, Ed25519 in Sig but none in actor"
else "Algo not given in Sig nor actor"
verifyAlgo sigAlgo (Just algo) =
case algo of
AlgorithmEd25519 -> Right ()
AlgorithmOther _ ->
Left $
if sigAlgo
then "Algo mismatch, Ed25519 in Sig but unsupported algo in actor"
else "No algo in Sig, unsupported algo in actor"
parseKey pem =
case E.publicKey $ pemContent pem of
CryptoPassed k -> Right k
CryptoFailed _ -> Left "Parsing Ed25519 public key failed"
verifyAlgo :: Maybe S.Algorithm -> PublicVerifKey -> Either String ()
verifyAlgo Nothing _ = Right ()
verifyAlgo (Just a) k =
case a of
S.AlgorithmEd25519 ->
case k of
PublicVerifKeyEd25519 _ -> Right ()
PublicVerifKeyRSA _ ->
Left "Algo mismatch, algo is Ed25519 but actual key is RSA"
S.AlgorithmRsaSha256 ->
case k of
PublicVerifKeyEd25519 _ ->
Left
"Algo mismatch, algo is RSA-SHA256 but actual key is \
\Ed25519"
PublicVerifKeyRSA _ -> Right ()
S.AlgorithmOther b -> Left $ concat
[ "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
-- ^ Whether the Ed25519 algorithm is specified explicitly in the HTTP
-- signature header
-> Maybe S.Algorithm
-- ^ Signature algorithm possibly specified in the HTTP 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
( publicKeyPem pkey
, \ k ->
Fetched
{ fetchedPublicKey = k
, fetchedKeyExpires = publicKeyExpires pkey
, fetchedActorId = luActor
, fetchedActorInbox = inbox
, fetchedKeyShared = oi
}
, publicKeyAlgo pkey
)
return Fetched
{ fetchedPublicKey = publicKeyMaterial pkey
, fetchedKeyExpires = publicKeyExpires pkey
, fetchedActorId = luActor
, fetchedActorInbox = inbox
, fetchedKeyShared = oi
}
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
( publicKeyPem pk
, \ k ->
Fetched
{ fetchedPublicKey = k
, fetchedKeyExpires = publicKeyExpires pk
, fetchedActorId = owner
, fetchedActorInbox = actorInbox actor
, fetchedKeyShared = False
}
, publicKeyAlgo pk
)
ExceptT . pure $ do
verifyAlgo sigAlgo malgo
mkFetched <$> parseKey pem
return Fetched
{ fetchedPublicKey = publicKeyMaterial pk
, fetchedKeyExpires = publicKeyExpires pk
, fetchedActorId = owner
, fetchedActorInbox = actorInbox actor
, fetchedKeyShared = False
}
ExceptT . pure $ verifyAlgo malgo $ fetchedPublicKey fetched
return fetched
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
-- ^ Whether the Ed25519 algorithm is specified explicitly in the HTTP
-- signature header
-> Maybe S.Algorithm
-- ^ Signature algorithm possibly specified in the HTTP signature header
-> Text
-- ^ Instance host
-> LocalURI
-- ^ Key owner actor ID URI
-> LocalURI
-- ^ Key URI
-> ExceptT String m (E.PublicKey, Maybe UTCTime)
fetchKnownPersonalKey manager sigAlgo host luOwner luKey = do
-> ExceptT String m (PublicVerifKey, Maybe UTCTime)
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
verifyAlgo sigAlgo malgo
(, mexpires) <$> parseKey pem
ExceptT . pure $ verifyAlgo malgo material
return (material, mexpires)
-- | 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
-- ^ Whether the Ed25519 algorithm is specified explicitly in the HTTP
-- signature header
-> Maybe S.Algorithm
-- ^ Signature algorithm possibly specified in the HTTP signature header
-> Text
-- ^ Instance host
-> LocalURI
-- ^ Actor ID from HTTP actor header
-> LocalURI
-- ^ Key URI
-> ExceptT String m (E.PublicKey, Maybe UTCTime)
fetchKnownSharedKey manager listed sigAlgo host luActor luKey = do
-> ExceptT String m (PublicVerifKey, Maybe UTCTime)
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
ExceptT . pure $ do
verifyAlgo sigAlgo malgo
(, mexpires) <$> parseKey pem
let (material, mexpires) = keyDetail pkey
ExceptT . pure $ verifyAlgo malgo material
return (material, mexpires)

7
vervis.cabal
View file

@ -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