app/Css.hs

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

app/DB.hs

@@ -1,56 +1,49 @@
 -- | Database interaction
 module DB where
 
+import GHC.Stack (HasCallStack)
 import Data.Text qualified as T
 import Database.Sqlite.Easy qualified as DB
-import Fedi
-import GHC.Stack (HasCallStack)
 import Text.RawString.QQ
+import Fedi
 
 -----------------------
-
 -- * Database handler API
 
 data DB
   = DB
-  { getNotes :: IO [Note]
+    { getNotes :: IO [Note]
-  , getNote :: DB.Int64 -> IO (Maybe Note)
+    , insertNote :: NoteEntry -> IO NoteId
-  , insertNote :: NoteEntry -> IO ObjectId
+    }
-  }
 
 -- * Data types
 
 data NoteEntry
   = NoteEntry
-  { inReplyTo :: Maybe Url
+    { inReplyTo :: Maybe Url
-  , content :: T.Text
+    , content :: T.Text
-  , name :: Maybe String
+    , name :: Maybe String
-  , url :: Maybe Url
+    , url :: Maybe Url
-  }
+    }
 
 -----------------------
-
 -- * Handler smart constructor
 
 mkDB :: DB.ConnectionString -> UserDetails -> IO DB
 mkDB connstr details = do
   pool <- DB.createSqlitePool connstr
   DB.withPool pool runMigrations
-  pure
+  pure DB
-    DB
+    { getNotes =
-      { getNotes =
+      DB.withPool pool (getNotesFromDb $ actorUrl details)
-          DB.withPool pool (getNotesFromDb $ actorUrl details)
+    , insertNote =
-      , getNote =
+      \note -> DB.withPool pool (insertNoteToDb (actorUrl details) note)
-          \noteid -> DB.withPool pool (getNoteFromDb noteid $ actorUrl details)
+    }
-      , insertNote =
-          \note -> DB.withPool pool (insertNoteToDb (actorUrl details) note)
-      }
 
 -----------------------
-
 -- * Database migrations
 
-runMigrations :: (HasCallStack) => DB.SQLite ()
+runMigrations :: HasCallStack => DB.SQLite ()
 runMigrations = DB.migrate migrations migrateUp migrateDown
 
 migrations :: [DB.MigrationName]
