Make noteId optional, to support taking a Note in postOutboxR

src/Vervis/Federation.hs

@@ -146,7 +146,8 @@ handleActivity raw hActor iidActor rsidActor (Activity _id _luActor audience spe
                 rm E.^. RemoteMessageLostParent E.==. E.just (E.val uNote) E.&&.
                 m E.^. MessageRoot `op` E.val did
             return (rm E.^. RemoteMessageId, m E.^. MessageId)
-    handleCreate iidActor hActor rsidActor raw audience (Note luNote _luAttrib muParent muContext mpublished content) = do
+    handleCreate iidActor hActor rsidActor raw audience (Note mluNote _luAttrib muParent muContext mpublished content) = do
+        luNote <- fromMaybeE mluNote "Got Create Note without note id"
         (shr, prj) <- do
             uRecip <- parseAudience audience
             parseProject uRecip

src/Vervis/Handler/Discussion.hs

@@ -141,7 +141,7 @@ getDiscussionMessage shr lmid = selectRep $ provideAP $ runDB $ do
     route2local <- getEncodeRouteLocal
     let lmhid = encodeHid $ fromSqlKey lmid
     return $ Doc host Note
-        { noteId        = route2local $ MessageR shr lmhid
+        { noteId        = Just $ route2local $ MessageR shr lmhid
         , noteAttrib    = route2local $ SharerR shr
         , noteReplyTo   = Just $ fromMaybe uContext muParent
         , noteContext   = Just uContext

src/Vervis/Handler/Inbox.hs

@@ -85,6 +85,7 @@ import Database.Persist.Local
 import Network.FedURI
 import Web.ActivityPub
 import Yesod.Auth.Unverified
+import Yesod.FedURI
 
 import Vervis.ActorKey
 import Vervis.Federation
@@ -228,12 +229,6 @@ getPublishR = do
 getOutboxR :: Handler TypedContent
 getOutboxR = error "Not implemented yet"
 
-route2uri' :: (Route App -> Text) -> Route App -> FedURI
-route2uri' renderUrl r =
-    case parseFedURI $ renderUrl r of
-        Left e -> error e
-        Right u -> u
-
 postOutboxR :: Handler Html
 postOutboxR = do
     ((result, widget), enctype) <- runFormPost activityForm
@@ -247,9 +242,9 @@ postOutboxR = do
                 sharer <- runDB $ get404 $ personIdent person
                 return $ sharerIdent sharer
             renderUrl <- getUrlRender
+            route2uri <- getEncodeRouteFed
             now <- liftIO getCurrentTime
-            let route2uri = route2uri' renderUrl
+            let (h, actor) = f2l $ route2uri $ SharerR shr
-                (h, actor) = f2l $ route2uri $ SharerR shr
                 actorID = renderUrl $ SharerR shr
                 appendPath u t = u { luriPath = luriPath u <> t }
                 activity = Activity
@@ -264,7 +259,8 @@ postOutboxR = do
                         }
                     , activitySpecific = CreateActivity Create
                         { createObject = Note
-                            { noteId        = appendPath actor "/fake-note"
+                            { noteId        = Just $ appendPath actor "/fake-note"
+                            , noteAttrib    = actor
                             , noteReplyTo   = mparent
                             , noteContext   = mcontext
                             , notePublished = Just now
@@ -328,7 +324,7 @@ getActorKey choose route = selectRep $ provideAP $ do
     actorKey <-
         liftIO . fmap (actorKeyPublicBin . choose) . readTVarIO =<<
         getsYesod appActorKeys
-    route2uri <- route2uri' <$> getUrlRender
+    route2uri <- getEncodeRouteFed
     let (host, id_) = f2l $ route2uri route
     return $ Doc host PublicKey
         { publicKeyId       = id_

src/Web/ActivityPub.hs

@@ -81,6 +81,7 @@ import Data.Semigroup (Endo, First (..))
 import Data.Text (Text)
 import Data.Text.Encoding (encodeUtf8, decodeUtf8)
 import Data.Time.Clock (UTCTime)
+import Data.Traversable
 import Data.Vector (Vector)
 import Network.HTTP.Client hiding (Proxy, proxy)
 import Network.HTTP.Client.Conduit.ActivityPub (httpAPEither)
@@ -316,7 +317,7 @@ instance ActivityPub Actor where
         <> "publicKey"         `pair` encodePublicKeySet host pkeys
 
 data Note = Note
-    { noteId        :: LocalURI
+    { noteId        :: Maybe LocalURI
     , noteAttrib    :: LocalURI
     --, noteTo      :: FedURI
     , noteReplyTo   :: Maybe FedURI
@@ -331,22 +332,31 @@ withHost h a = do
         then return v
         else fail "URI host mismatch"
 
+withHostM h a = do
+    mp <- a
+    for mp $ \ (h', v) ->
+        if h == h'
+            then return v
+            else fail "URI host mismatch"
+
 instance ActivityPub Note where
     jsonldContext _ = ContextAS2
     parseObject o = do
         typ <- o .: "type"
         unless (typ == ("Note" :: Text)) $ fail "type isn't Note"
+        (h, attrib) <- f2l <$> o .: "attributedTo"
         (h, id_) <- f2l <$> o .: "id"
         fmap (h,) $
-            Note id_
+            Note
-                <$> withHost h (f2l <$> o .:  "attributedTo")
+                <$> withHostM h (fmap f2l <$> o .:? "id")
+                <*> pure attrib
                 <*> o .:? "inReplyTo"
                 <*> o .:? "context"
                 <*> o .:? "published"
                 <*> o .:  "content"
-    toSeries host (Note id_ attrib mreply mcontext mpublished content)
+    toSeries host (Note mid attrib mreply mcontext mpublished content)
         =  "type"         .=  ("Note" :: Text)
-        <> "id"           .=  l2f host id_
+        <> "id"           .=? (l2f host <$> mid)
         <> "attributedTo" .=  l2f host attrib
         <> "inReplyTo"    .=? mreply
         <> "context"      .=? mcontext