diff --git a/config/models b/config/models index e7699e0..56bbe15 100644 --- a/config/models +++ b/config/models @@ -43,7 +43,7 @@ VerifKey ident LocalURI instance InstanceId expires UTCTime Maybe - public PublicKey + public PublicVerifKey sharer RemoteSharerId Maybe UniqueVerifKey instance ident diff --git a/src/Crypto/PubKey/Encoding.hs b/src/Crypto/PubKey/Encoding.hs new file mode 100644 index 0000000..208ccb1 --- /dev/null +++ b/src/Crypto/PubKey/Encoding.hs @@ -0,0 +1,79 @@ +{- This file is part of Vervis. + - + - Written in 2019 by fr33domlover . + - + - ♡ 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 + - . + -} + +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 diff --git a/src/Crypto/PublicVerifKey.hs b/src/Crypto/PublicVerifKey.hs new file mode 100644 index 0000000..ad7720d --- /dev/null +++ b/src/Crypto/PublicVerifKey.hs @@ -0,0 +1,82 @@ +{- This file is part of Vervis. + - + - Written in 2019 by fr33domlover . + - + - ♡ 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 + - . + -} + +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 diff --git a/src/Database/Persist/Class/Local.hs b/src/Database/Persist/Class/Local.hs index 71b74f5..45dd0f1 100644 --- a/src/Database/Persist/Class/Local.hs +++ b/src/Database/Persist/Class/Local.hs @@ -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 diff --git a/src/Database/Persist/Sql/Local.hs b/src/Database/Persist/Sql/Local.hs index ea9582d..d495a6d 100644 --- a/src/Database/Persist/Sql/Local.hs +++ b/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 - sqlType = sqlType . fmap convert' - where - convert' :: PublicKey -> ByteString - convert' = convert +instance PersistFieldSql PublicVerifKey where + sqlType = sqlType . fmap encodePublicVerifKeyASN1 diff --git a/src/Vervis/ActorKey.hs b/src/Vervis/ActorKey.hs index e2bfacd..82bab7d 100644 --- a/src/Vervis/ActorKey.hs +++ b/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. --- --- 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 diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 6a4c757..662b41c 100644 --- a/src/Vervis/Foundation.hs +++ b/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 - 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 diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs index 0553215..5c76550 100644 --- a/src/Vervis/Handler/Inbox.hs +++ b/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_ - , 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 diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 6ac0730..dee555a 100644 --- a/src/Vervis/Migration.hs +++ b/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)) diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs index dd19ddf..451f0d9 100644 --- a/src/Vervis/Migration/Model.hs +++ b/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") diff --git a/src/Vervis/Model.hs b/src/Vervis/Model.hs index 6811496..8206df2 100644 --- a/src/Vervis/Model.hs +++ b/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) diff --git a/src/Vervis/RemoteActorStore.hs b/src/Vervis/RemoteActorStore.hs index 920168a..4b77930 100644 --- a/src/Vervis/RemoteActorStore.hs +++ b/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 diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 39ec6a4..320ae96 100644 --- a/src/Web/ActivityPub.hs +++ b/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 -> - 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) diff --git a/vervis.cabal b/vervis.cabal index f477e0d..deed69b 100644 --- a/vervis.cabal +++ b/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