Publish AS2 representation of SSH keys and list SSH keys in actor documents

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

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

src/Vervis/Handler/Key.hs

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

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 :: ShrIdent -> Sharer -> Entity Person -> Handler TypedContent
-getPerson shr sharer person = do
+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")

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
             }

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
             }

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

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