Dockerfile

@@ -7,8 +7,8 @@ COPY . /app/
 WORKDIR /app
 
 RUN cabal update
-RUN cabal build exe:fediserve --enable-executable-static
+RUN cabal build exe:fedi --enable-executable-static
-RUN strip `cabal list-bin fediserve`
+RUN strip `cabal list-bin fedi`
 
 FROM scratch AS artifact
-COPY --from=build /app/dist-newstyle/build/x86_64-linux/*/*/x/*/build/*/fediserve .
+COPY --from=build /app/dist-newstyle/build/x86_64-linux/*/*/x/*/build/*/fedi .

app/DB.hs

@@ -8,16 +8,13 @@ module DB (
   DB.Int64,
 ) where
 
-import Data.Aeson qualified as A
 import Control.Monad.IO.Class (liftIO)
 import Data.Text qualified as T
-import Data.Text.Encoding qualified as T
 import Data.Typeable
 import Database.Sqlite.Easy qualified as DB
 import Fedi
 import GHC.Stack (HasCallStack)
 import Text.RawString.QQ
-import Data.ByteString.Lazy qualified as BSL
 
 -----------------------
 
@@ -28,7 +25,6 @@ data DB
   { getNotes :: IO [Note]
   , getNote :: DB.Int64 -> IO (Maybe Note)
   , insertNote :: NoteEntry -> IO (DB.Int64, Note)
-  , insertLike :: LikeEntry -> IO DB.Int64
   , insertFollower
       :: forall a
        . (Typeable a) => FollowerEntry -> (DB.Int64 -> IO a) -> IO a
@@ -66,23 +62,6 @@ data Follower
   }
   deriving (Show)
 
-data LikeEntry
-  = LikeEntry
-  { likeUrl :: Url
-  , likeActorUrl :: Link
-  , likeNoteUrl :: Link
-  }
-  deriving (Show)
-
-data DbLike
-  = DbLike
-  { likeId :: DB.Int64
-  , likeUrl :: ObjectId
-  , likeActorUrl :: Link
-  , likeNoteUrl :: Link
-  }
-  deriving (Show, Fedi.Generic, A.FromJSON)
-
 -----------------------
 
 -- * Handler smart constructor
@@ -99,8 +78,6 @@ mkDB connstr details = do
           \noteid -> DB.withPool pool (getNoteFromDb noteid)
       , insertNote =
           \note -> DB.withPool pool (insertNoteToDb (actorUrl details) note)
-      , insertLike =
-          \like -> DB.withPool pool (insertLikeToDb like)
       , insertFollower =
           \follower handle -> DB.withPool pool $ DB.transaction do
             id' <- insertFollowerToDb follower
@@ -124,7 +101,6 @@ migrations :: [DB.MigrationName]
 migrations =
   [ "note"
   , "follower"
-  , "like"
   ]
 
 migrateUp :: (HasCallStack) => DB.MigrationName -> DB.SQLite ()
@@ -153,17 +129,6 @@ migrateUp = \case
         )
       |]
     pure ()
-  "like" -> do
-    [] <-
-      DB.run
-        [r| create table like(
-          id integer primary key autoincrement,
-          like_url text not null unique,
-          actor_url text not null,
-          note_url text not null
-        )
-      |]
-    pure ()
   name -> error $ "unexpected migration: " <> show name
 
 migrateDown :: (HasCallStack) => DB.MigrationName -> DB.SQLite ()
@@ -174,9 +139,6 @@ migrateDown = \case
   "follower" -> do
     [] <- DB.run "DROP TABLE follower"
     pure ()
-  "like" -> do
-    [] <- DB.run "DROP TABLE like"
-    pure ()
   name -> error $ "unexpected migration: " <> show name
 
 -----------------------
@@ -197,11 +159,6 @@ insertNoteToDb actor note = do
   [n] <- map decodeNoteRow <$> uncurry DB.runWith (insertNoteSQL actor note)
   pure n
 
