rewrite api to be a bit richer
This commit is contained in:
parent
bc4039c7fd
commit
62917c3ce4
@ -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;
|
||||
|
||||
117
app/DB.hs
117
app/DB.hs
@ -1,53 +1,56 @@
|
||||
-- | 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
|
||||
}
|
||||
{ getNotes :: IO [Note]
|
||||
, getNote :: DB.Int64 -> IO (Maybe Note)
|
||||
, insertNote :: NoteEntry -> IO ObjectId
|
||||
}
|
||||
|
||||
-- * Data types
|
||||
|
||||
data NoteEntry
|
||||
= NoteEntry
|
||||
{ inReplyTo :: Maybe Url
|
||||
, content :: T.Text
|
||||
, name :: Maybe String
|
||||
, url :: Maybe Url
|
||||
}
|
||||
{ inReplyTo :: Maybe Url
|
||||
, content :: T.Text
|
||||
, name :: Maybe String
|
||||
, 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 DB
|
||||
{ getNotes =
|
||||
DB.withPool pool (getNotesFromDb $ actorUrl details)
|
||||
, getNote =
|
||||
\noteid -> DB.withPool pool (getNoteFromDb noteid $ actorUrl details)
|
||||
, insertNote =
|
||||
\note -> DB.withPool pool (insertNoteToDb (actorUrl details) note)
|
||||
}
|
||||
pure
|
||||
DB
|
||||
{ getNotes =
|
||||
DB.withPool pool (getNotesFromDb $ actorUrl details)
|
||||
, getNote =
|
||||
\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]
|
||||
@ -55,11 +58,12 @@ migrations =
|
||||
[ "note"
|
||||
]
|
||||
|
||||
migrateUp :: HasCallStack => DB.MigrationName -> DB.SQLite ()
|
||||
migrateUp :: (HasCallStack) => DB.MigrationName -> DB.SQLite ()
|
||||
migrateUp = \case
|
||||
"note" -> do
|
||||
[] <- DB.run
|
||||
[r| create table note(
|
||||
[] <-
|
||||
DB.run
|
||||
[r| create table note(
|
||||
id integer primary key autoincrement,
|
||||
published datetime default (datetime('now')),
|
||||
actor text not null,
|
||||
@ -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 published,
|
||||
DB.SQLText actor,
|
||||
DB.SQLText content,
|
||||
nullableString -> Just name,
|
||||
nullableString -> Just inReplyTo,
|
||||
nullableString -> Just url
|
||||
[ DB.SQLText noteid
|
||||
, DB.SQLText published
|
||||
, DB.SQLText actor
|
||||
, DB.SQLText content
|
||||
, nullableString -> Just name
|
||||
, nullableString -> Just inReplyTo
|
||||
, nullableString -> Just url
|
||||
] ->
|
||||
Note
|
||||
{ id = T.unpack noteid
|
||||
, published = read (T.unpack published)
|
||||
, actor = T.unpack actor
|
||||
, inReplyTo = inReplyTo
|
||||
, content = content
|
||||
, url = url
|
||||
, name = name
|
||||
, replies = Collection
|
||||
{ id = T.unpack noteid <> "/replies"
|
||||
, summary = "Replies"
|
||||
, items = []
|
||||
, first = Nothing
|
||||
, last = Nothing
|
||||
let
|
||||
emptyNote = emptyUserNote $ T.unpack actor
|
||||
in
|
||||
emptyNote
|
||||
{ id = Just $ ObjectId $ T.unpack noteid
|
||||
, published = Just $ read (T.unpack published)
|
||||
, attributedTo = Just $ LLink $ Link $ T.unpack actor
|
||||
, inReplyTo = LLink . Link <$> inReplyTo
|
||||
, content = Just content
|
||||
, url = url
|
||||
, name = StringName <$> name
|
||||
, otype =
|
||||
emptyNote.otype
|
||||
{ likes =
|
||||
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] -> 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)
|
||||
|
||||
110
app/Html.hs
110
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
|
||||
|
||||
@ -15,69 +14,69 @@ type Html = H.Html ()
|
||||
adminPage :: Fedi.UserDetails -> [Fedi.Note] -> Html
|
||||
adminPage details notes =
|
||||
template (T.pack $ Fedi.fullmention details) do
|
||||
userHtml details
|
||||
newNoteHtml details
|
||||
notesHtml notes
|
||||
userHtml details
|
||||
newNoteHtml details
|
||||
notesHtml notes
|
||||
|
||||
actorPage :: Fedi.UserDetails -> [Fedi.Note] -> Html
|
||||
actorPage details notes =
|
||||
template (T.pack $ Fedi.fullmention details) do
|
||||
userHtml details
|
||||
notesHtml notes
|
||||
userHtml details
|
||||
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.name_ "viewport", H.content_ "width=device-width initial_scale=1.0" ]
|
||||
H.meta_ [H.charset_ "utf-8"]
|
||||
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.a_ [ H.href_ (T.pack $ "/" <> details.username) ] $
|
||||
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"] do
|
||||
H.a_ [H.href_ (T.pack $ "/" <> details.username)] $
|
||||
H.img_ [H.class_ "avatar", H.src_ (T.pack details.icon)]
|
||||
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-header" ] $ do
|
||||
H.div_ [H.class_ "note"] $ do
|
||||
H.div_ [H.class_ "note-header"] $ do
|
||||
case note.name of
|
||||
Just title ->
|
||||
H.h2_ [ H.class_ (checkDirection $ T.pack title) ] (fromString title)
|
||||
Nothing -> pure ()
|
||||
Just (Fedi.StringName title) ->
|
||||
H.h2_ [H.class_ (checkDirection $ T.pack title)] (fromString title)
|
||||
_ -> 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 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.toHtmlRaw note.content
|
||||
H.div_ [H.class_ $ "note-content " <> checkDirection (maybe "" id note.content)] $ do
|
||||
H.toHtmlRaw (maybe "" id note.content)
|
||||
|
||||
checkDirection :: T.Text -> T.Text
|
||||
checkDirection txt =
|
||||
@ -95,31 +94,36 @@ newNoteHtml details = do
|
||||
, H.class_ "new-note"
|
||||
]
|
||||
( do
|
||||
H.div_ [ H.class_ "new-note-div" ] $ H.input_
|
||||
[ H.class_ "new-note-text"
|
||||
, H.autofocus_
|
||||
, H.type_ "text"
|
||||
, H.name_ "title"
|
||||
, H.placeholder_ "A title (optional)"
|
||||
]
|
||||
H.div_ [H.class_ "new-note-div"] $
|
||||
H.input_
|
||||
[ H.class_ "new-note-text"
|
||||
, H.autofocus_
|
||||
, H.type_ "text"
|
||||
, H.name_ "title"
|
||||
, H.placeholder_ "A title (optional)"
|
||||
]
|
||||
|
||||
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.textarea_
|
||||
[ H.class_ "new-note-content"
|
||||
, H.name_ "content"
|
||||
, H.placeholder_ "Yes?"
|
||||
]
|
||||
""
|
||||
|
||||
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.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.class_ "new-note-submit"
|
||||
, H.type_ "submit"
|
||||
, H.title_ "Add a new note"
|
||||
, H.value_ "Post"
|
||||
]
|
||||
H.div_ [H.class_ "new-note-div"] $
|
||||
H.input_
|
||||
[ H.class_ "new-note-submit"
|
||||
, H.type_ "submit"
|
||||
, H.title_ "Add a new note"
|
||||
, H.value_ "Post"
|
||||
]
|
||||
)
|
||||
|
||||
121
app/Main.hs
121
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 (run, Port)
|
||||
import Network.Wai.Middleware.Routed qualified as Wai
|
||||
import Network.Wai.Handler.Warp (Port, run)
|
||||
import Network.Wai.Middleware.HttpAuth (basicAuth)
|
||||
import Network.Wai.Middleware.RequestLogger qualified as Logger
|
||||
import System.Environment (getArgs)
|
||||
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 Network.Wai.Middleware.Routed qualified as Wai
|
||||
import Routes
|
||||
import System.Environment (getArgs, lookupEnv)
|
||||
import Web.Twain qualified as Twain
|
||||
|
||||
data Command
|
||||
= Serve
|
||||
@ -25,10 +23,11 @@ data Command
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
command <- getArgs >>= \case
|
||||
["insert", file] -> pure (Insert file)
|
||||
["serve"] -> pure Serve
|
||||
_ -> usageError
|
||||
command <-
|
||||
getArgs >>= \case
|
||||
["insert", file] -> pure (Insert file)
|
||||
["serve"] -> pure Serve
|
||||
_ -> usageError
|
||||
|
||||
case command of
|
||||
Insert file -> do
|
||||
@ -41,25 +40,28 @@ insertNoteFromFile file = do
|
||||
connStr <- maybe "/tmp/fediserve_sqlite_db.sqlite" fromString <$> lookupEnv "FEDI_CONN_STRING"
|
||||
content <- T.readFile file
|
||||
|
||||
detailsFile <- lookupEnv "FEDI_DETAILS"
|
||||
<&> maybe (error "missing FEDI_DETAILS") id
|
||||
detailsFile <-
|
||||
lookupEnv "FEDI_DETAILS"
|
||||
<&> maybe (error "missing FEDI_DETAILS") id
|
||||
|
||||
details <- A.eitherDecodeFileStrict detailsFile
|
||||
<&> either (\err -> error $ "could not read file '" <> detailsFile <> "'.\n" <> err) id
|
||||
details <-
|
||||
A.eitherDecodeFileStrict detailsFile
|
||||
<&> either (\err -> error $ "could not read file '" <> detailsFile <> "'.\n" <> err) id
|
||||
|
||||
db <- mkDB connStr details
|
||||
|
||||
note <- db.insertNote NoteEntry
|
||||
{ content = content
|
||||
, inReplyTo = Nothing
|
||||
, name = Nothing
|
||||
, url = Nothing
|
||||
}
|
||||
note <-
|
||||
db.insertNote
|
||||
NoteEntry
|
||||
{ content = content
|
||||
, inReplyTo = Nothing
|
||||
, name = Nothing
|
||||
, url = Nothing
|
||||
}
|
||||
|
||||
putStrLn "Inserted."
|
||||
print note
|
||||
|
||||
|
||||
serve :: IO ()
|
||||
serve = do
|
||||
auth <- fmap (T.splitOn "," . T.pack) <$> lookupEnv "FEDI_AUTH"
|
||||
@ -73,13 +75,15 @@ serve = do
|
||||
let
|
||||
username = secureMemFromByteString $ T.encodeUtf8 user
|
||||
password = secureMemFromByteString $ T.encodeUtf8 pass
|
||||
pure $ basicAuth
|
||||
( \u p -> pure $
|
||||
secureMemFromByteString u == username
|
||||
&& secureMemFromByteString p == password
|
||||
)
|
||||
"My Fediserve"
|
||||
Just{} -> usageError
|
||||
pure $
|
||||
basicAuth
|
||||
( \u p ->
|
||||
pure $
|
||||
secureMemFromByteString u == username
|
||||
&& secureMemFromByteString p == password
|
||||
)
|
||||
"My Fediserve"
|
||||
Just {} -> usageError
|
||||
|
||||
fediPort <- maybe 3001 read <$> lookupEnv "FEDI_PORT"
|
||||
conn <- maybe "/tmp/fediserve_sqlite_db.sqlite" fromString <$> lookupEnv "FEDI_CONN_STRING"
|
||||
@ -89,41 +93,46 @@ serve = do
|
||||
|
||||
usageError :: err
|
||||
usageError =
|
||||
errorWithoutStackTrace $ unlines
|
||||
[ "Usage: fedi [ insert <FILE> | serve ]"
|
||||
, "Env vars:"
|
||||
, " - FEDI_PORT=<PORT>"
|
||||
, " - FEDI_DETAILS=<FILE>"
|
||||
, " - FEDI_CONN_STRING=<SQLITE_CONN_STR>"
|
||||
, " - FEDI_AUTH=<user>,<password>"
|
||||
]
|
||||
errorWithoutStackTrace $
|
||||
unlines
|
||||
[ "Usage: fedi [ insert <FILE> | serve ]"
|
||||
, "Env vars:"
|
||||
, " - FEDI_PORT=<PORT>"
|
||||
, " - FEDI_DETAILS=<FILE>"
|
||||
, " - FEDI_CONN_STRING=<SQLITE_CONN_STR>"
|
||||
, " - FEDI_AUTH=<user>,<password>"
|
||||
]
|
||||
|
||||
-- | Run server at at specific port.
|
||||
runServer :: Port -> Twain.Middleware -> Twain.Application -> IO ()
|
||||
runServer port authMiddleware app = do
|
||||
putStrLn $ unwords
|
||||
[ "Running fedi at"
|
||||
, "http://localhost:" <> show port
|
||||
, "(ctrl-c to quit)"
|
||||
]
|
||||
putStrLn $
|
||||
unwords
|
||||
[ "Running fedi at"
|
||||
, "http://localhost:" <> show port
|
||||
, "(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 <- lookupEnv "FEDI_DETAILS"
|
||||
<&> maybe (error "missing FEDI_DETAILS") id
|
||||
detailsFile <-
|
||||
lookupEnv "FEDI_DETAILS"
|
||||
<&> maybe (error "missing FEDI_DETAILS") id
|
||||
|
||||
details <- A.eitherDecodeFileStrict detailsFile
|
||||
<&> either (\err -> error $ "could not read file '" <> detailsFile <> "'.\n" <> err) id
|
||||
details <-
|
||||
A.eitherDecodeFileStrict detailsFile
|
||||
<&> either (\err -> error $ "could not read file '" <> detailsFile <> "'.\n" <> err) id
|
||||
|
||||
db <- mkDB connStr details
|
||||
|
||||
pure $ foldr ($)
|
||||
(Twain.notFound $ Twain.send $ Twain.text "Error: not found.")
|
||||
(routes db detailsFile)
|
||||
pure $
|
||||
foldr
|
||||
($)
|
||||
(Twain.notFound $ Twain.send $ Twain.text "Error: not found.")
|
||||
(routes db detailsFile)
|
||||
|
||||
@ -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
|
||||
|
||||
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
|
||||
{ content = content
|
||||
, inReplyTo = Nothing
|
||||
, name = if trim title == "" then Nothing else Just title
|
||||
, url = if trim url == "" then Nothing else Just url
|
||||
}
|
||||
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 note =
|
||||
Fedi.Create
|
||||
{ id =
|
||||
note.id <> "/create"
|
||||
, actor = note.actor
|
||||
, object = Fedi.NoteObject note
|
||||
}
|
||||
noteToCreate :: Fedi.Note -> Fedi.Create
|
||||
noteToCreate note = Fedi.makeCreateNote note
|
||||
|
||||
@ -17,10 +17,10 @@ library
|
||||
import: warnings
|
||||
exposed-modules:
|
||||
Fedi
|
||||
Fedi.Activity
|
||||
Fedi.Actor
|
||||
Fedi.Helpers
|
||||
Fedi.Routes
|
||||
Fedi.Types
|
||||
Fedi.UserDetails
|
||||
Fedi.Webfinger
|
||||
-- other-modules:
|
||||
-- other-extensions:
|
||||
|
||||
16
fourmolu.yaml
Normal file
16
fourmolu.yaml
Normal file
@ -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: []
|
||||
@ -1,7 +1,7 @@
|
||||
module Fedi (module Export) where
|
||||
|
||||
import Fedi.Activity as Export
|
||||
import Fedi.Actor as Export
|
||||
import Fedi.Helpers as Export
|
||||
import Fedi.Routes as Export
|
||||
import Fedi.Types as Export
|
||||
import Fedi.UserDetails as Export
|
||||
import Fedi.Webfinger as Export
|
||||
|
||||
@ -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
|
||||
]
|
||||
@ -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
|
||||
]
|
||||
153
src/Fedi/Helpers.hs
Normal file
153
src/Fedi/Helpers.hs
Normal file
@ -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
|
||||
}
|
||||
}
|
||||
@ -1,35 +1,32 @@
|
||||
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.Actor
|
||||
import Fedi.UserDetails
|
||||
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 (matchCreate details) do
|
||||
handleUser details
|
||||
|
||||
handleOutbox details []
|
||||
, Twain.get (matchCreateNote details) do
|
||||
handleCreateNote details []
|
||||
, Twain.get (matchNote details) do
|
||||
handleUser details
|
||||
handleNote details []
|
||||
, -- , Twain.post (matchInbox details) do
|
||||
-- handleInbox details undefined
|
||||
|
||||
, Twain.get matchWebfinger do
|
||||
handleWebfinger details
|
||||
Twain.get matchWebfinger do
|
||||
handleWebfinger details
|
||||
]
|
||||
|
||||
jsonLD :: BSL.ByteString -> Twain.Response
|
||||
@ -40,11 +37,11 @@ jsonLD =
|
||||
|
||||
-- * Create
|
||||
|
||||
matchCreate :: UserDetails -> Twain.PathPattern
|
||||
matchCreate details = fromString ("/" <> details.username <> "/notes/:note_id/create")
|
||||
matchCreateNote :: UserDetails -> Twain.PathPattern
|
||||
matchCreateNote details = fromString ("/" <> details.username <> "/notes/:note_id/create")
|
||||
|
||||
handleCreate :: UserDetails -> [Activity] -> Twain.ResponderM a
|
||||
handleCreate details items = do
|
||||
handleCreateNote :: UserDetails -> [Create] -> Twain.ResponderM a
|
||||
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,34 +125,62 @@ handleOutbox details items = do
|
||||
case isPage of
|
||||
Just True ->
|
||||
let
|
||||
empty = emptyOrderedCollectionPage outboxUrl
|
||||
content :: OutboxPage
|
||||
content =
|
||||
OrderedCollectionPage
|
||||
{ id = outboxUrl <> "?page=true"
|
||||
, partOf = outboxUrl
|
||||
, orderedItems = items
|
||||
empty
|
||||
{ id = Just $ ObjectId $ outboxUrl <> "?page=true"
|
||||
, otype =
|
||||
empty.otype
|
||||
{ ctype =
|
||||
empty.otype.ctype
|
||||
{ partOf = outboxUrl
|
||||
, orderedItems = items
|
||||
}
|
||||
}
|
||||
}
|
||||
in A.encode content
|
||||
in
|
||||
A.encode content
|
||||
_ ->
|
||||
let
|
||||
content :: Outbox
|
||||
content =
|
||||
Collection
|
||||
{ id = outboxUrl
|
||||
, summary = details.username <> "'s notes"
|
||||
, items = items
|
||||
, first = Just $ outboxUrl <> "?page=true"
|
||||
, last = Just $ outboxUrl <> "?page=true"
|
||||
emptyOrderedCollection
|
||||
{ id = Just $ ObjectId outboxUrl
|
||||
, summary = Just $ fromString $ details.username <> "'s notes"
|
||||
, 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
|
||||
Just bs ->
|
||||
("application/activity+json" `BS.isInfixOf` bs)
|
||||
|| ( ("application/activity+json" `BS.isInfixOf` bs)
|
||||
&& ("profile=\"https://www.w3.org/ns/activitystreams\"" `BS.isInfixOf` bs)
|
||||
)
|
||||
|| ( ("application/activity+json" `BS.isInfixOf` bs)
|
||||
&& ("profile=\"https://www.w3.org/ns/activitystreams\"" `BS.isInfixOf` bs)
|
||||
)
|
||||
Nothing -> False
|
||||
|
||||
@ -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
|
||||
deriving Show
|
||||
-- | An Object is what everything is here.
|
||||
-- <https://www.w3.org/TR/activitystreams-vocabulary/#object-types>
|
||||
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)
|
||||
|
||||
instance A.ToJSON Rel where
|
||||
toJSON Self = A.String "self"
|
||||
class ToObject a where
|
||||
toObject :: a -> [A.Pair]
|
||||
|
||||
instance (ToObject a) => A.ToJSON (Object a) where
|
||||
toJSON = A.object . toObject
|
||||
|
||||
data LinkType = ActivityJson
|
||||
deriving Show
|
||||
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
|
||||
]
|
||||
]
|
||||
|
||||
instance A.ToJSON LinkType where
|
||||
toJSON ActivityJson = A.String "application/activity+json"
|
||||
newtype ObjectId = ObjectId {unwrap :: String}
|
||||
deriving (Show, Eq, A.FromJSON, A.ToJSON) via String
|
||||
|
||||
type Url = String
|
||||
type Domain = String
|
||||
type Username = String
|
||||
newtype Link = Link {unwrap :: Url}
|
||||
deriving (Show, A.FromJSON, A.ToJSON) via Url
|
||||
|
||||
newtype Pem = Pem T.Text
|
||||
deriving Show
|
||||
deriving A.FromJSON via T.Text
|
||||
data LinkOrObject a
|
||||
= LLink Link
|
||||
| OObject (Object a)
|
||||
| CCollection [LinkOrObject a]
|
||||
deriving (Show)
|
||||
|
||||
instance A.ToJSON Pem where
|
||||
toJSON (Pem pem) = A.String pem
|
||||
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)
|
||||
|
||||
data UserDetails
|
||||
= UserDetails
|
||||
{ domain :: Domain
|
||||
, username :: String
|
||||
, name :: String
|
||||
, summary :: String
|
||||
, icon :: Url
|
||||
, publicPem :: Pem
|
||||
, privatePem :: FilePath
|
||||
}
|
||||
deriving (Show, Generic, A.FromJSON)
|
||||
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
|
||||
|
||||
actorUrl :: UserDetails -> Url
|
||||
actorUrl details =
|
||||
"https://" <> details.domain <> "/" <> details.username
|
||||
data AnyMedia
|
||||
= ImageMedia Image
|
||||
deriving (Show)
|
||||
|
||||
fullmention :: UserDetails -> String
|
||||
fullmention details = "@" <> details.username <> "@" <> details.domain
|
||||
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
|
||||
]
|
||||
|
||||
46
src/Fedi/UserDetails.hs
Normal file
46
src/Fedi/UserDetails.hs
Normal file
@ -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
|
||||
@ -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]
|
||||
}
|
||||
deriving Show
|
||||
{ subject :: Subject
|
||||
, links :: [WfLink]
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data Subject
|
||||
= Subject
|
||||
{ username :: Username
|
||||
, domain :: Domain
|
||||
}
|
||||
deriving Show
|
||||
{ username :: Username
|
||||
, domain :: Domain
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
ppSubject :: Subject -> String
|
||||
ppSubject subject =
|
||||
"acct:" <> subject.username <> "@" <> subject.domain
|
||||
|
||||
data Link
|
||||
= Link
|
||||
{ rel :: Rel
|
||||
, type_ :: LinkType
|
||||
, href :: Url
|
||||
}
|
||||
deriving Show
|
||||
data WfLink
|
||||
= WfLink
|
||||
{ type_ :: WfLinkType
|
||||
, href :: Url
|
||||
}
|
||||
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
|
||||
{ username = details.username
|
||||
, domain = details.domain
|
||||
}
|
||||
{ subject =
|
||||
Subject
|
||||
{ username = details.username
|
||||
, domain = details.domain
|
||||
}
|
||||
, links =
|
||||
[ Link
|
||||
{ rel = Self
|
||||
, type_ = ActivityJson
|
||||
, href = url <> "/" <> details.username
|
||||
}
|
||||
]
|
||||
[ WfLink
|
||||
{ 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
|
||||
]
|
||||
|
||||
Loading…
Reference in New Issue
Block a user