fedi/app/Routes.hs

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 Html
import Lucid qualified as H
import System.IO.Unsafe (unsafePerformIO)
import Web.Twain qualified as Twain
import Data.Text qualified as T
import Control.Concurrent.Async qualified as Async

routes :: DB -> FilePath -> [Twain.Middleware]
routes db detailsFile =
  [ Twain.get "/" do
      details <- liftIO $ fetchUserDetails detailsFile
      Twain.send $
        Twain.redirect302 $
          fromString ("/" <> details.username)
  , -- Match actor
    Twain.get (Fedi.matchUser $ unsafePerformIO $ fetchUserDetails detailsFile) do
      request <- Twain.request
      if Fedi.checkContentTypeAccept request
        then do
          details <- liftIO $ fetchUserDetails detailsFile
          Fedi.handleUser details
        else do
          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
      request <- Twain.request
      if Fedi.checkContentTypeAccept request
        then do
          details <- liftIO $ fetchUserDetails detailsFile
          notes <- map (Fedi.ActivityCreate . noteToCreate) <$> liftIO db.getNotes
          Fedi.handleOutbox details notes
        else Twain.next
  , -- Match Create object
    Twain.get (Fedi.matchCreateNote $ unsafePerformIO $ fetchUserDetails detailsFile) do
      details <- liftIO $ fetchUserDetails detailsFile
      notes <- map noteToCreate <$> liftIO db.getNotes

      Fedi.handleCreateNote details notes
  , -- Match inbox
    Twain.post (Fedi.matchInbox $ unsafePerformIO $ fetchUserDetails detailsFile) do
      request <- Twain.request
      if Fedi.checkContentTypeAccept request
        then do
          Fedi.handleInbox (handleInbox db detailsFile)
        else Twain.next

  , -- Match Create object
    Twain.get (Fedi.matchCreateNote $ unsafePerformIO $ fetchUserDetails detailsFile) do
      details <- liftIO $ fetchUserDetails detailsFile
      notes <- map noteToCreate <$> liftIO db.getNotes

      Fedi.handleCreateNote details notes
  , -- Match Note object
    Twain.get (Fedi.matchNote $ unsafePerformIO $ fetchUserDetails detailsFile) do
      details <- liftIO $ fetchUserDetails detailsFile
      noteId <- Twain.param "note_id"
      mnote <- liftIO $ db.getNote noteId

      request <- Twain.request
      if Fedi.checkContentTypeAccept request
        then do
          Fedi.handleNote details (maybeToList mnote)
        else do
          case mnote of
            Nothing -> Twain.next
            Just thenote ->
              Twain.send $ Twain.html $ H.renderBS $ actorPage details [thenote]

  , -- Followers
    Twain.get (Fedi.matchFollowers $ unsafePerformIO $ fetchUserDetails detailsFile) do
      details <- liftIO $ fetchUserDetails detailsFile
      followers <- liftIO db.getFollowers
        <&> map (\follower -> T.unpack follower.actorId)
      Fedi.handleFollowers details followers
  , -- Following
    Twain.get (Fedi.matchFollowing $ unsafePerformIO $ fetchUserDetails detailsFile) do
      details <- liftIO $ fetchUserDetails detailsFile
      Fedi.handleFollowing details
  , -- 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"
      content <- Twain.param "content"
      url <- Twain.param "url"
      details <- liftIO $ fetchUserDetails detailsFile

      (noteid, note) <-
        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
              }

      liftIO $ sendFollowers details db (Fedi.ActivityCreate $ noteToCreate note)

      Twain.send $ Twain.redirect302 (fromString ("/" <> details.username <> "/notes/" <> show noteid))
  ]

trim :: String -> String
trim = unwords . words

fetchUserDetails :: FilePath -> IO Fedi.UserDetails
fetchUserDetails detailsFile =
  A.eitherDecodeFileStrict detailsFile
    <&> either (\err -> error $ "could not read file '" <> detailsFile <> "'.\n" <> err) id

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
  case activity of
    Fedi.ActivityFollow follow -> do
      let
        id' = follow.id
        actor = follow.otype.actor
        object = follow.otype.atype.object
      case id' of
        Just id'' -> do
          if object == Fedi.LLink (Fedi.Link $ Fedi.actorUrl details)
            then do
              liftIO do
                insertId <- db.insertFollower FollowerEntry
                  { actorId = fromString actor.unwrap
                  , followId = fromString id''.unwrap
                  }
                (result :: A.Value) <- Fedi.sendPost
                  details
                  (id''.unwrap <> "/inbox")
                  ( Fedi.makeAccept
                    follow
                    (Fedi.actorUrl details <> "/accepts/follows/" <> show insertId)
                  )
                print result
                pure $ Fedi.jsonLD "{}"
            else Twain.next
        Nothing ->
          Twain.next
    Fedi.ActivityUndo
      ( Fedi.Object
        { otype = Fedi.TypeActivity
          { atype = Fedi.TypeUndo
            { object = Fedi.ActivityFollow follow
            }
          }
        }) -> do
      let
        id' = follow.id
        actor = follow.otype.actor
        object = follow.otype.atype.object
      case id' of
        Just id'' -> do
          if object == Fedi.LLink (Fedi.Link $ Fedi.actorUrl details)
            then do
              liftIO do
                deletedId <- db.deleteFollower FollowerEntry
                  { actorId = fromString actor.unwrap
                  , followId = fromString id''.unwrap
                  }
                print ("deleted follower: " <> show deletedId)
                pure $ Fedi.jsonLD "{}"
            else Twain.next
        Nothing ->
          Twain.next
    _ -> do
      liftIO (print activity)
      Twain.next

sendFollowers :: Fedi.UserDetails -> DB -> Fedi.AnyActivity -> IO ()
sendFollowers details db message = do
  followers <- db.getFollowers
  Fedi.for_ followers \follower -> do
    Async.async $ do
      result <- Fedi.sendPost @A.Value details (T.unpack follower.actorId <> "/inbox") message
      print (follower.actorId, A.encode result)