-insertLikeToDb :: LikeEntry -> DB.SQLite DB.Int64
-insertLikeToDb like = do
-  [n] <- map decodeIntRow <$> uncurry DB.runWith (insertLikeSQL like)
-  pure n
-
 insertFollowerToDb :: FollowerEntry -> DB.SQLite DB.Int64
 insertFollowerToDb follower = do
   [n] <- map decodeIntRow <$> uncurry DB.runWith (insertFollowerSQL follower)
@@ -222,48 +179,16 @@ getNotesSQL :: (DB.SQL, [DB.SQLData])
 getNotesSQL =
   ( [r|
       SELECT
-        id as nid,
+        id,
         actor || '/notes/' || id,
         published,
         actor,
         content,
         name,
         inReplyTo,
-        url,
-        json_group_array(like) FILTER (WHERE like IS NOT NULL) as likes
-      FROM
-      ( SELECT
-          note.*,
-          CASE
-            WHEN like.id IS NOT NULL
-            THEN json_object(
-                   'likeId',
-                   like.id,
-                   'likeUrl',
-                   like.like_url,
-                   'likeActorUrl',
-                   like.actor_url,
-                   'likeNoteUrl',
-                   like.note_url
-                 )
-            ELSE NULL
-            END AS like
-        FROM
-        ( SELECT * FROM note
-          WHERE inReplyTo IS NULL
-        ) as note
-        LEFT JOIN like
-        ON note.url = like.note_url
-      )
-      GROUP BY
-        id,
-        actor,
-        published,
-        actor,
-        content,
-        name,
-        inReplyTo,
         url
+      FROM note
+      WHERE inReplyTo IS NULL
       ORDER BY published DESC
     |]
   , []
@@ -280,38 +205,10 @@ getNoteSQL noteid =
         content,
         name,
         inReplyTo,
-        url,
-        json_group_array(like) FILTER (WHERE like IS NOT NULL) as likes
-      FROM
-      ( SELECT
-          note.*,
-          CASE
-            WHEN like.id IS NOT NULL
-            THEN json_object(
-                   'likeId',
-                   like.id,
-                   'likeUrl',
-                   like.like_url,
-                   'likeActorUrl',
-                   like.actor_url,
-                   'likeNoteUrl',
-                   like.note_url
-                 )
-            ELSE NULL
-            END AS like
-        FROM (SELECT * FROM note WHERE id = ?) as note
-        LEFT JOIN like
-        ON note.url = like.note_url
-      )
-      GROUP BY
-        id,
-        actor,
-        published,
-        actor,
-        content,
-        name,
-        inReplyTo,
         url
+      FROM note
+      WHERE note.id = ?
+      ORDER BY published DESC
     |]
   , [DB.SQLInteger noteid]
   )
@@ -341,23 +238,6 @@ insertNoteSQL actor note =
     ]
   )
 
-insertLikeSQL :: LikeEntry -> (DB.SQL, [DB.SQLData])
-insertLikeSQL like =
-  ( [r|
-      INSERT INTO outer_like(like_url, actor_url, note_url)
-      VALUES (?, ?, ?)
-      RETURNING
-        id as id,
-        like_url,
-        actor_url,
-        note_url
-    |]
-  , [ DB.SQLText (T.pack like.likeUrl)
-    , DB.SQLText (T.pack like.likeActorUrl.unwrap)
-    , DB.SQLText (T.pack like.likeNoteUrl.unwrap)
-    ]
-  )
-
 insertFollowerSQL :: FollowerEntry -> (DB.SQL, [DB.SQLData])
 insertFollowerSQL follower =
   ( [r|
@@ -410,14 +290,9 @@ decodeNoteRow = \case
     , nullableString -> Just name
     , nullableString -> Just inReplyTo
     , nullableString -> Just url
-    , fromJson -> Just (dblikes :: [DbLike])
     ] ->
       let
         emptyNote = emptyUserNote $ T.unpack actor
-        likes =
-          map
-            (\like -> aLike like.likeUrl like.likeActorUrl like.likeNoteUrl)
-            dblikes
       in
         ( noteid
         , emptyNote
@@ -431,18 +306,8 @@ decodeNoteRow = \case
             , otype =
                 emptyNote.otype
                   { likes =
-                      emptyUnorderedCollection
+                      emptyNote.otype.likes
                         { id = Just $ ObjectId $ T.unpack noteidurl <> "/likes"
-                        , otype =
-                          CollectionType
-                            { ctype =
-                                UnorderedCollectionType
-                                  { items = likes
-                                  }
-                            , first = Nothing
-                            , last = Nothing
-                            , current = Nothing
-                            }
                         }
                   , shares =
                       emptyNote.otype.shares
@@ -481,9 +346,3 @@ toNullableString :: Maybe String -> DB.SQLData
 toNullableString = \case
   Nothing -> DB.SQLNull
   Just str -> DB.SQLText (T.pack str)
-
-fromJson :: A.FromJSON a => DB.SQLData -> Maybe [a]
-fromJson = \case
-  DB.SQLNull -> Just []
-  DB.SQLText str -> A.decode (BSL.fromStrict $ T.encodeUtf8 str)
-  _ -> Nothing

app/Main.hs

@@ -15,7 +15,6 @@ import Network.Wai.Middleware.RequestLogger qualified as Logger
 import Network.Wai.Middleware.RequestSizeLimit qualified as Limit
 import Network.Wai.Middleware.Routed qualified as Wai
 import Routes
-import Fedi qualified as Fedi
 import System.Environment (getArgs, lookupEnv)
 import Web.Twain qualified as Twain
 
@@ -136,7 +135,9 @@ mkFediApp connStr = do
     lookupEnv "FEDI_DETAILS"
       <&> maybe (error "missing FEDI_DETAILS") id
 
-  details <- Fedi.readUserDetailsFile detailsFile
+  details <-
+    A.eitherDecodeFileStrict detailsFile
+      <&> either (\err -> error $ "could not read file '" <> detailsFile <> "'.\n" <> err) id
 
   db <- mkDB connStr details
 

app/Routes.hs

@@ -1,5 +1,6 @@
 module Routes where
 
+import Control.Concurrent.Async qualified as Async
 import Control.Logger.Simple qualified as Log
 import DB
 import Data.Aeson qualified as A
@@ -9,7 +10,7 @@ import Data.Text qualified as T
 import Fedi qualified as Fedi
 import Html
 import Lucid qualified as H
-import Routes.Inbox
+import Routes.Inbox.Follow
 import System.IO.Unsafe (unsafePerformIO)
 import Web.Twain qualified as Twain
 
@@ -124,3 +125,36 @@ fetchUserDetails detailsFile =
 
 noteToCreate :: Fedi.Note -> Fedi.Create
 noteToCreate note = Fedi.makeCreateNote note
+
+handleInbox :: DB -> FilePath -> Fedi.AnyActivity -> Twain.ResponderM Twain.Response
+handleInbox db detailsFile activity = do
+  details <- liftIO $ fetchUserDetails detailsFile
+  Log.logDebug $ "Inbox request: " <> Fedi.pJson activity
+  case activity of
+    Fedi.ActivityFollow follow ->
+      handleInboxFollow details db activity follow
+    Fedi.ActivityUndo
+      ( Fedi.Object
+          { otype =
+            Fedi.TypeActivity
+              { atype =
+                Fedi.TypeUndo
+                  { object = Fedi.ActivityFollow follow
+                  }
+              }
+          }
+        ) ->
+        handleInboxUnfollow details db activity follow
+    _ -> do
+      Log.logError $ "Unsupported activity: " <> Fedi.pShow activity
+      Twain.next
+
+sendFollowers :: Fedi.UserDetails -> DB -> Fedi.AnyActivity -> IO ()
+sendFollowers details db message = do
+  Log.logDebug $ "Sending to followers: " <> Fedi.pJson message
+  followers <- db.getFollowers
+  Fedi.for_ followers \follower -> do
+    Async.async $ do
+      Log.logDebug $ "Sending to follower: " <> Fedi.pShow follower.actorId
+      bs <- Fedi.sendPost details (T.unpack follower.actorId <> "/inbox") message
+      Log.logDebug $ "Sent to follower: " <> Fedi.pShow (follower.actorId, bs)

app/Routes/Inbox.hs

@@ -1,45 +0,0 @@
-module Routes.Inbox where
-
-import Control.Concurrent.Async qualified as Async
-import Control.Logger.Simple qualified as Log
-import DB
-import Data.Text qualified as T
-import Fedi qualified as Fedi
-import Routes.Inbox.Follow
-import Routes.Inbox.Like
-import Web.Twain qualified as Twain
-
-handleInbox :: DB -> FilePath -> Fedi.AnyActivity -> Twain.ResponderM Twain.Response
-handleInbox db detailsFile activity = do
-  details <- liftIO $ Fedi.readUserDetailsFile detailsFile
-  Log.logDebug $ "Inbox request: " <> Fedi.pJson activity
-  case activity of
-    Fedi.ActivityFollow follow ->
-      handleInboxFollow details db activity follow
-    Fedi.ActivityLike like ->
-      handleInboxLike db like
-    Fedi.ActivityUndo
-      ( Fedi.Object
-          { otype =
-            Fedi.TypeActivity
-              { atype =
-                Fedi.TypeUndo
-                  { object = Fedi.ActivityFollow follow
-                  }
-              }
-          }
-        ) ->
-        handleInboxUnfollow details db activity follow
-    _ -> do
-      Log.logError $ "Unsupported activity: " <> Fedi.pShow activity
-      Twain.next
-
-sendFollowers :: Fedi.UserDetails -> DB -> Fedi.AnyActivity -> IO ()
-sendFollowers details db message = do
-  Log.logDebug $ "Sending to followers: " <> Fedi.pJson message
-  followers <- db.getFollowers
-  Fedi.for_ followers \follower -> do
-    Async.async $ do
-      Log.logDebug $ "Sending to follower: " <> Fedi.pShow follower.actorId
-      bs <- Fedi.sendPost details (T.unpack follower.actorId <> "/inbox") message
-      Log.logDebug $ "Sent to follower: " <> Fedi.pShow (follower.actorId, bs)

app/Routes/Inbox/Like.hs

@@ -1,72 +0,0 @@
-module Routes.Inbox.Like where
-
-import Control.Logger.Simple qualified as Log
-import DB
-import Fedi qualified as Fedi
-import Web.Twain qualified as Twain
-
-handleInboxLike
-  :: DB
-  -> Fedi.Like
-  -> Twain.ResponderM Twain.Response
-handleInboxLike db like = do
-  let
-    id' = like.id
-    actor = like.otype.actor
-    note = like.otype.atype.object
-  case id' of
-    Just id'' -> do
-      let
-        likeEntry =
-          ( LikeEntry
-              { likeUrl = fromString id''.unwrap
-              , likeActorUrl = actor
-              , likeNoteUrl = note
-              }
-          )
-        operation = do
-          likeid <- db.insertLike likeEntry
-          Log.logInfo ("New like: " <> Fedi.pShow (likeid, likeEntry))
-      liftIO operation
-      pure $ Twain.text ""
-    Nothing ->
-      Twain.next
-
-  {-
-handleInboxUnlike
-  :: DB
-  -> Fedi.Like
-  -> Twain.ResponderM Twain.Response
-handleInboxUnlike db like = do
-  let
-    id' = like.id
-    actor = like.otype.actor
-    note = like.otype.atype.object
-  case id' of
-    Just id'' -> do
-          let
-            followerEntry =
-              ( LikeEntry
-                  { likeUrl = fromString id''.unwrap
-                  , likeActorUrl = actor
-                  , likeNoteUrl = note
-                  }
-              )
-            operation sendAccept = do
-              deleteFollower
-                db
-                LikeEntry
-                ( \deletedId' -> do
-                    let
-                      deletedId = Fedi.fromMaybe 0 deletedId'
-                    sendAccept deletedId
-                      <* Log.logInfo ("Deleted follower: " <> Fedi.pShow deletedId)
-                )
-
-          liftIO $ acceptRequest details actor activity operation
-
-          pure $ Twain.text ""
-    Nothing ->
-      Twain.next
-
--}

fedi.cabal

@@ -91,8 +91,6 @@ executable fediserve
     Html
     Css
     Routes
-    Routes.Inbox
-    Routes.Inbox.Like
     Routes.Inbox.Follow
     Routes.Inbox.Accept
   -- other-extensions:
@@ -104,7 +102,6 @@ executable fediserve
     , wai-extra
     , warp
     , twain
-    , bytestring
     , text
     , sqlite-easy
     , raw-strings-qq
@@ -124,9 +121,6 @@ executable fediserve
     ViewPatterns
     DuplicateRecordFields
     NoFieldSelectors
-    GeneralizedNewtypeDeriving
-    DeriveAnyClass
-    DerivingStrategies
   ghc-options: -Wall -O -threaded -rtsopts -with-rtsopts=-N
 
 test-suite fedi-test

src/Fedi/Crypto.hs

@@ -76,12 +76,3 @@ decodeBase64 = Base64.decodeBase64Lenient
 makeDigest :: ByteString -> ByteString
 makeDigest message =
   BA.convert (Crypto.hash message :: Crypto.Digest Crypto.SHA256)
-
-sha1short :: Show a => a -> String
-sha1short =
-  ( take 10
-  . show
-  . (Crypto.hash :: ByteString -> Crypto.Digest Crypto.SHA1)
-  . fromString
-  . show
-  )

src/Fedi/Types.hs

@@ -350,33 +350,27 @@ instance A.FromJSON TypeUndo where
 --
 type Like = Object (TypeActivity TypeLike)
 
-data TypeLike
+data TypeLike = TypeLike deriving (Show, Eq)
-  = TypeLike
-  { object :: Link
-  }
-  deriving (Show, Eq)
 
 instance ToObject TypeLike where
-  toObject like =
+  toObject TypeLike =
     [ "type" A..= ("Like" :: String)
-    , "object" A..= like.object
     ]
 
 instance A.FromJSON TypeLike where
   parseJSON =
     A.withObject "TypeLike" \value -> do
       typ :: String <- value A..: "type"
-      object <- value A..: "object"
       guard (typ == "Like")
-      pure TypeLike{..}
+      pure TypeLike
 
 data AnyActivity
   = -- ActivityAnnounce Announce
     ActivityCreate Create
   | ActivityUndo Undo
   | ActivityFollow Follow
-  | ActivityLike Like
+  | --  | ActivityLike Like
-  | ActivityAccept Accept
+    ActivityAccept Accept
   | ActivityReject Reject
   deriving (Show, Eq)
 
@@ -386,7 +380,6 @@ instance A.ToJSON AnyActivity where
     ActivityCreate obj -> A.toJSON obj
     ActivityUndo obj -> A.toJSON obj
     ActivityFollow obj -> A.toJSON obj
-    ActivityLike obj -> A.toJSON obj
     --    ActivityLike obj -> A.toJSON obj
     ActivityAccept obj -> A.toJSON obj
     ActivityReject obj -> A.toJSON obj
@@ -399,7 +392,6 @@ instance A.FromJSON AnyActivity where
         "Create" -> ActivityCreate <$> A.parseJSON value
         "Undo" -> ActivityUndo <$> A.parseJSON value
         "Follow" -> ActivityFollow <$> A.parseJSON value
-        "Like" -> ActivityLike <$> A.parseJSON value
         "Accept" -> ActivityAccept <$> A.parseJSON value
         "Reject" -> ActivityReject <$> A.parseJSON value
         _ -> fail ("Parsing '" <> typ <> "' not yet implemented.")

src/Fedi/Types/Helpers.hs

@@ -174,23 +174,3 @@ makeAccept accept =
           , origin = Nothing
           }
     }
-
--- | Create a 'Like'.
-aLike :: ObjectId -> Link -> Link -> Like
-aLike id' actor object =
-  emptyObject
-    { id = Just id'
-    , otype = typeActivityLike actor object
-    }
-
--- | A 'TypeLike'.
-typeActivityLike :: Link -> Link -> TypeActivity TypeLike
-typeActivityLike actor object =
-  TypeActivity
-    { actor = actor
-    , atype = TypeLike
-      { object = object
-      }
-    , target = Nothing
-    , origin = Nothing
-    }