rewrite api to be a bit richer

app/Css.hs

@@ -4,7 +4,8 @@ import Data.Text qualified as T
 import Text.RawString.QQ
 
 css :: T.Text
-css = [r|
+css =
+  [r|
 body {
   margin: 40px auto;
   max-width: 650px;

app/DB.hs

@@ -1,21 +1,21 @@
 -- | Database interaction
 module DB where
 
-import Data.Maybe (listToMaybe)
-import GHC.Stack (HasCallStack)
 import Data.Text qualified as T
 import Database.Sqlite.Easy qualified as DB
-import Text.RawString.QQ
 import Fedi
+import GHC.Stack (HasCallStack)
+import Text.RawString.QQ
 
 -----------------------
+
 -- * Database handler API
 
 data DB
   = DB
   { getNotes :: IO [Note]
   , getNote :: DB.Int64 -> IO (Maybe Note)
-    , insertNote :: NoteEntry -> IO NoteId
+  , insertNote :: NoteEntry -> IO ObjectId
   }
 
 -- * Data types
@@ -29,13 +29,15 @@ data NoteEntry
   }
 
 -----------------------
+
 -- * Handler smart constructor
 
 mkDB :: DB.ConnectionString -> UserDetails -> IO DB
 mkDB connstr details = do
   pool <- DB.createSqlitePool connstr
   DB.withPool pool runMigrations
-  pure DB
+  pure
+    DB
       { getNotes =
           DB.withPool pool (getNotesFromDb $ actorUrl details)
       , getNote =
@@ -45,9 +47,10 @@ mkDB connstr details = do
       }
 
 -----------------------
+
 -- * Database migrations
 
-runMigrations :: HasCallStack => DB.SQLite ()
+runMigrations :: (HasCallStack) => DB.SQLite ()
 runMigrations = DB.migrate migrations migrateUp migrateDown
 
 migrations :: [DB.MigrationName]
@@ -55,10 +58,11 @@ migrations =
   [ "note"
   ]
 
-migrateUp :: HasCallStack => DB.MigrationName -> DB.SQLite ()
+migrateUp :: (HasCallStack) => DB.MigrationName -> DB.SQLite ()
 migrateUp = \case
   "note" -> do
-    [] <- DB.run
+    [] <-
+      DB.run
         [r| create table note(
           id integer primary key autoincrement,
           published datetime default (datetime('now')),
@@ -71,10 +75,9 @@ migrateUp = \case
       |]
 
     pure ()
-
   name -> error $ "unexpected migration: " <> show name
 
-migrateDown :: HasCallStack => DB.MigrationName -> DB.SQLite ()
+migrateDown :: (HasCallStack) => DB.MigrationName -> DB.SQLite ()
 migrateDown = \case
   "notes" -> do
     [] <- DB.run "DROP TABLE note"
@@ -82,6 +85,7 @@ migrateDown = \case
   name -> error $ "unexpected migration: " <> show name
 
 -----------------------
+
 -- * Database actions
 
 getNotesFromDb :: Url -> DB.SQLite [Note]
@@ -93,7 +97,7 @@ getNoteFromDb noteid url = do
   n <- map decodeNoteRow <$> uncurry DB.runWith (getNoteSQL noteid url)
   pure (listToMaybe n)
 
-insertNoteToDb :: Url -> NoteEntry -> DB.SQLite NoteId
+insertNoteToDb :: Url -> NoteEntry -> DB.SQLite ObjectId
 insertNoteToDb actor note = do
   [n] <- map decodeNoteIdRow <$> uncurry DB.runWith (insertNoteSQL actor note)
   pure n
@@ -143,7 +147,8 @@ insertNoteSQL actor note =
       VALUES (?, ?, ?, ?, ?)
       RETURNING cast(id as text)
     |]
-  , [ DB.SQLText (T.pack actor)
+  ,
+    [ DB.SQLText (T.pack actor)
     , toNullableString note.inReplyTo
     , DB.SQLText note.content
     , toNullableString note.name
@@ -152,39 +157,47 @@ insertNoteSQL actor note =
   )
 
 -----------------------
+
 -- ** Decode row
 
 decodeNoteRow :: [DB.SQLData] -> Note
 decodeNoteRow = \case
-  [ DB.SQLText noteid,
+  [ DB.SQLText noteid
-    DB.SQLText published,
+    , DB.SQLText published
-    DB.SQLText actor,
+    , DB.SQLText actor
-    DB.SQLText content,
+    , DB.SQLText content
-    nullableString -> Just name,
+    , nullableString -> Just name
-    nullableString -> Just inReplyTo,
+    , nullableString -> Just inReplyTo
-    nullableString -> Just url
+    , nullableString -> Just url
     ] ->
-      Note
+      let
-        { id = T.unpack noteid
+        emptyNote = emptyUserNote $ T.unpack actor
-        , published = read (T.unpack published)
+      in
-        , actor = T.unpack actor
+        emptyNote
-        , inReplyTo = inReplyTo
+          { id = Just $ ObjectId $ T.unpack noteid
-        , content = content
+          , published = Just $ read (T.unpack published)
+          , attributedTo = Just $ LLink $ Link $ T.unpack actor
+          , inReplyTo = LLink . Link <$> inReplyTo
+          , content = Just content
           , url = url
-        , name = name
+          , name = StringName <$> name
-        , replies = Collection
+          , otype =
-          { id = T.unpack noteid <> "/replies"
+              emptyNote.otype
-          , summary = "Replies"
+                { likes =
-          , items = []
+                    emptyNote.otype.likes
-          , first = Nothing
+                      { id = Just $ ObjectId $ T.unpack noteid <> "/likes"
-          , last = Nothing
+                      }
+                , shares =
+                    emptyNote.otype.shares
+                      { id = Just $ ObjectId $ T.unpack noteid <> "/shares"
+                      }
                 }
           }
   row -> error $ "Couldn't decode row as Note: " <> show row
 
-decodeNoteIdRow :: [DB.SQLData] -> NoteId
+decodeNoteIdRow :: [DB.SQLData] -> ObjectId
 decodeNoteIdRow = \case
-  [ DB.SQLText noteid] -> T.unpack noteid
+  [DB.SQLText noteid] -> ObjectId $ T.unpack noteid
   row -> error $ "Couldn't decode row as NoteId: " <> show row
 
 nullableString :: DB.SQLData -> Maybe (Maybe String)

app/Html.hs

@@ -1,12 +1,11 @@
 module Html where
 
-import Data.String (fromString)
-import Data.Char (ord, isAlpha)
-import Data.Text qualified as T
-import Lucid qualified as H
-
-import Fedi qualified as Fedi
 import Css (css)
+import Data.Char (isAlpha, ord)
+import Data.String (fromString)
+import Data.Text qualified as T
+import Fedi qualified as Fedi
+import Lucid qualified as H
 
 -- * HTML
 
@@ -60,9 +59,9 @@ noteHtml note = do
   H.div_ [H.class_ "note"] $ do
     H.div_ [H.class_ "note-header"] $ do
       case note.name of
-        Just title ->
+        Just (Fedi.StringName title) ->
           H.h2_ [H.class_ (checkDirection $ T.pack title)] (fromString title)
-        Nothing -> pure ()
+        _ -> pure ()
 
       case note.url of
         Just url ->
@@ -70,14 +69,14 @@ noteHtml note = do
         Nothing -> pure ()
 
       H.a_
-        [ H.href_ (T.pack note.id)
+        [ H.href_ (T.pack (maybe "" (\i -> i.unwrap) note.id))
         , H.class_ "note-time"
         , H.title_ "See note page"
         ]
         (H.toHtml (T.pack (show note.published)))
 
-    H.div_ [H.class_ $ "note-content " <> checkDirection note.content] $ do
+    H.div_ [H.class_ $ "note-content " <> checkDirection (maybe "" id note.content)] $ do
-      H.toHtmlRaw note.content
+      H.toHtmlRaw (maybe "" id note.content)
 
 checkDirection :: T.Text -> T.Text
 checkDirection txt =
@@ -95,7 +94,8 @@ newNoteHtml details = do
     , H.class_ "new-note"
     ]
     ( do
-      H.div_ [ H.class_ "new-note-div" ] $ H.input_
+        H.div_ [H.class_ "new-note-div"] $
+          H.input_
             [ H.class_ "new-note-text"
             , H.autofocus_
             , H.type_ "text"
@@ -103,20 +103,24 @@ newNoteHtml details = do
             , H.placeholder_ "A title (optional)"
             ]
 
-      H.div_ [ H.class_ "new-note-div" ] $ H.textarea_
+        H.div_ [H.class_ "new-note-div"] $
+          H.textarea_
             [ H.class_ "new-note-content"
             , H.name_ "content"
             , H.placeholder_ "Yes?"
-        ] ""
+            ]
+            ""
 
-      H.div_ [ H.class_ "new-note-div" ] $ H.input_
+        H.div_ [H.class_ "new-note-div"] $
+          H.input_
             [ H.class_ "new-note-text"
             , H.type_ "url"
             , H.name_ "url"
             , H.placeholder_ "A URL this note should link to (optional)"
             ]
 
-      H.div_ [ H.class_ "new-note-div" ] $ H.input_
+        H.div_ [H.class_ "new-note-div"] $
+          H.input_
             [ H.class_ "new-note-submit"
             , H.type_ "submit"
             , H.title_ "Add a new note"

app/Main.hs

@@ -1,23 +1,21 @@
 module Main where
 
+import DB
+import Data.Aeson qualified as A
+import Data.Functor ((<&>))
 import Data.SecureMem (secureMemFromByteString)
 import Data.String (fromString)
+import Data.Text qualified as T
+import Data.Text.Encoding qualified as T
+import Data.Text.IO qualified as T
 import Database.Sqlite.Easy qualified as Sqlite
-import Data.Aeson qualified as A
+import Network.Wai.Handler.Warp (Port, run)
-import Network.Wai.Handler.Warp (run, Port)
-import Network.Wai.Middleware.Routed qualified as Wai
 import Network.Wai.Middleware.HttpAuth (basicAuth)
 import Network.Wai.Middleware.RequestLogger qualified as Logger
-import System.Environment (getArgs)
+import Network.Wai.Middleware.Routed qualified as Wai
-import System.Environment (lookupEnv)
-import Web.Twain qualified as Twain
-import Data.Functor ((<&>))
-import qualified Data.Text.Encoding as T
-import qualified Data.Text.IO as T
-import qualified Data.Text as T
-
-import DB
 import Routes
+import System.Environment (getArgs, lookupEnv)
+import Web.Twain qualified as Twain
 
 data Command
   = Serve
@@ -25,7 +23,8 @@ data Command
 
 main :: IO ()
 main = do
-  command <- getArgs >>= \case
+  command <-
+    getArgs >>= \case
       ["insert", file] -> pure (Insert file)
       ["serve"] -> pure Serve
       _ -> usageError
@@ -41,15 +40,19 @@ insertNoteFromFile file = do
   connStr <- maybe "/tmp/fediserve_sqlite_db.sqlite" fromString <$> lookupEnv "FEDI_CONN_STRING"
   content <- T.readFile file
 
-  detailsFile <- lookupEnv "FEDI_DETAILS"
+  detailsFile <-
+    lookupEnv "FEDI_DETAILS"
       <&> maybe (error "missing FEDI_DETAILS") id
 
-  details <- A.eitherDecodeFileStrict detailsFile
+  details <-
+    A.eitherDecodeFileStrict detailsFile
       <&> either (\err -> error $ "could not read file '" <> detailsFile <> "'.\n" <> err) id
 
   db <- mkDB connStr details
 
-  note <- db.insertNote NoteEntry
+  note <-
+    db.insertNote
+      NoteEntry
         { content = content
         , inReplyTo = Nothing
         , name = Nothing
@@ -59,7 +62,6 @@ insertNoteFromFile file = do
   putStrLn "Inserted."
   print note
 
-
 serve :: IO ()
 serve = do
   auth <- fmap (T.splitOn "," . T.pack) <$> lookupEnv "FEDI_AUTH"
@@ -73,8 +75,10 @@ serve = do
         let
           username = secureMemFromByteString $ T.encodeUtf8 user
           password = secureMemFromByteString $ T.encodeUtf8 pass
-        pure $ basicAuth
+        pure $
-          ( \u p -> pure $
+          basicAuth
+            ( \u p ->
+                pure $
                   secureMemFromByteString u == username
                     && secureMemFromByteString p == password
             )
@@ -89,7 +93,8 @@ serve = do
 
 usageError :: err
 usageError =
-  errorWithoutStackTrace $ unlines
+  errorWithoutStackTrace $
+    unlines
       [ "Usage: fedi [ insert <FILE> | serve ]"
       , "Env vars:"
       , " - FEDI_PORT=<PORT>"
@@ -101,7 +106,8 @@ usageError =
 -- | Run server at at specific port.
 runServer :: Port -> Twain.Middleware -> Twain.Application -> IO ()
 runServer port authMiddleware app = do
-  putStrLn $ unwords
+  putStrLn $
+    unwords
       [ "Running fedi at"
       , "http://localhost:" <> show port
       , "(ctrl-c to quit)"
@@ -109,21 +115,24 @@ runServer port authMiddleware app = do
   auth <- Wai.routedMiddleware matchAdmin <$> pure authMiddleware
   run port (Logger.logStdoutDev $ auth app)
 
-
 matchAdmin :: [T.Text] -> Bool
 matchAdmin = any (== "admin")
 
 -- | Application description.
 mkFediApp :: Sqlite.ConnectionString -> IO Twain.Application
 mkFediApp connStr = do
-  detailsFile <- lookupEnv "FEDI_DETAILS"
+  detailsFile <-
+    lookupEnv "FEDI_DETAILS"
       <&> maybe (error "missing FEDI_DETAILS") id
 
-  details <- A.eitherDecodeFileStrict detailsFile
+  details <-
+    A.eitherDecodeFileStrict detailsFile
       <&> either (\err -> error $ "could not read file '" <> detailsFile <> "'.\n" <> err) id
 
   db <- mkDB connStr details
 
-  pure $ foldr ($)
+  pure $
+    foldr
+      ($)
       (Twain.notFound $ Twain.send $ Twain.text "Error: not found.")
       (routes db detailsFile)

app/Routes.hs

@@ -1,17 +1,16 @@
 module Routes where
 
+import Control.Monad.IO.Class (liftIO)
+import DB
+import Data.Aeson qualified as A
+import Data.Functor ((<&>))
 import Data.Maybe (maybeToList)
 import Data.String (fromString)
-import Data.Aeson qualified as A
-import Web.Twain qualified as Twain
 import Fedi qualified as Fedi
-import Data.Functor ((<&>))
-import System.IO.Unsafe (unsafePerformIO)
-import Control.Monad.IO.Class (liftIO)
-import Lucid qualified as H
-
 import Html
-import DB
+import Lucid qualified as H
+import System.IO.Unsafe (unsafePerformIO)
+import Web.Twain qualified as Twain
 
 routes :: DB -> FilePath -> [Twain.Middleware]
 routes db detailsFile =
@@ -26,20 +25,17 @@ routes db detailsFile =
           details <- liftIO $ fetchUserDetails detailsFile
           notes <- liftIO db.getNotes
           Twain.send $ Twain.html $ H.renderBS $ actorPage details notes
-
   , -- Match outbox
     Twain.get (Fedi.matchOutbox $ unsafePerformIO $ fetchUserDetails detailsFile) do
       details <- liftIO $ fetchUserDetails detailsFile
-      notes <- map noteToCreate <$> liftIO db.getNotes
+      notes <- map (Fedi.ActivityCreate . noteToCreate) <$> liftIO db.getNotes
       Fedi.handleOutbox details notes
-
   , -- Match Create object
-    Twain.get (Fedi.matchCreate $ unsafePerformIO $ fetchUserDetails detailsFile) do
+    Twain.get (Fedi.matchCreateNote $ unsafePerformIO $ fetchUserDetails detailsFile) do
       details <- liftIO $ fetchUserDetails detailsFile
       notes <- map noteToCreate <$> liftIO db.getNotes
 
-      Fedi.handleCreate details notes
+      Fedi.handleCreateNote details notes
-
   , -- Match Note object
     Twain.get (Fedi.matchNote $ unsafePerformIO $ fetchUserDetails detailsFile) do
       details <- liftIO $ fetchUserDetails detailsFile
@@ -55,18 +51,15 @@ routes db detailsFile =
             Nothing -> Twain.next
             Just thenote ->
               Twain.send $ Twain.html $ H.renderBS $ actorPage details [thenote]
-
   , -- Match webfinger
     Twain.get Fedi.matchWebfinger do
       details <- liftIO $ fetchUserDetails detailsFile
       Fedi.handleWebfinger details
-
   , -- Admin page
     Twain.get (fromString $ "/" <> (unsafePerformIO $ fetchUserDetails detailsFile).username <> "/admin") do
       details <- liftIO $ fetchUserDetails detailsFile
       notes <- liftIO db.getNotes
       Twain.send $ Twain.html $ H.renderBS $ adminPage details notes
-
   , -- New post
     Twain.post (fromString $ "/" <> (unsafePerformIO $ fetchUserDetails detailsFile).username <> "/admin/new") do
       title <- Twain.param "title"
@@ -75,14 +68,16 @@ routes db detailsFile =
       details <- liftIO $ fetchUserDetails detailsFile
 
       noteid <-
-        liftIO $ db.insertNote NoteEntry
+        liftIO $
+          db.insertNote
+            NoteEntry
               { content = content
               , inReplyTo = Nothing
               , name = if trim title == "" then Nothing else Just title
               , url = if trim url == "" then Nothing else Just url
               }
 
-      Twain.send $ Twain.redirect302 (fromString ("/" <> details.username <> "/notes/" <> noteid))
+      Twain.send $ Twain.redirect302 (fromString ("/" <> details.username <> "/notes/" <> noteid.unwrap))
   ]
 
 trim :: String -> String
@@ -93,11 +88,5 @@ fetchUserDetails detailsFile =
   A.eitherDecodeFileStrict detailsFile
     <&> either (\err -> error $ "could not read file '" <> detailsFile <> "'.\n" <> err) id
 
-noteToCreate :: Fedi.Note -> Fedi.Activity
+noteToCreate :: Fedi.Note -> Fedi.Create
-noteToCreate note =
+noteToCreate note = Fedi.makeCreateNote note
-    Fedi.Create
-      { id =
-        note.id <> "/create"
-      , actor = note.actor
-      , object = Fedi.NoteObject note
-      }

fedi.cabal

@@ -17,10 +17,10 @@ library
   import: warnings
   exposed-modules:
     Fedi
-    Fedi.Activity
+    Fedi.Helpers
-    Fedi.Actor
     Fedi.Routes
     Fedi.Types
+    Fedi.UserDetails
     Fedi.Webfinger
   -- other-modules:
   -- other-extensions:

fourmolu.yaml

@@ -0,0 +1,16 @@
+indentation: 2
+column-limit: 150
+function-arrows: leading
+comma-style: leading
+import-export-style: diff-friendly
+indent-wheres: true
+record-brace-space: true
+newlines-between-decls: 1
+haddock-style: single-line
+haddock-style-module: single-line
+let-style: newline
+in-style: left-align
+single-constraint-parens: always
+unicode: never
+respectful: false
+fixities: []

src/Fedi.hs

@@ -1,7 +1,7 @@
 module Fedi (module Export) where
 
-import Fedi.Activity as Export
+import Fedi.Helpers as Export
-import Fedi.Actor as Export
 import Fedi.Routes as Export
 import Fedi.Types as Export
+import Fedi.UserDetails as Export
 import Fedi.Webfinger as Export

src/Fedi/Activity.hs

@@ -1,168 +0,0 @@
-module Fedi.Activity where
-
-import Data.Aeson qualified as A
-import Data.Text qualified as T
-import Fedi.Types
-import Fedi.Actor
-import Data.Time (UTCTime)
-
-data Activity
-  = Create
-    { id :: ActivityUrl
-    , actor :: ActorId
-    , object :: Object
-    }
-  deriving Show
-
-activityUrl :: Activity -> ActivityUrl
-activityUrl = \case
-  create@Create{} -> create.id
-
-type ActivityUrl = Url
-
-data Object
-  = NoteObject Note
-  deriving Show
-
-objectUrl :: Object -> Url
-objectUrl = \case
-  NoteObject note -> note.id
-
-data Note
-  = Note
-    { id :: NoteId
-    , published :: UTCTime
-    , inReplyTo :: Maybe Url
-    , actor :: ActorId
-    , content :: T.Text
-    , name :: Maybe String
-    , url :: Maybe Url
-    , replies :: Collection Unordered Note
-    }
-  deriving Show
-
-type NoteId = Url
-
-type Followers = [Actor]
-type Following = [Actor]
-
-type Inbox = Collection Ordered Activity
-type Outbox = Collection Ordered Activity
-type OutboxPage = OrderedCollectionPage Activity
-
-data Ordered
-data Unordered
-
-data OrderedCollectionPage a
-  = OrderedCollectionPage
-    { id :: Url
-    , partOf :: Url
-    , orderedItems :: [a]
-    }
-  deriving Show
-
-data Collection order a
-  = Collection
-    { id :: Url
-    , summary :: String
-    , items :: [a]
-    , first :: Maybe Url
-    , last :: Maybe Url
-    }
-  deriving Show
-
-instance A.ToJSON Note where
-  toJSON note =
-    A.object $
-        [ "@context" A..=
-          ( "https://www.w3.org/ns/activitystreams" :: String
-          )
-        , "id" A..= note.id
-        , "type" A..= ("Note" :: String)
-        , "summary" A..= (Nothing :: Maybe String)
-        , "inReplyTo" A..= note.inReplyTo
-        , "published" A..= note.published
-        , "attributedTo" A..= note.actor
-        , "content" A..= note.content
-        , "name" A..= note.name
-        , "replies" A..= note.replies
-        , "sensitive" A..= False
-        , "tag" A..= ([] :: [String])
-
-        , "to" A..= [
-            "https://www.w3.org/ns/activitystreams#Public" :: String
-          ]
-        , "cc" A..= [
-            note.actor <> "/followers" :: String
-          ]
-        , "likes" A..=
-          ( Collection
-            { id = note.id <> "/likes"
-            , summary = "likes"
-            , items = []
-            , first = Nothing
-            , last = Nothing
-            } :: Collection Unordered Activity
-          )
-        , "shares" A..= (Nothing :: Maybe String)
-        ]
-        <> [ "name" A..= name | Just name <- [note.name] ]
-        <> [ "url" A..= url | Just url <- [note.url] ]
-
-instance A.ToJSON Object where
-  toJSON = \case
-    NoteObject note -> A.toJSON note
-
-instance A.ToJSON Activity where
-  toJSON = \case
-    create@Create{} ->
-      A.object
-        [ "@context" A..=
-          ( "https://www.w3.org/ns/activitystreams" :: String
-          )
-        , "type" A..= ("Create" :: String)
-        , "id" A..= create.id
-        , "actor" A..= create.actor
-        , "object" A..= create.object
-        ]
-
-instance A.ToJSON a => A.ToJSON (Collection Ordered a) where
-  toJSON collection =
-    A.object
-      [ "@context" A..=
-        ( "https://www.w3.org/ns/activitystreams" :: String
-        )
-      , "id" A..= collection.id
-      , "type" A..= ("OrderedCollection" :: String)
-      , "summary" A..= collection.summary
-      , "totalItems" A..= length collection.items
-      , "orderedItems" A..= collection.items
-      , "first" A..= collection.first
-      , "last" A..= collection.last
-      ]
-
-instance A.ToJSON a => A.ToJSON (Collection Unordered a) where
-  toJSON collection =
-    A.object
-      [ "@context" A..=
-        ( "https://www.w3.org/ns/activitystreams" :: String
-        )
-      , "id" A..= collection.id
-      , "type" A..= ("Collection" :: String)
-      , "summary" A..= collection.summary
-      , "totalItems" A..= length collection.items
-      , "items" A..= collection.items
-      , "first" A..= collection.first
-      , "last" A..= collection.last
-      ]
-
-instance A.ToJSON a => A.ToJSON (OrderedCollectionPage a) where
-  toJSON collection =
-    A.object
-      [ "@context" A..=
-        [ "https://www.w3.org/ns/activitystreams" :: String
-        ]
-      , "type" A..= ("OrderedCollectionPage" :: String)
-      , "partOf" A..= collection.partOf
-      , "orderedItems" A..= collection.orderedItems
-      ]

src/Fedi/Actor.hs

@@ -1,80 +0,0 @@
-module Fedi.Actor where
-
-import Data.Aeson qualified as A
-import Fedi.Types
-
-data Actor
-  = Actor
-    { id :: Url
-    , name :: String
-    , preferredUsername :: String
-    , summary :: String
-    , icon :: Url
-    , publicKey :: PublicKey
-    }
-  deriving Show
-
-type ActorId = Url
-
-data ActorType
-  = Person
-  deriving Show
-
-data PublicKey
-  = PublicKey
-    { id :: Url
-    , owner :: Url
-    , publicKeyPem :: Pem
-    }
-  deriving Show
-
-makeActor :: UserDetails -> Actor
-makeActor details =
-  let
-    actor = actorUrl details
-  in Actor
-    { id = actor
-    , name = details.name
-    , preferredUsername = details.username
-    , summary = details.summary
-    , icon = details.icon
-    , publicKey =
-      PublicKey
-        { id = actor <> "#main-key"
-        , owner = actor
-        , publicKeyPem = details.publicPem
-        }
-    }
-
-instance A.ToJSON Actor where
-  toJSON actor =
-    A.object
-      [ "@context" A..=
-        [ "https://www.w3.org/ns/activitystreams" :: String
-        , "https://w3id.org/security/v1"
-        ]
-      , "id" A..= actor.id
-      , "type" A..= Person
-      , "name" A..= actor.name
-      , "preferredUsername" A..= actor.preferredUsername
-      , "summary" A..= actor.summary
-      , "icon" A..= A.object
-        [ "type" A..= ("Image" :: String)
-        , "mediaType" A..= ("image/png" :: String)
-        , "url" A..= actor.icon
-        ]
-      , "inbox" A..= (actor.id <> "/inbox")
-      , "outbox" A..= (actor.id <> "/outbox")
-      , "publicKey" A..= actor.publicKey
-      ]
-
-instance A.ToJSON ActorType where
-  toJSON Person = A.String "Person"
-
-instance A.ToJSON PublicKey where
-  toJSON pk =
-    A.object
-      [ "id" A..= pk.id
-      , "owner" A..= pk.owner
-      , "publicKeyPem" A..= pk.publicKeyPem
-      ]

src/Fedi/Helpers.hs

@@ -0,0 +1,153 @@
+module Fedi.Helpers where
+
+import Data.Text qualified as T
+import Fedi.Types
+import Fedi.UserDetails
+
+-- | An empty activitypub Object.
+emptyObject :: Object ()
+emptyObject =
+  Object
+    { id = Nothing
+    , otype = ()
+    , content = Nothing
+    , published = Nothing
+    , replies = Nothing
+    , attachment = Nothing
+    , attributedTo = Nothing
+    , tag = Nothing
+    , to = Nothing
+    , cc = Nothing
+    , inReplyTo = Nothing
+    , url = Nothing
+    , name = Nothing
+    , icon = Nothing
+    , image = Nothing
+    , preview = Nothing
+    , summary = Nothing
+    , updated = Nothing
+    , mediaType = Nothing
+    }
+
+-- | Create an activitypub Actor.
+makeActor :: UserDetails -> Actor
+makeActor details =
+  let
+    actor = actorUrl details
+  in
+    ActorPerson $
+      emptyObject
+        { id = Just $ ObjectId actor
+        , otype =
+            TypePerson
+              { preferredUsername = details.username
+              , inbox = Link $ actor <> "/inbox"
+              , outbox = Link $ actor <> "/outbox"
+              , following = Link $ actor <> "/following"
+              , followers = Link $ actor <> "/followers"
+              , publicKey =
+                  PublicKey
+                    { pkid = actor <> "#main-key"
+                    , owner = actor
+                    , publicKeyPem = details.publicPem
+                    }
+              }
+        , url = Nothing -- details.url
+        , name = Just $ StringName details.name
+        , icon = Just $ makeImage details.icon
+        , image = Just $ makeImage details.image
+        , summary = Just $ T.pack details.summary
+        }
+
+makeCreateNote :: Note -> Create
+makeCreateNote note =
+  emptyObject
+    { id = (\oid -> ObjectId $ oid.unwrap <> "/create") <$> note.id
+    , otype =
+        TypeActivity
+          { actor = maybe (Link "") getAttributedTo note.attributedTo
+          , atype = TypeCreate note
+          , target = Nothing
+          , origin = Nothing
+          }
+    }
+
+-- | Create an user's empty 'Note'.
+emptyUserNote :: Url -> Note
+emptyUserNote actor =
+  emptyObject
+    { otype = emptyTypeNote
+    , attributedTo = Just (LLink $ Link actor)
+    , to = Just [Link "https://www.w3.org/ns/activitystreams#Public"]
+    , cc = Just [Link $ actor <> "/followers"]
+    }
+
+-- | An empty 'Note'.
+emptyTypeNote :: TypeNote
+emptyTypeNote =
+  TypeNote
+    { likes = emptyUnorderedCollection
+    , shares = emptyUnorderedCollection
+    , replies = emptyUnorderedCollection
+    , sensitive = False
+    }
+
+-- | Create an activitypub Image.
+makeImage :: Url -> Image
+makeImage link =
+  emptyObject
+    { otype = TypeImage
+    , mediaType = Just ("image/png" :: MediaType)
+    , url = Just link
+    }
+
+-- | An empty 'Collection'.
+emptyUnorderedCollection :: Collection a
+emptyUnorderedCollection =
+  emptyObject
+    { otype =
+        CollectionType
+          { ctype =
+              UnorderedCollectionType
+                { items = []
+                }
+          , first = Nothing
+          , last = Nothing
+          , current = Nothing
+          }
+    }
+
+-- | An empty 'OrderedCollection'.
+emptyOrderedCollection :: OrderedCollection a
+emptyOrderedCollection =
+  emptyObject
+    { otype =
+        CollectionType
+          { ctype =
+              OrderedCollectionType
+                { totalItems = 0
+                }
+          , first = Nothing
+          , last = Nothing
+          , current = Nothing
+          }
+    }
+
+-- | Create an empty 'OrderedCollectionPage'.
+emptyOrderedCollectionPage :: Url -> OrderedCollectionPage a
+emptyOrderedCollectionPage url =
+  emptyObject
+    { otype =
+        CollectionType
+          { ctype =
+              OrderedCollectionPageType
+                { partOf = url
+                , prev = Nothing
+                , next = Nothing
+                , orderedItems = []
+                }
+          , first = Nothing
+          , last = Nothing
+          , current = Nothing
+          }
+    }

src/Fedi/Routes.hs

@@ -1,16 +1,14 @@
 module Fedi.Routes where
 
-import Data.List (find)
-import Web.Twain qualified as Twain
-import Web.Twain.Types qualified as Twain
-import Data.String (fromString)
 import Data.Aeson qualified as A
 import Data.ByteString qualified as BS
 import Data.ByteString.Lazy qualified as BSL
+import Fedi.Helpers
 import Fedi.Types
-import Fedi.Activity
+import Fedi.UserDetails
-import Fedi.Actor
 import Fedi.Webfinger
+import Web.Twain qualified as Twain
+import Web.Twain.Types qualified as Twain
 
 -- * Routes
 
@@ -18,17 +16,16 @@ routes :: UserDetails -> [Twain.Middleware]
 routes details =
   [ Twain.get (matchUser details) do
       handleUser details
-
   , Twain.get (matchOutbox details) do
       handleOutbox details []
-
+  , Twain.get (matchCreateNote details) do
-  , Twain.get (matchCreate details) do
+      handleCreateNote details []
-    handleUser details
-
   , Twain.get (matchNote details) do
-    handleUser details
+      handleNote details []
+  , -- , Twain.post (matchInbox details) do
+    --   handleInbox details undefined
 
-  , Twain.get matchWebfinger do
+    Twain.get matchWebfinger do
       handleWebfinger details
   ]
 
@@ -40,11 +37,11 @@ jsonLD =
 
 -- * Create
 
-matchCreate :: UserDetails -> Twain.PathPattern
+matchCreateNote :: UserDetails -> Twain.PathPattern
-matchCreate details = fromString ("/" <> details.username <> "/notes/:note_id/create")
+matchCreateNote details = fromString ("/" <> details.username <> "/notes/:note_id/create")
 
-handleCreate :: UserDetails -> [Activity] -> Twain.ResponderM a
+handleCreateNote :: UserDetails -> [Create] -> Twain.ResponderM a
-handleCreate details items = do
+handleCreateNote details items = do
   noteId <- Twain.param "note_id"
   let
     createUrl =
@@ -57,7 +54,7 @@ handleCreate details items = do
         <> "/create"
   let
     content =
-      find (\create -> create.id == createUrl) items
+      find (\create -> create.id == Just (ObjectId createUrl)) items
   Twain.send $ jsonLD (A.encode content)
 
 -- * Note
@@ -78,7 +75,7 @@ handleNote details items = do
         <> noteId
   let
     content =
-      find (\note -> note.id == noteUrl) items
+      find (\note -> note.id == Just (ObjectId noteUrl)) items
   Twain.send $ jsonLD (A.encode content)
 
 -- * User
@@ -88,7 +85,8 @@ matchUser details = fromString ("/" <> details.username)
 
 handleUser :: UserDetails -> Twain.ResponderM a
 handleUser details = do
-  let content = makeActor details
+  let
+    content = makeActor details
   Twain.send $ jsonLD (A.encode content)
 
 -- * Webfinger
@@ -99,7 +97,8 @@ matchWebfinger = "/.well-known/webfinger"
 handleWebfinger :: UserDetails -> Twain.ResponderM b
 handleWebfinger details = do
   resource <- Twain.param "resource"
-  let webfinger = makeWebfinger details
+  let
+    webfinger = makeWebfinger details
   if resource == ppSubject webfinger.subject
     then do
       Twain.send $ jsonLD (A.encode webfinger)
@@ -112,7 +111,7 @@ matchOutbox :: UserDetails -> Twain.PathPattern
 matchOutbox details =
   fromString ("/" <> details.username <> "/outbox")
 
-handleOutbox :: UserDetails -> [Activity] -> Twain.ResponderM b
+handleOutbox :: UserDetails -> [AnyActivity] -> Twain.ResponderM b
 handleOutbox details items = do
   isPage <- Twain.queryParamMaybe "page"
   let
@@ -126,28 +125,56 @@ handleOutbox details items = do
       case isPage of
         Just True ->
           let
+            empty = emptyOrderedCollectionPage outboxUrl
             content :: OutboxPage
             content =
-              OrderedCollectionPage
+              empty
-                { id = outboxUrl <> "?page=true"
+                { id = Just $ ObjectId $ outboxUrl <> "?page=true"
-                , partOf = outboxUrl
+                , otype =
+                    empty.otype
+                      { ctype =
+                          empty.otype.ctype
+                            { partOf = outboxUrl
                             , orderedItems = items
                             }
-          in A.encode content
+                      }
+                }
+          in
+            A.encode content
         _ ->
           let
             content :: Outbox
             content =
-              Collection
+              emptyOrderedCollection
-                { id = outboxUrl
+                { id = Just $ ObjectId outboxUrl
-                , summary = details.username <> "'s notes"
+                , summary = Just $ fromString $ details.username <> "'s notes"
-                , items = items
+                , otype =
+                    emptyOrderedCollection.otype
+                      { ctype =
+                          emptyOrderedCollection.otype.ctype
+                            { totalItems = fromIntegral $ length items
+                            }
                       , first = Just $ outboxUrl <> "?page=true"
                       , last = Just $ outboxUrl <> "?page=true"
                       }
-          in A.encode content
+                }
+          in
+            A.encode content
   Twain.send $ jsonLD response
 
+-- * Inbox
+
+-- matchInbox :: UserDetails -> Twain.PathPattern
+-- matchInbox details =
+--   fromString ("/" <> details.username <> "/inbox")
+--
+-- handleInbox :: UserDetails -> (Activity -> Twain.ResponderM b) -> Twain.ResponderM b
+-- handleInbox _details _handle = do
+--   let response = undefined
+--   Twain.send $ jsonLD response
+
+-- * Other stuff
+
 checkContentTypeAccept :: Twain.Request -> Bool
 checkContentTypeAccept request =
   case lookup Twain.hAccept request.requestHeaders of

src/Fedi/Types.hs

@@ -1,48 +1,380 @@
 module Fedi.Types where
 
-import GHC.Generics (Generic)
 import Data.Aeson qualified as A
+import Data.Aeson.Types qualified as A
 import Data.Text qualified as T
+import Fedi.UserDetails
 
-data Rel = Self
+-- | An Object is what everything is here.
-  deriving Show
+-- <https://www.w3.org/TR/activitystreams-vocabulary/#object-types>
-
+data Object typ
-instance A.ToJSON Rel where
+  = Object
-  toJSON Self = A.String "self"
+  { id :: Maybe ObjectId
-
+  , otype :: typ
-
+  , content :: Maybe Content
-data LinkType = ActivityJson
+  , published :: Maybe UTCTime
-  deriving Show
+  , replies :: Maybe [Link]
-
+  , attachment :: Maybe [AnyMedia]
-instance A.ToJSON LinkType where
+  , attributedTo :: Maybe (LinkOrObject Actor)
-  toJSON ActivityJson = A.String "application/activity+json"
+  , -- , audience :: Maybe String
-
+    tag :: Maybe [Tag]
-type Url = String
+  , to :: Maybe [Link]
-type Domain = String
+  , cc :: Maybe [Link]
-type Username = String
+  , inReplyTo :: Maybe (LinkOrObject Actor)
-
+  , url :: Maybe Url -- revisit
-newtype Pem = Pem T.Text
+  , name :: Maybe Name
-  deriving Show
+  , icon :: Maybe Image
-  deriving A.FromJSON via T.Text
+  , image :: Maybe Image
-
+  , preview :: Maybe Preview
-instance A.ToJSON Pem where
+  , summary :: Maybe T.Text
-  toJSON (Pem pem) = A.String pem
+  , updated :: Maybe UTCTime
-
+  , -- , bto :: Maybe String
-data UserDetails
+    -- , bcc :: Maybe String
-  = UserDetails
+    mediaType :: Maybe MediaType
-    { domain :: Domain
+    -- , duration  :: Maybe String
-    , username :: String
-    , name :: String
-    , summary :: String
-    , icon :: Url
-    , publicPem :: Pem
-    , privatePem :: FilePath
   }
-  deriving (Show, Generic, A.FromJSON)
+  deriving (Show)
 
-actorUrl :: UserDetails -> Url
+class ToObject a where
-actorUrl details =
+  toObject :: a -> [A.Pair]
-  "https://" <> details.domain <> "/" <> details.username
 
-fullmention :: UserDetails -> String
+instance (ToObject a) => A.ToJSON (Object a) where
-fullmention details = "@" <> details.username <> "@" <> details.domain
+  toJSON = A.object . toObject
+
+instance (ToObject a) => ToObject (Object a) where
+  toObject object =
+    [ "@context"
+        A..= ("https://www.w3.org/ns/activitystreams" :: String)
+    ]
+      <> toObject object.otype
+      <> [ assignment
+         | Just assignment <-
+            [ fmap ("id" A..=) object.id
+            , fmap ("content" A..=) object.content
+            , fmap ("attachement" A..=) object.attachment
+            , fmap ("attributedTo" A..=) object.attributedTo
+            , fmap ("published" A..=) object.published
+            , fmap ("inReplyTo" A..=) object.inReplyTo
+            , fmap ("url" A..=) object.url
+            , fmap ("name" A..=) object.name
+            , fmap ("icon" A..=) object.icon
+            , fmap ("image" A..=) object.image
+            , -- , fmap ("preview" A..=  ) object.preview
+              fmap ("summary" A..=) object.summary
+            , fmap ("updated" A..=) object.updated
+            , fmap ("mediaType" A..=) object.mediaType
+            , fmap ("to" A..=) object.to
+            , fmap ("cc" A..=) object.cc
+            , fmap ("replies" A..=) object.replies
+            ]
+         ]
+
+newtype ObjectId = ObjectId {unwrap :: String}
+  deriving (Show, Eq, A.FromJSON, A.ToJSON) via String
+
+newtype Link = Link {unwrap :: Url}
+  deriving (Show, A.FromJSON, A.ToJSON) via Url
+
+data LinkOrObject a
+  = LLink Link
+  | OObject (Object a)
+  | CCollection [LinkOrObject a]
+  deriving (Show)
+
+getAttributedTo :: LinkOrObject a -> Link
+getAttributedTo = \case
+  LLink link -> link
+  OObject obj -> Link (maybe (ObjectId "") id obj.id).unwrap
+  CCollection list ->
+    maybe (Link "") getAttributedTo (listToMaybe list)
+
+instance (ToObject o) => A.ToJSON (LinkOrObject o) where
+  toJSON = \case
+    LLink link -> A.toJSON link
+    OObject ob -> A.toJSON ob
+    CCollection loos -> A.toJSON loos
+
+data AnyMedia
+  = ImageMedia Image
+  deriving (Show)
+
+instance A.ToJSON AnyMedia where
+  toJSON = \case
+    ImageMedia obj -> A.toJSON obj
+
+type Image = Object TypeImage
+
+data TypeImage = TypeImage deriving (Show)
+
+instance ToObject TypeImage where
+  toObject TypeImage =
+    ["type" A..= ("Image" :: String)]
+
+data Name
+  = StringName String
+  | ObjectName (LinkOrObject Actor)
+  deriving (Show)
+
+instance A.ToJSON Name where
+  toJSON = \case
+    StringName str -> A.toJSON str
+    ObjectName loo -> A.toJSON loo
+
+type Content = T.Text
+
+type MediaType = String
+
+-- | A Note is an object that has the type 'Note'.
+type Note = Object TypeNote
+
+data TypeNote
+  = TypeNote
+  { likes :: Collection Like
+  , shares :: Collection Share
+  , replies :: Collection Note
+  , sensitive :: Bool
+  }
+  deriving (Show)
+
+instance ToObject TypeNote where
+  toObject note =
+    [ "type" A..= ("Note" :: String)
+    , "likes" A..= note.likes
+    , "shares" A..= note.shares
+    , "sensitive" A..= note.sensitive
+    ]
+
+type Tag = Object TypeTag
+
+data TypeTag
+  = TypeTag
+  { href :: Url
+  }
+  deriving (Show)
+
+type Preview = Object TypePreview
+
+data TypePreview = TypePreview
+  deriving (Show)
+
+type Share = Object TypeShare
+
+data TypeShare = TypeShare deriving (Show)
+
+instance ToObject TypeShare where
+  toObject TypeShare =
+    [ "type" A..= ("Share" :: String)
+    ]
+
+-- * Activities
+
+-- | An Activity is a superset of an Object with one of the following types,
+-- <https://www.w3.org/TR/activitystreams-vocabulary/#activity-types>
+-- and some additional fields.
+type Activity t = Object (TypeActivity t)
+
+data TypeActivity t
+  = TypeActivity
+  { actor :: Link
+  , atype :: t
+  , target :: Maybe AnyActivity
+  , origin :: Maybe AnyActivity
+  -- , result :: Maybe String
+  -- , instrument :: Maybe String
+  }
+  deriving (Show)
+
+instance (ToObject t) => ToObject (TypeActivity t) where
+  toObject activity =
+    [ "actor" A..= activity.actor
+    ]
+      <> [ pair
+         | Just pair <-
+            [ fmap ("target" A..=) activity.target
+            , fmap ("origin" A..=) activity.origin
+            ]
+         ]
+      <> toObject activity.atype
+
+-- type Announce = Object (TypeActivity TypeAnnounce)
+-- data TypeAnnounce = TypeAnnounce deriving Show
+-- instance ToObject TypeAnnounce where
+--   toObject TypeAnnounce =
+--     [ "type" A..= ("Announce" :: String)
+--     ]
+
+type Create = Activity TypeCreate
+
+data TypeCreate
+  = TypeCreate
+  { object :: Note
+  }
+  deriving (Show)
+
+instance ToObject TypeCreate where
+  toObject create =
+    [ "type" A..= ("Create" :: String)
+    , "object" A..= create.object
+    ]
+
+-- type Follow = Object (TypeActivity TypeFollow)
+-- data TypeFollow = TypeFollow deriving Show
+-- instance ToObject TypeFollow where
+--   toObject TypeFollow =
+--     [ "type" A..= ("Follow" :: String)
+--     ]
+--
+type Like = Object (TypeActivity TypeLike)
+
+data TypeLike = TypeLike deriving (Show)
+
+instance ToObject TypeLike where
+  toObject TypeLike =
+    [ "type" A..= ("Like" :: String)
+    ]
+
+data AnyActivity
+  = -- ActivityAnnounce Announce
+    ActivityCreate Create
+  --  | ActivityFollow Follow
+  --  | ActivityLike Like
+  deriving (Show)
+
+instance A.ToJSON AnyActivity where
+  toJSON = \case
+    --    ActivityAnnounce obj -> A.toJSON obj
+    ActivityCreate obj -> A.toJSON obj
+
+--    ActivityFollow obj -> A.toJSON obj
+--    ActivityLike obj -> A.toJSON obj
+
+-- * Actors
+
+-- | An Actor is an object that has one of the following types.
+-- <https://www.w3.org/TR/activitystreams-vocabulary/#actor-types>
+data Actor = ActorPerson Person deriving (Show)
+
+instance A.ToJSON Actor where
+  toJSON = \case
+    ActorPerson obj -> A.toJSON obj
+
+instance ToObject Actor where
+  toObject = \case
+    ActorPerson obj -> toObject obj
+
+-- | A Person is an object that has the type 'Person'.
+type Person = Object TypePerson
+
+data TypePerson
+  = TypePerson
+  { preferredUsername :: String
+  , publicKey :: PublicKey
+  , inbox :: Link
+  , outbox :: Link
+  , following :: Link
+  , followers :: Link
+  }
+  deriving (Show)
+
+instance ToObject TypePerson where
+  toObject person =
+    [ "type" A..= ("Person" :: String)
+    , "preferredUsername" A..= person.preferredUsername
+    , "publicKey" A..= person.publicKey
+    , "inbox" A..= person.inbox
+    , "outbox" A..= person.outbox
+    , "following" A..= person.following
+    , "followers" A..= person.followers
+    ]
+
+data PublicKey
+  = PublicKey
+  { pkid :: Url
+  , owner :: Url
+  , publicKeyPem :: Pem
+  }
+  deriving (Show)
+
+instance A.ToJSON PublicKey where
+  toJSON pk =
+    A.object
+      [ "id" A..= pk.pkid
+      , "owner" A..= pk.owner
+      , "publicKeyPem" A..= pk.publicKeyPem
+      ]
+
+-- * Collections
+
+type Collection e = Object (CollectionType (Unordered e))
+
+type OrderedCollection e = Object (CollectionType (Ordered e))
+
+type OrderedCollectionPage e = Object (CollectionType (OrderedPage e))
+
+type Outbox = OrderedCollection AnyActivity
+
+type OutboxPage = OrderedCollectionPage AnyActivity
+
+data CollectionType t
+  = CollectionType
+  { ctype :: t
+  , first :: Maybe Url
+  , last :: Maybe Url
+  , current :: Maybe Url
+  }
+  deriving (Show)
+
+instance (ToObject t) => ToObject (CollectionType t) where
+  toObject collection =
+    toObject collection.ctype
+      <> [ pair
+         | Just pair <-
+            [ fmap ("first" A..=) collection.first
+            , fmap ("last" A..=) collection.last
+            , fmap ("current" A..=) collection.current
+            ]
+         ]
+
+data Unordered e
+  = UnorderedCollectionType
+  { items :: [e]
+  }
+  deriving (Show)
+
+instance (A.ToJSON e) => ToObject (Unordered e) where
+  toObject collection =
+    [ "type" A..= ("Collection" :: String)
+    , "totalItems" A..= length collection.items
+    , "items" A..= collection.items
+    ]
+
+data Ordered e
+  = OrderedCollectionType
+  { totalItems :: Integer
+  }
+  deriving (Show)
+
+instance (A.ToJSON e) => ToObject (Ordered e) where
+  toObject collection =
+    [ "type" A..= ("OrderedCollection" :: String)
+    , "totalItems" A..= collection.totalItems
+    ]
+
+data OrderedPage e
+  = OrderedCollectionPageType
+  { partOf :: Url
+  , prev :: Maybe Url
+  , next :: Maybe Url
+  , orderedItems :: [e]
+  }
+  deriving (Show)
+
+instance (A.ToJSON e) => ToObject (OrderedPage e) where
+  toObject page =
+    [ "type" A..= ("OrderedCollectionPage" :: String)
+    , "totalItems" A..= length page.orderedItems
+    , "orderedItems" A..= page.orderedItems
+    , "partOf" A..= page.partOf
+    , "prev" A..= page.prev
+    , "next" A..= page.next
+    ]

src/Fedi/UserDetails.hs

@@ -0,0 +1,46 @@
+module Fedi.UserDetails (
+  module Fedi.UserDetails,
+  module Export,
+) where
+
+import Data.Aeson qualified as A
+import Data.List as Export (find)
+import Data.Maybe as Export (fromMaybe, listToMaybe, maybeToList)
+import Data.String as Export (fromString)
+import Data.Text as Export (Text)
+import Data.Text qualified as T
+import Data.Time as Export (UTCTime)
+import GHC.Generics as Export (Generic)
+
+type Url = String
+
+type Domain = String
+
+type Username = String
+
+newtype Pem = Pem T.Text
+  deriving (Show)
+  deriving (A.FromJSON) via T.Text
+
+instance A.ToJSON Pem where
+  toJSON (Pem pem) = A.String pem
+
+data UserDetails
+  = UserDetails
+  { domain :: Domain
+  , username :: String
+  , name :: String
+  , summary :: String
+  , icon :: Url
+  , image :: Url
+  , publicPem :: Pem
+  , privatePem :: FilePath
+  }
+  deriving (Show, Generic, A.FromJSON)
+
+actorUrl :: UserDetails -> Url
+actorUrl details =
+  "https://" <> details.domain <> "/" <> details.username
+
+fullmention :: UserDetails -> String
+fullmention details = "@" <> details.username <> "@" <> details.domain

src/Fedi/Webfinger.hs

@@ -1,34 +1,38 @@
 module Fedi.Webfinger where
 
-import Data.String (fromString)
 import Data.Aeson qualified as A
-import Fedi.Types
+import Fedi.UserDetails
 
 data Webfinger
   = Webfinger
   { subject :: Subject
-    , links :: [Link]
+  , links :: [WfLink]
   }
-  deriving Show
+  deriving (Show)
 
 data Subject
   = Subject
   { username :: Username
   , domain :: Domain
   }
-  deriving Show
+  deriving (Show)
 
 ppSubject :: Subject -> String
 ppSubject subject =
   "acct:" <> subject.username <> "@" <> subject.domain
 
-data Link
+data WfLink
-  = Link
+  = WfLink
-    { rel :: Rel
+  { type_ :: WfLinkType
-    , type_ :: LinkType
   , href :: Url
   }
-  deriving Show
+  deriving (Show)
+
+data WfLinkType = ActivityJson
+  deriving (Show)
+
+instance A.ToJSON WfLinkType where
+  toJSON ActivityJson = A.String "application/activity+json"
 
 makeWebfinger :: UserDetails -> Webfinger
 makeWebfinger details =
@@ -36,20 +40,21 @@ makeWebfinger details =
     url = "https://" <> details.domain
   in
     Webfinger
-      { subject = Subject
+      { subject =
+          Subject
             { username = details.username
             , domain = details.domain
             }
       , links =
-        [ Link
+          [ WfLink
-          { rel = Self
+              { type_ = ActivityJson
-          , type_ = ActivityJson
               , href = url <> "/" <> details.username
               }
           ]
       }
 
 -- * -------------------------
+
 ---
 
 instance A.ToJSON Webfinger where
@@ -63,10 +68,10 @@ instance A.ToJSON Subject where
   toJSON subject =
     fromString $ ppSubject subject
 
-instance A.ToJSON Link where
+instance A.ToJSON WfLink where
   toJSON link =
     A.object
-      [ "rel" A..= link.rel
+      [ "rel" A..= ("self" :: String)
       , "type" A..= link.type_
       , "href" A..= link.href
       ]