From a419db5b5bb26e36d2f803c95df024eca8bd2fc5 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Thu, 17 Oct 2019 08:37:48 +0000 Subject: [PATCH] Publish AS2 representation of SSH keys and list SSH keys in actor documents --- config/routes | 2 + src/Vervis/Foundation.hs | 1 + src/Vervis/Handler/Key.hs | 38 ++++++++++++++++-- src/Vervis/Handler/Person.hs | 10 ++++- src/Vervis/Handler/Project.hs | 1 + src/Vervis/Handler/Repo.hs | 1 + src/Vervis/Handler/Sharer.hs | 2 +- src/Web/ActivityPub.hs | 76 +++++++++++++++++++++++++++++++++-- 8 files changed, 122 insertions(+), 9 deletions(-) diff --git a/config/routes b/config/routes index 79a1dc4..89b69d2 100644 --- a/config/routes +++ b/config/routes @@ -66,6 +66,8 @@ /s/#ShrIdent/follow SharerFollowR POST /s/#ShrIdent/unfollow SharerUnfollowR POST +/s/#ShrIdent/k/#SshKeyKeyHashid SshKeyR GET + /p PeopleR GET /g GroupsR GET POST diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index dfa8c6a..dc81bd1 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -135,6 +135,7 @@ data App = App -- Aliases for the routes file, because it doesn't like spaces in path piece -- type names. type OutboxItemKeyHashid = KeyHashid OutboxItem +type SshKeyKeyHashid = KeyHashid SshKey type MessageKeyHashid = KeyHashid Message type LocalMessageKeyHashid = KeyHashid LocalMessage type TicketDepKeyHashid = KeyHashid TicketDependency diff --git a/src/Vervis/Handler/Key.hs b/src/Vervis/Handler/Key.hs index 33855b7..5ca5952 100644 --- a/src/Vervis/Handler/Key.hs +++ b/src/Vervis/Handler/Key.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2018 by fr33domlover . + - Written in 2016, 2018, 2019 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -18,11 +18,13 @@ module Vervis.Handler.Key , postKeysR , getKeyNewR , getKeyR + , getSshKeyR , deleteKeyR , postKeyR ) where +import Control.Monad import Data.ByteString.Base64 (encode) import Data.Monoid ((<>)) import Data.Text (Text, intercalate) @@ -32,12 +34,19 @@ import Database.Persist import Network.HTTP.Types (StdMethod (DELETE)) import Text.Blaze.Html (Html, toHtml) import Yesod.Auth (requireAuthId) -import Yesod.Core (defaultLayout) +import Yesod.Core import Yesod.Core.Handler import Yesod.Core.Widget (setTitle) import Yesod.Form.Functions (runFormPost) import Yesod.Form.Types (FormResult (..)) -import Yesod.Persist.Core (runDB, getBy404) +import Yesod.Persist.Core + +import Web.ActivityPub +import Yesod.ActivityPub +import Yesod.FedURI +import Yesod.Hashids + +import Yesod.Persist.Local import Vervis.Form.Key import Vervis.Foundation @@ -84,6 +93,29 @@ getKeyR tag = do content = toText $ encode $ sshKeyContent key defaultLayout $(widgetFile "key/one") +getSshKeyR :: ShrIdent -> KeyHashid SshKey -> Handler TypedContent +getSshKeyR shr skkhid = do + skid <- decodeKeyHashid404 skkhid + key <- runDB $ do + sid <- getKeyBy404 $ UniqueSharer shr + pid <- getKeyBy404 $ UniquePersonIdent sid + sk <- get404 skid + unless (sshKeyPerson sk == pid) notFound + return sk + encodeRouteLocal <- getEncodeRouteLocal + let here = SshKeyR shr skkhid + keyAP = SshPublicKey + { sshPublicKeyId = encodeRouteLocal here + , sshPublicKeyExpires = Nothing + , sshPublicKeyOwner = encodeRouteLocal $ SharerR shr + , sshPublicKeyAlgorithm = + case sshKeyAlgo key of + "ssh-rsa" -> SshKeyAlgorithmRSA + _ -> error "Unexpected sshKeyAlgo in DB" + , sshPublicKeyMaterial = sshKeyContent key + } + provideHtmlAndAP keyAP $ redirectToPrettyJSON here + deleteKeyR :: KyIdent -> Handler Html deleteKeyR tag = do pid <- requireAuthId diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index 83e6ea0..99ff89b 100644 --- a/src/Vervis/Handler/Person.hs +++ b/src/Vervis/Handler/Person.hs @@ -28,6 +28,7 @@ import Yesod.Auth.Account.Message (AccountMsg (MsgEmailUnverified)) import Yesod.Persist.Core import qualified Data.Text as T (unpack) +import qualified Database.Persist as P import Yesod.Auth.Unverified (requireUnverifiedAuth) @@ -37,6 +38,7 @@ import Network.FedURI import Web.ActivityPub import Yesod.ActivityPub import Yesod.FedURI +import Yesod.Hashids import Vervis.ActorKey import Vervis.Foundation @@ -127,9 +129,11 @@ getPersonNewR = redirect $ AuthR newAccountR else notFound -} -getPerson :: ShrIdent -> Sharer -> Person -> Handler TypedContent -getPerson shr sharer person = do +getPerson :: ShrIdent -> Sharer -> Entity Person -> Handler TypedContent +getPerson shr sharer (Entity pid person) = do encodeRouteLocal <- getEncodeRouteLocal + encodeKeyHashid <- getEncodeKeyHashid + skids <- runDB $ P.selectKeysList [SshKeyPerson P.==. pid] [P.Asc SshKeyId] let personAP = Actor { actorId = encodeRouteLocal $ SharerR shr , actorType = ActorTypePerson @@ -143,6 +147,8 @@ getPerson shr sharer person = do [ Left $ encodeRouteLocal ActorKey1R , Left $ encodeRouteLocal ActorKey2R ] + , actorSshKeys = + map (encodeRouteLocal . SshKeyR shr . encodeKeyHashid) skids } secure <- getSecure provideHtmlAndAP personAP $(widgetFile "person") diff --git a/src/Vervis/Handler/Project.hs b/src/Vervis/Handler/Project.hs index 37e5796..661250e 100644 --- a/src/Vervis/Handler/Project.hs +++ b/src/Vervis/Handler/Project.hs @@ -157,6 +157,7 @@ getProjectR shar proj = do [ Left $ route2local ActorKey1R , Left $ route2local ActorKey2R ] + , actorSshKeys = [] } , AP.projectTeam = route2local $ ProjectTeamR shar proj } diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index 235ebec..19c54b0 100644 --- a/src/Vervis/Handler/Repo.hs +++ b/src/Vervis/Handler/Repo.hs @@ -231,6 +231,7 @@ getRepoR shr rp = do [ Left $ encodeRouteLocal ActorKey1R , Left $ encodeRouteLocal ActorKey2R ] + , actorSshKeys = [] } , AP.repoTeam = encodeRouteLocal $ RepoTeamR shr rp } diff --git a/src/Vervis/Handler/Sharer.hs b/src/Vervis/Handler/Sharer.hs index 40b2af5..6a84fd3 100644 --- a/src/Vervis/Handler/Sharer.hs +++ b/src/Vervis/Handler/Sharer.hs @@ -67,7 +67,7 @@ getSharerR shr = do notFound Just (s, ent) -> case ent of - Left (Entity _ p) -> getPerson shr s p + Left ep -> getPerson shr s ep Right (Entity _ g) -> getGroup shr g getSharerFollowersR :: ShrIdent -> Handler TypedContent diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index c43f219..da37728 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -30,6 +30,8 @@ module Web.ActivityPub --, Algorithm (..) , Owner (..) , PublicKey (..) + , SshKeyAlgorithm (..) + , SshPublicKey (..) , Actor (..) , Repo (..) , Project (..) @@ -105,7 +107,7 @@ import Data.List.NonEmpty (NonEmpty (..)) import Data.Proxy import Data.Semigroup (Endo, First (..)) import Data.Text (Text) -import Data.Text.Encoding (encodeUtf8, decodeUtf8) +import Data.Text.Encoding (encodeUtf8, decodeUtf8, decodeUtf8') import Data.Time.Clock (UTCTime) import Data.Traversable import Network.HTTP.Client hiding (Proxy, proxy) @@ -120,6 +122,7 @@ import Yesod.Core.Handler (ProvidedRep, provideRepType) import Network.HTTP.Client.Signature import qualified Data.Attoparsec.ByteString as A +import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as BL import qualified Data.HashMap.Strict as M @@ -274,6 +277,70 @@ encodePublicKeySet authority es = renderKey (Left lu) = toEncoding $ ObjURI authority lu renderKey (Right pk) = pairs $ toSeries authority pk +data SshKeyAlgorithm + = SshKeyAlgorithmRSA + | SshKeyAlgorithmDSA + | SshKeyAlgorithmECDSA + | SshKeyAlgorithmEd25519 + +instance FromJSON SshKeyAlgorithm where + parseJSON = withText "SshKeyAlgorithm" parse + where + parse t + | t == "ssh-rsa" = pure SshKeyAlgorithmRSA + | t == "ssh-dsa" = pure SshKeyAlgorithmDSA + | t == "ssh-ecdsa" = pure SshKeyAlgorithmECDSA + | t == "ssh-ed25519" = pure SshKeyAlgorithmEd25519 + | otherwise = + fail $ "Unrecognized ssh key algo: " ++ T.unpack t + +instance ToJSON SshKeyAlgorithm where + toJSON = error "toJSON SshKeyAlgorithm" + toEncoding = toEncoding . render + where + render :: SshKeyAlgorithm -> Text + render SshKeyAlgorithmRSA = "ssh-rsa" + render SshKeyAlgorithmDSA = "ssh-dsa" + render SshKeyAlgorithmECDSA = "ssh-ecdsa" + render SshKeyAlgorithmEd25519 = "ssh-ed25519" + +data SshPublicKey u = SshPublicKey + { sshPublicKeyId :: LocalURI + , sshPublicKeyExpires :: Maybe UTCTime + , sshPublicKeyOwner :: LocalURI + , sshPublicKeyAlgorithm :: SshKeyAlgorithm + , sshPublicKeyMaterial :: ByteString + } + +instance ActivityPub SshPublicKey where + jsonldContext _ = [secContext, forgeContext, extContext] + parseObject o = do + mtyp <- optional $ o .: "@type" <|> o .: "type" + for_ mtyp $ \ t -> + when (t /= ("SshKey" :: Text)) $ + fail "SshKey @type isn't SshKey" + + mediaType <- o .: "mediaType" + unless (mediaType == ("application/octet-stream" :: Text)) $ + fail "mediaType isn't octet-stream" + + ObjURI authority luId <- o .: "@id" <|> o .: "id" + fmap (authority,) $ + SshPublicKey luId + <$> o .:? "expires" + <*> withAuthorityO authority (o .: "owner") + <*> o .: "sshKeyType" + <*> (decodeBase64 . encodeUtf8 =<< o .: "content") + where + decodeBase64 = either fail return . B64.decode + toSeries authority (SshPublicKey luId mexpires owner algo mat) + = "@id" .= ObjURI authority luId + <> "expires" .=? mexpires + <> "owner" .= ObjURI authority owner + <> "sshKeyType" .= algo + <> "mediaType" .= ("application/octet-stream" :: Text) + <> "content" .= decodeUtf8 (B64.encode mat) + data Actor u = Actor { actorId :: LocalURI , actorType :: ActorType @@ -284,10 +351,11 @@ data Actor u = Actor , actorOutbox :: Maybe LocalURI , actorFollowers :: Maybe LocalURI , actorPublicKeys :: [Either LocalURI (PublicKey u)] + , actorSshKeys :: [LocalURI] } instance ActivityPub Actor where - jsonldContext _ = [as2Context, secContext, extContext] + jsonldContext _ = [as2Context, secContext, forgeContext, extContext] parseObject o = do ObjURI authority id_ <- o .: "id" fmap (authority,) $ @@ -300,8 +368,9 @@ instance ActivityPub Actor where <*> withAuthorityMaybeO authority (o .:? "outbox") <*> withAuthorityMaybeO authority (o .:? "followers") <*> withAuthorityT authority (parsePublicKeySet =<< o .: "publicKey") + <*> (traverse (withAuthorityO authority . return) =<< o .: "sshKey") toSeries authority - (Actor id_ typ musername mname msummary inbox outbox followers pkeys) + (Actor id_ typ musername mname msummary inbox outbox followers pkeys skeys) = "id" .= ObjURI authority id_ <> "type" .= typ <> "preferredUsername" .=? musername @@ -311,6 +380,7 @@ instance ActivityPub Actor where <> "outbox" .=? (ObjURI authority <$> outbox) <> "followers" .=? (ObjURI authority <$> followers) <> "publicKey" `pair` encodePublicKeySet authority pkeys + <> "sshKey" .= map (ObjURI authority) skeys data Repo u = Repo { repoActor :: Actor u