mirror of
https://code.sup39.dev/repos/Wqawg
synced 2024-12-29 00:24:51 +09:00
Publish AS2 representation of SSH keys and list SSH keys in actor documents
This commit is contained in:
fr33domlover
parent
0be7fa05f8
commit
a419db5b5b
8 changed files with 122 additions and 9 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2016, 2018 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2016, 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ 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
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
|
|
|
|||
|
|
@ -157,6 +157,7 @@ getProjectR shar proj = do
|
|||
[ Left $ route2local ActorKey1R
|
||||
, Left $ route2local ActorKey2R
|
||||
]
|
||||
, actorSshKeys = []
|
||||
}
|
||||
, AP.projectTeam = route2local $ ProjectTeamR shar proj
|
||||
}
|
||||
|
|
|
|||
|
|
@ -231,6 +231,7 @@ getRepoR shr rp = do
|
|||
[ Left $ encodeRouteLocal ActorKey1R
|
||||
, Left $ encodeRouteLocal ActorKey2R
|
||||
]
|
||||
, actorSshKeys = []
|
||||
}
|
||||
, AP.repoTeam = encodeRouteLocal $ RepoTeamR shr rp
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue