159 lines
6.1 KiB
Haskell
159 lines
6.1 KiB
Haskell
module Routes where
|
|
|
|
import DB
|
|
import Data.Aeson qualified as A
|
|
import Data.Functor ((<&>))
|
|
import Data.Maybe (maybeToList)
|
|
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
|
|
import Control.Logger.Simple qualified as Log
|
|
import Routes.Inbox.Follow
|
|
|
|
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
|
|
Log.logTrace "Inbox"
|
|
Fedi.handleInbox (handleInbox db detailsFile)
|
|
|
|
, -- 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
|
|
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)
|