@@ -58,12 +51,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(
-        [r| create table note(
           id integer primary key autoincrement,
           published datetime default (datetime('now')),
           actor text not null,
@@ -75,9 +67,10 @@ 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"
@@ -85,19 +78,13 @@ migrateDown = \case
   name -> error $ "unexpected migration: " <> show name
 
 -----------------------
-
 -- * Database actions
 
 getNotesFromDb :: Url -> DB.SQLite [Note]
 getNotesFromDb url =
   map decodeNoteRow <$> uncurry DB.runWith (getNotesSQL url)
 
-getNoteFromDb :: DB.Int64 -> Url -> DB.SQLite (Maybe Note)
+insertNoteToDb :: Url -> NoteEntry -> DB.SQLite NoteId
-getNoteFromDb noteid url = do
-  n <- map decodeNoteRow <$> uncurry DB.runWith (getNoteSQL noteid url)
-  pure (listToMaybe n)
-
-insertNoteToDb :: Url -> NoteEntry -> DB.SQLite ObjectId
 insertNoteToDb actor note = do
   [n] <- map decodeNoteIdRow <$> uncurry DB.runWith (insertNoteSQL actor note)
   pure n
@@ -116,30 +103,11 @@ getNotesSQL url =
         inReplyTo,
         url
       FROM note
-      WHERE inReplyTo IS NULL
       ORDER BY published DESC
     |]
   , [DB.SQLText $ T.pack url]
   )
 
-getNoteSQL :: DB.Int64 -> Url -> (DB.SQL, [DB.SQLData])
-getNoteSQL noteid url =
-  ( [r|
-      SELECT
-        ? || '/notes/' || id,
-        published,
-        actor,
-        content,
-        name,
-        inReplyTo,
-        url
-      FROM note
-      WHERE note.id = ?
-      ORDER BY published DESC
-    |]
-  , [DB.SQLText $ T.pack url, DB.SQLInteger noteid]
-  )
-
 insertNoteSQL :: Url -> NoteEntry -> (DB.SQL, [DB.SQLData])
 insertNoteSQL actor note =
   ( [r|
@@ -147,8 +115,7 @@ 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
@@ -157,47 +124,39 @@ 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
     ] ->
-      let
+      Note
-        emptyNote = emptyUserNote $ T.unpack actor
+        { id = T.unpack noteid
-      in
+        , published = read (T.unpack published)
-        emptyNote
+        , actor = T.unpack actor
-          { id = Just $ ObjectId $ T.unpack noteid
+        , inReplyTo = inReplyTo
-          , published = Just $ read (T.unpack published)
+        , content = content
-          , attributedTo = Just $ LLink $ Link $ T.unpack actor
+        , url = url
-          , inReplyTo = LLink . Link <$> inReplyTo
+        , name = name
-          , content = Just content
+        , replies = Collection
-          , url = url
+          { id = T.unpack noteid <> "/replies"
-          , name = StringName <$> name
+          , summary = "Replies"
-          , otype =
+          , items = []
-              emptyNote.otype
+          , first = Nothing
-                { likes =
+          , last = Nothing
-                    emptyNote.otype.likes
-                      { id = Just $ ObjectId $ T.unpack noteid <> "/likes"
-                      }
-                , shares =
-                    emptyNote.otype.shares
-                      { id = Just $ ObjectId $ T.unpack noteid <> "/shares"
-                      }
-                }
           }
+        }
   row -> error $ "Couldn't decode row as Note: " <> show row
 
-decodeNoteIdRow :: [DB.SQLData] -> ObjectId
+decodeNoteIdRow :: [DB.SQLData] -> NoteId
 decodeNoteIdRow = \case
-  [DB.SQLText noteid] -> ObjectId $ T.unpack noteid
+  [ DB.SQLText noteid] -> 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,13 @@
 module Html where
 
-import Css (css)
-import Data.Char (isAlpha, ord)
 import Data.String (fromString)
+import Data.Char (ord, isAlpha)
 import Data.Text qualified as T
-import Fedi qualified as Fedi
 import Lucid qualified as H
 
+import Fedi qualified as Fedi
+import Css (css)
+
 -- * HTML
 
 type Html = H.Html ()
@@ -14,69 +15,69 @@ type Html = H.Html ()
 adminPage :: Fedi.UserDetails -> [Fedi.Note] -> Html
 adminPage details notes =
   template (T.pack $ Fedi.fullmention details) do
-    userHtml details
+  userHtml details
-    newNoteHtml details
+  newNoteHtml details
-    notesHtml notes
+  notesHtml notes
 
 actorPage :: Fedi.UserDetails -> [Fedi.Note] -> Html
 actorPage details notes =
   template (T.pack $ Fedi.fullmention details) do
-    userHtml details
+  userHtml details
-    notesHtml notes
+  notesHtml notes
 
 -- | HTML boilerplate template
 template :: T.Text -> Html -> Html
 template title content =
   H.doctypehtml_ $ do
     H.head_ $ do
-      H.meta_ [H.charset_ "utf-8"]
+      H.meta_ [ H.charset_ "utf-8" ]
-      H.meta_ [H.name_ "viewport", H.content_ "width=device-width initial_scale=1.0"]
+      H.meta_ [ H.name_ "viewport", H.content_ "width=device-width initial_scale=1.0" ]
       H.title_ (H.toHtml $ "Fediserve - " <> title)
       H.style_ css
     H.body_ $ do
-      H.div_ [H.class_ "main"] $ do
+      H.div_ [ H.class_ "main" ] $ do
         content
       H.footer_ ""
 
 userHtml :: Fedi.UserDetails -> Html
 userHtml details = do
-  H.div_ [H.class_ "user-details"] do
+  H.div_ [ H.class_ "user-details" ] do
-    H.a_ [H.href_ (T.pack $ "/" <> details.username)] $
+    H.a_ [ H.href_ (T.pack $ "/" <> details.username) ] $
-      H.img_ [H.class_ "avatar", H.src_ (T.pack details.icon)]
+      H.img_ [ H.class_ "avatar", H.src_ (T.pack details.icon) ]
-    H.div_ [H.class_ "user-details-details"] do
+    H.div_ [ H.class_ "user-details-details" ] do
       H.h2_ (fromString details.username)
-      H.a_ [H.href_ (T.pack $ Fedi.actorUrl details)] $
+      H.a_ [ H.href_ (T.pack $ Fedi.actorUrl details) ] $
         H.p_ (fromString $ Fedi.fullmention details)
       H.p_ (fromString details.summary)
 
 notesHtml :: [Fedi.Note] -> Html
 notesHtml notes = do
-  H.div_ [H.class_ "notes"] $ mapM_ noteHtml notes
+  H.div_ [ H.class_ "notes" ] $ mapM_ noteHtml notes
 
 -- | A single post as HTML.
 noteHtml :: Fedi.Note -> Html
 noteHtml note = do
-  H.div_ [H.class_ "note"] $ do
+  H.div_ [ H.class_ "note" ] $ do
-    H.div_ [H.class_ "note-header"] $ do
+    H.div_ [ H.class_ "note-header" ] $ do
       case note.name of
-        Just (Fedi.StringName title) ->
+        Just title ->
-          H.h2_ [H.class_ (checkDirection $ T.pack title)] (fromString title)
+          H.h2_ [ H.class_ (checkDirection $ T.pack title) ] (fromString title)
-        _ -> pure ()
+        Nothing -> pure ()
 
       case note.url of
         Just url ->
-          H.p_ $ H.a_ [H.href_ (T.pack url)] $ fromString url
+          H.p_ $ H.a_ [ H.href_ (T.pack url) ] $ fromString url
         Nothing -> pure ()
 
       H.a_
-        [ H.href_ (T.pack (maybe "" (\i -> i.unwrap) note.id))
+        [ H.href_ (T.pack 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 (maybe "" id note.content)] $ do
+    H.div_ [H.class_ $ "note-content " <> checkDirection note.content] $ do
-      H.toHtmlRaw (maybe "" id note.content)
+      H.toHtmlRaw note.content
 
 checkDirection :: T.Text -> T.Text
 checkDirection txt =
@@ -94,36 +95,31 @@ newNoteHtml details = do
     , H.class_ "new-note"
     ]
     ( do
-        H.div_ [H.class_ "new-note-div"] $
+      H.div_ [ H.class_ "new-note-div" ] $ H.input_
-          H.input_
+        [ H.class_ "new-note-text"
-            [ H.class_ "new-note-text"
+        , H.autofocus_
-            , H.autofocus_
+        , H.type_ "text"
-            , H.type_ "text"
+        , H.name_ "title"
-            , H.name_ "title"
+        , H.placeholder_ "A title (optional)"
-            , H.placeholder_ "A title (optional)"
+        ]
-            ]
 
-        H.div_ [H.class_ "new-note-div"] $
+      H.div_ [ H.class_ "new-note-div" ] $ H.textarea_
-          H.textarea_
+        [ H.class_ "new-note-content"
-            [ H.class_ "new-note-content"
+        , H.name_ "content"
-            , H.name_ "content"
+        , H.placeholder_ "Yes?"
-            , H.placeholder_ "Yes?"
+        ] ""
-            ]
-            ""
 
-        H.div_ [H.class_ "new-note-div"] $
+      H.div_ [ H.class_ "new-note-div" ] $ H.input_
-          H.input_
+        [ H.class_ "new-note-text"
-            [ H.class_ "new-note-text"
+        , H.type_ "url"
-            , H.type_ "url"
+        , H.name_ "url"
-            , H.name_ "url"
+        , H.placeholder_ "A URL this note should link to (optional)"
-            , H.placeholder_ "A URL this note should link to (optional)"
+        ]
-            ]
 
-        H.div_ [H.class_ "new-note-div"] $
+      H.div_ [ H.class_ "new-note-div" ] $ H.input_
-          H.input_
+        [ H.class_ "new-note-submit"
-            [ H.class_ "new-note-submit"
+        , H.type_ "submit"
-            , H.type_ "submit"
+        , H.title_ "Add a new note"
-            , H.title_ "Add a new note"
+        , H.value_ "Post"
-            , H.value_ "Post"
+        ]
-            ]
     )

app/Main.hs

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

app/Routes.hs

@@ -1,16 +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 Fedi qualified as Fedi
+import Data.Aeson qualified as A
-import Html
-import Lucid qualified as H
-import System.IO.Unsafe (unsafePerformIO)
 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
 
 routes :: DB -> FilePath -> [Twain.Middleware]
 routes db detailsFile =
@@ -25,41 +25,54 @@ 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 (Fedi.ActivityCreate . noteToCreate) <$> liftIO db.getNotes
+      notes <- map noteToCreate <$> liftIO db.getNotes
       Fedi.handleOutbox details notes
+
   , -- Match Create object
-    Twain.get (Fedi.matchCreateNote $ unsafePerformIO $ fetchUserDetails detailsFile) do
+    Twain.get (Fedi.matchCreate $ unsafePerformIO $ fetchUserDetails detailsFile) do
       details <- liftIO $ fetchUserDetails detailsFile
       notes <- map noteToCreate <$> liftIO db.getNotes
 
-      Fedi.handleCreateNote details notes
+      Fedi.handleCreate details notes
+
   , -- Match Note object
     Twain.get (Fedi.matchNote $ unsafePerformIO $ fetchUserDetails detailsFile) do
       details <- liftIO $ fetchUserDetails detailsFile
-      noteId <- Twain.param "note_id"
+      notes <- liftIO db.getNotes
-      mnote <- liftIO $ db.getNote noteId
 
       request <- Twain.request
       if Fedi.checkContentTypeAccept request
         then do
-          Fedi.handleNote details (maybeToList mnote)
+          Fedi.handleNote details notes
         else do
-          case mnote of
+          noteId <- Twain.param "note_id"
-            Nothing -> Twain.next
+          let
-            Just thenote ->
+            noteUrl =
-              Twain.send $ Twain.html $ H.renderBS $ actorPage details [thenote]
+              "https://"
+              <> details.domain
+              <> "/"
+              <> details.username
+              <> "/notes/"
+              <> noteId
+            thenote = filter (\note -> note.id == noteUrl) notes
+
+          Twain.send $ Twain.html $ H.renderBS $ actorPage details thenote
+
   , -- Match webfinger
     Twain.get Fedi.matchWebfinger do
-      details <- liftIO $ fetchUserDetails detailsFile
+    details <- liftIO $ fetchUserDetails detailsFile
-      Fedi.handleWebfinger details
+    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"
@@ -68,16 +81,14 @@ routes db detailsFile =
       details <- liftIO $ fetchUserDetails detailsFile
 
       noteid <-
-        liftIO $
+        liftIO $ db.insertNote NoteEntry
-          db.insertNote
+          { content = content
-            NoteEntry
+          , inReplyTo = Nothing
-              { content = content
+          , name = if trim title == "" then Nothing else Just title
-              , inReplyTo = Nothing
+          , url = if trim url == "" then Nothing else Just url
-              , 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.unwrap))
+      Twain.send $ Twain.redirect302 (fromString ("/" <> details.username <> "/notes/" <> noteid))
   ]
 
 trim :: String -> String
@@ -88,5 +99,11 @@ fetchUserDetails detailsFile =
   A.eitherDecodeFileStrict detailsFile
     <&> either (\err -> error $ "could not read file '" <> detailsFile <> "'.\n" <> err) id
 
-noteToCreate :: Fedi.Note -> Fedi.Create
+noteToCreate :: Fedi.Note -> Fedi.Activity
-noteToCreate note = Fedi.makeCreateNote note
+noteToCreate 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.Helpers
+    Fedi.Activity
+    Fedi.Actor
     Fedi.Routes
     Fedi.Types
-    Fedi.UserDetails
     Fedi.Webfinger
   -- other-modules:
   -- other-extensions:

fourmolu.yaml

@@ -1,16 +0,0 @@
-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.Helpers as Export
+import Fedi.Activity 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

@@ -0,0 +1,168 @@
+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

@@ -0,0 +1,80 @@
+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

@@ -1,153 +0,0 @@
-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,32 +1,35 @@
 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.UserDetails
+import Fedi.Activity
+import Fedi.Actor
 import Fedi.Webfinger
-import Web.Twain qualified as Twain
-import Web.Twain.Types qualified as Twain
 
 -- * Routes
 
 routes :: UserDetails -> [Twain.Middleware]
 routes details =
   [ Twain.get (matchUser details) do
-      handleUser details
+    handleUser details
-  , Twain.get (matchOutbox details) do
-      handleOutbox details []
-  , Twain.get (matchCreateNote details) do
-      handleCreateNote details []
-  , Twain.get (matchNote details) do
-      handleNote details []
-  , -- , Twain.post (matchInbox details) do
-    --   handleInbox details undefined
 
-    Twain.get matchWebfinger do
+  , Twain.get (matchOutbox details) do
-      handleWebfinger details
+    handleOutbox details []
+
+  , Twain.get (matchCreate details) do
+    handleUser details
+
+  , Twain.get (matchNote details) do
+    handleUser details
+
+  , Twain.get matchWebfinger do
+    handleWebfinger details
   ]
 
 jsonLD :: BSL.ByteString -> Twain.Response
@@ -37,11 +40,11 @@ jsonLD =
 
 -- * Create
 
-matchCreateNote :: UserDetails -> Twain.PathPattern
+matchCreate :: UserDetails -> Twain.PathPattern
-matchCreateNote details = fromString ("/" <> details.username <> "/notes/:note_id/create")
+matchCreate details = fromString ("/" <> details.username <> "/notes/:note_id/create")
 
-handleCreateNote :: UserDetails -> [Create] -> Twain.ResponderM a
+handleCreate :: UserDetails -> [Activity] -> Twain.ResponderM a
-handleCreateNote details items = do
+handleCreate details items = do
   noteId <- Twain.param "note_id"
   let
     createUrl =
@@ -54,7 +57,7 @@ handleCreateNote details items = do
         <> "/create"
   let
     content =
-      find (\create -> create.id == Just (ObjectId createUrl)) items
+      find (\create -> create.id == createUrl) items
   Twain.send $ jsonLD (A.encode content)
 
 -- * Note
@@ -75,7 +78,7 @@ handleNote details items = do
         <> noteId
   let
     content =
-      find (\note -> note.id == Just (ObjectId noteUrl)) items
+      find (\note -> note.id == noteUrl) items
   Twain.send $ jsonLD (A.encode content)
 
 -- * User
@@ -85,8 +88,7 @@ matchUser details = fromString ("/" <> details.username)
 
 handleUser :: UserDetails -> Twain.ResponderM a
 handleUser details = do
-  let
+  let content = makeActor details
-    content = makeActor details
   Twain.send $ jsonLD (A.encode content)
 
 -- * Webfinger
@@ -97,8 +99,7 @@ matchWebfinger = "/.well-known/webfinger"
 handleWebfinger :: UserDetails -> Twain.ResponderM b
 handleWebfinger details = do
   resource <- Twain.param "resource"
-  let
+  let webfinger = makeWebfinger details
-    webfinger = makeWebfinger details
   if resource == ppSubject webfinger.subject
     then do
       Twain.send $ jsonLD (A.encode webfinger)
@@ -111,7 +112,7 @@ matchOutbox :: UserDetails -> Twain.PathPattern
 matchOutbox details =
   fromString ("/" <> details.username <> "/outbox")
 
-handleOutbox :: UserDetails -> [AnyActivity] -> Twain.ResponderM b
+handleOutbox :: UserDetails -> [Activity] -> Twain.ResponderM b
 handleOutbox details items = do
   isPage <- Twain.queryParamMaybe "page"
   let
@@ -125,62 +126,34 @@ handleOutbox details items = do
       case isPage of
         Just True ->
           let
-            empty = emptyOrderedCollectionPage outboxUrl
             content :: OutboxPage
             content =
-              empty
+              OrderedCollectionPage
-                { id = Just $ ObjectId $ outboxUrl <> "?page=true"
+                { id = outboxUrl <> "?page=true"
-                , otype =
+                , partOf = outboxUrl
-                    empty.otype
+                , orderedItems = items
-                      { ctype =
-                          empty.otype.ctype
-                            { partOf = outboxUrl
-                            , orderedItems = items
-                            }
-                      }
                 }
-          in
+          in A.encode content
-            A.encode content
         _ ->
           let
             content :: Outbox
             content =
-              emptyOrderedCollection
+              Collection
-                { id = Just $ ObjectId outboxUrl
+                { id = outboxUrl
-                , summary = Just $ fromString $ details.username <> "'s notes"
+                , summary = details.username <> "'s notes"
-                , otype =
+                , items = items
-                    emptyOrderedCollection.otype
+                , first = Just $ outboxUrl <> "?page=true"
-                      { ctype =
+                , last = Just $ outboxUrl <> "?page=true"
-                          emptyOrderedCollection.otype.ctype
-                            { totalItems = fromIntegral $ length items
-                            }
-                      , first = Just $ outboxUrl <> "?page=true"
-                      , last = Just $ outboxUrl <> "?page=true"
-                      }
                 }
-          in
+          in A.encode content
-            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
     Just bs ->
       ("application/activity+json" `BS.isInfixOf` bs)
-        || ( ("application/activity+json" `BS.isInfixOf` bs)
+      || ( ("application/activity+json" `BS.isInfixOf` bs)
-              && ("profile=\"https://www.w3.org/ns/activitystreams\"" `BS.isInfixOf` bs)
+           && ("profile=\"https://www.w3.org/ns/activitystreams\"" `BS.isInfixOf` bs)
-           )
+         )
     Nothing -> False

src/Fedi/Types.hs

@@ -1,380 +1,48 @@
 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
 
--- | An Object is what everything is here.
+data Rel = Self
--- <https://www.w3.org/TR/activitystreams-vocabulary/#object-types>
+  deriving Show
-data Object typ
-  = Object
-  { id :: Maybe ObjectId
-  , otype :: typ
-  , content :: Maybe Content
-  , published :: Maybe UTCTime
-  , replies :: Maybe [Link]
-  , attachment :: Maybe [AnyMedia]
-  , attributedTo :: Maybe (LinkOrObject Actor)
-  , -- , audience :: Maybe String
-    tag :: Maybe [Tag]
-  , to :: Maybe [Link]
-  , cc :: Maybe [Link]
-  , inReplyTo :: Maybe (LinkOrObject Actor)
-  , url :: Maybe Url -- revisit
-  , name :: Maybe Name
-  , icon :: Maybe Image
-  , image :: Maybe Image
-  , preview :: Maybe Preview
-  , summary :: Maybe T.Text
-  , updated :: Maybe UTCTime
-  , -- , bto :: Maybe String
-    -- , bcc :: Maybe String
-    mediaType :: Maybe MediaType
-    -- , duration  :: Maybe String
-  }
-  deriving (Show)
 
-class ToObject a where
+instance A.ToJSON Rel where
-  toObject :: a -> [A.Pair]
+  toJSON Self = A.String "self"
 
-instance (ToObject a) => A.ToJSON (Object a) where
-  toJSON = A.object . toObject
 
-instance (ToObject a) => ToObject (Object a) where
+data LinkType = ActivityJson
-  toObject object =
+  deriving Show
-    [ "@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}
+instance A.ToJSON LinkType where
-  deriving (Show, Eq, A.FromJSON, A.ToJSON) via String
+  toJSON ActivityJson = A.String "application/activity+json"
 
-newtype Link = Link {unwrap :: Url}
+type Url = String
-  deriving (Show, A.FromJSON, A.ToJSON) via Url
+type Domain = String
+type Username = String
 
-data LinkOrObject a
+newtype Pem = Pem T.Text
-  = LLink Link
+  deriving Show
-  | OObject (Object a)
+  deriving A.FromJSON via T.Text
-  | CCollection [LinkOrObject a]
-  deriving (Show)
 
-getAttributedTo :: LinkOrObject a -> Link
+instance A.ToJSON Pem where
-getAttributedTo = \case
+  toJSON (Pem pem) = A.String pem
-  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
+data UserDetails
-  toJSON = \case
+  = UserDetails
-    LLink link -> A.toJSON link
+    { domain :: Domain
-    OObject ob -> A.toJSON ob
+    , username :: String
-    CCollection loos -> A.toJSON loos
+    , name :: String
+    , summary :: String
+    , icon :: Url
+    , publicPem :: Pem
+    , privatePem :: FilePath
+    }
+  deriving (Show, Generic, A.FromJSON)
 
-data AnyMedia
+actorUrl :: UserDetails -> Url
-  = ImageMedia Image
+actorUrl details =
-  deriving (Show)
+  "https://" <> details.domain <> "/" <> details.username
 
-instance A.ToJSON AnyMedia where
+fullmention :: UserDetails -> String
-  toJSON = \case
+fullmention details = "@" <> details.username <> "@" <> details.domain
-    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

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