diff --git a/app/Css.hs b/app/Css.hs index 2e275cd..10c77ae 100644 --- a/app/Css.hs +++ b/app/Css.hs @@ -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; diff --git a/app/DB.hs b/app/DB.hs index 86302e3..03b415d 100644 --- a/app/DB.hs +++ b/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) diff --git a/app/Html.hs b/app/Html.hs index 2789832..e6037db 100644 --- a/app/Html.hs +++ b/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" + ] ) diff --git a/app/Main.hs b/app/Main.hs index 7afa3fc..c00b36a 100644 --- a/app/Main.hs +++ b/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 | serve ]" - , "Env vars:" - , " - FEDI_PORT=" - , " - FEDI_DETAILS=" - , " - FEDI_CONN_STRING=" - , " - FEDI_AUTH=," - ] + errorWithoutStackTrace $ + unlines + [ "Usage: fedi [ insert | serve ]" + , "Env vars:" + , " - FEDI_PORT=" + , " - FEDI_DETAILS=" + , " - FEDI_CONN_STRING=" + , " - FEDI_AUTH=," + ] -- | 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) diff --git a/app/Routes.hs b/app/Routes.hs index 8fbfcdc..17e9cb0 100644 --- a/app/Routes.hs +++ b/app/Routes.hs @@ -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 diff --git a/fedi.cabal b/fedi.cabal index a3d2efc..9798bbd 100644 --- a/fedi.cabal +++ b/fedi.cabal @@ -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: diff --git a/fourmolu.yaml b/fourmolu.yaml new file mode 100644 index 0000000..685d4e3 --- /dev/null +++ b/fourmolu.yaml @@ -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: [] diff --git a/src/Fedi.hs b/src/Fedi.hs index 50d52ea..4d42414 100644 --- a/src/Fedi.hs +++ b/src/Fedi.hs @@ -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 diff --git a/src/Fedi/Activity.hs b/src/Fedi/Activity.hs deleted file mode 100644 index fc5a8ed..0000000 --- a/src/Fedi/Activity.hs +++ /dev/null @@ -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 - ] diff --git a/src/Fedi/Actor.hs b/src/Fedi/Actor.hs deleted file mode 100644 index f194043..0000000 --- a/src/Fedi/Actor.hs +++ /dev/null @@ -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 - ] diff --git a/src/Fedi/Helpers.hs b/src/Fedi/Helpers.hs new file mode 100644 index 0000000..007a6d8 --- /dev/null +++ b/src/Fedi/Helpers.hs @@ -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 + } + } diff --git a/src/Fedi/Routes.hs b/src/Fedi/Routes.hs index 67c903e..383f556 100644 --- a/src/Fedi/Routes.hs +++ b/src/Fedi/Routes.hs @@ -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 diff --git a/src/Fedi/Types.hs b/src/Fedi/Types.hs index c77ae79..42ac98e 100644 --- a/src/Fedi/Types.hs +++ b/src/Fedi/Types.hs @@ -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. +-- +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, +-- +-- 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. +-- +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 + ] diff --git a/src/Fedi/UserDetails.hs b/src/Fedi/UserDetails.hs new file mode 100644 index 0000000..3e2c2f7 --- /dev/null +++ b/src/Fedi/UserDetails.hs @@ -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 diff --git a/src/Fedi/Webfinger.hs b/src/Fedi/Webfinger.hs index 3a85b14..a4267f3 100644 --- a/src/Fedi/Webfinger.hs +++ b/src/Fedi/Webfinger.hs @@ -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 ]