diff --git a/fedi.cabal b/fedi.cabal index 96b7b47..8998f3f 100644 --- a/fedi.cabal +++ b/fedi.cabal @@ -18,10 +18,17 @@ library exposed-modules: Fedi Fedi.Helpers - Fedi.Routes Fedi.Types Fedi.UserDetails Fedi.Webfinger + + Fedi.Routes + Fedi.Routes.Helpers + Fedi.Routes.User + Fedi.Routes.Inbox + Fedi.Routes.Outbox + Fedi.Routes.Notes + Fedi.Routes.Follow -- other-modules: -- other-extensions: build-depends: diff --git a/src/Fedi/Routes.hs b/src/Fedi/Routes.hs index caa315e..a2ee7f7 100644 --- a/src/Fedi/Routes.hs +++ b/src/Fedi/Routes.hs @@ -1,14 +1,18 @@ -module Fedi.Routes where +module Fedi.Routes + ( module Fedi.Routes + , module Export + ) +where -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.UserDetails -import Fedi.Webfinger import Web.Twain qualified as Twain -import Web.Twain.Types qualified as Twain + +import Fedi.Routes.Helpers as Export +import Fedi.Routes.User as Export +import Fedi.Routes.Inbox as Export +import Fedi.Routes.Outbox as Export +import Fedi.Routes.Notes as Export +import Fedi.Routes.Follow as Export -- * Routes @@ -29,194 +33,3 @@ routes details = , Twain.get matchWebfinger do handleWebfinger details ] - -jsonLD :: BSL.ByteString -> Twain.Response -jsonLD = - Twain.raw - Twain.status200 - [(Twain.hContentType, "application/activity+json; charset=utf-8")] - --- * Create - -matchCreateNote :: UserDetails -> Twain.PathPattern -matchCreateNote details = fromString ("/" <> details.username <> "/notes/:note_id/create") - -handleCreateNote :: UserDetails -> [Create] -> Twain.ResponderM a -handleCreateNote details items = do - noteId <- Twain.param "note_id" - let - createUrl = - "https://" - <> details.domain - <> "/" - <> details.username - <> "/notes/" - <> noteId - <> "/create" - let - content = - find (\create -> create.id == Just (ObjectId createUrl)) items - Twain.send $ jsonLD (A.encode content) - --- * Note - -matchNote :: UserDetails -> Twain.PathPattern -matchNote details = fromString ("/" <> details.username <> "/notes/:note_id") - -handleNote :: UserDetails -> [Note] -> Twain.ResponderM a -handleNote details items = do - noteId <- Twain.param "note_id" - let - noteUrl = - "https://" - <> details.domain - <> "/" - <> details.username - <> "/notes/" - <> noteId - let - content = - find (\note -> note.id == Just (ObjectId noteUrl)) items - Twain.send $ jsonLD (A.encode content) - --- * User - -matchUser :: UserDetails -> Twain.PathPattern -matchUser details = fromString ("/" <> details.username) - -handleUser :: UserDetails -> Twain.ResponderM a -handleUser details = do - let - content = makeActor details - Twain.send $ jsonLD (A.encode content) - --- * Webfinger - -matchWebfinger :: Twain.PathPattern -matchWebfinger = "/.well-known/webfinger" - -handleWebfinger :: UserDetails -> Twain.ResponderM b -handleWebfinger details = do - resource <- Twain.param "resource" - let - webfinger = makeWebfinger details - if resource == ppSubject webfinger.subject - then do - Twain.send $ jsonLD (A.encode webfinger) - else do - Twain.next - --- * Outbox - -matchOutbox :: UserDetails -> Twain.PathPattern -matchOutbox details = - fromString ("/" <> details.username <> "/outbox") - -handleOutbox :: UserDetails -> [AnyActivity] -> Twain.ResponderM b -handleOutbox details items = do - isPage <- Twain.queryParamMaybe "page" - let - outboxUrl = - "https://" - <> details.domain - <> "/" - <> details.username - <> "/outbox" - response = - case isPage of - Just True -> - let - empty = emptyOrderedCollectionPage outboxUrl - content :: OutboxPage - content = - empty - { id = Just $ ObjectId $ outboxUrl <> "?page=true" - , otype = - empty.otype - { ctype = - empty.otype.ctype - { partOf = outboxUrl - , porderedItems = items - } - } - } - in - A.encode content - _ -> - let - content :: Outbox - content = - emptyOrderedCollection - { id = Just $ ObjectId outboxUrl - , summary = Just $ fromString $ details.username <> "'s notes" - , otype = - emptyOrderedCollection.otype - { ctype = - emptyOrderedCollection.otype.ctype - { orderedItems = items - } - , first = Just $ outboxUrl <> "?page=true" - , last = Just $ outboxUrl <> "?page=true" - } - } - in - A.encode content - Twain.send $ jsonLD response - --- * Inbox - -matchInbox :: UserDetails -> Twain.PathPattern -matchInbox details = - fromString ("/" <> details.username <> "/inbox") - -handleInbox :: (AnyActivity -> Twain.ResponderM Twain.Response) -> Twain.ResponderM b -handleInbox handle = do - activity <- Twain.fromBody - response <- handle activity - Twain.send response - --- * Followers - -matchFollowers :: UserDetails -> Twain.PathPattern -matchFollowers details = - fromString ("/" <> details.username <> "/followers") - -handleFollowers :: UserDetails -> Twain.ResponderM b -handleFollowers details = do - let - collection :: Collection () - collection = - emptyUnorderedCollection - { id = Just $ ObjectId $ actorUrl details <> "/followers" - , summary = Just $ fromString $ details.username <> "'s followers" - } - Twain.send $ jsonLD (A.encode collection) - --- * Following - -matchFollowing :: UserDetails -> Twain.PathPattern -matchFollowing details = - fromString ("/" <> details.username <> "/following") - -handleFollowing :: UserDetails -> Twain.ResponderM b -handleFollowing details = do - let - collection :: Collection () - collection = - emptyUnorderedCollection - { id = Just $ ObjectId $ actorUrl details <> "/following" - , summary = Just $ fromString $ details.username <> " is following" - } - Twain.send $ jsonLD (A.encode collection) - --- * Other stuff - -checkContentTypeAccept :: Twain.Request -> Bool -checkContentTypeAccept request = - case lookup Twain.hAccept request.requestHeaders of - Just bs -> - ("application/activity+json" `BS.isInfixOf` bs) - || ( ("application/ld+json" `BS.isInfixOf` bs) - && ("profile=\"https://www.w3.org/ns/activitystreams\"" `BS.isInfixOf` bs) - ) - Nothing -> False diff --git a/src/Fedi/Routes/Follow.hs b/src/Fedi/Routes/Follow.hs new file mode 100644 index 0000000..25712cf --- /dev/null +++ b/src/Fedi/Routes/Follow.hs @@ -0,0 +1,43 @@ +module Fedi.Routes.Follow where + +import Data.Aeson qualified as A +import Fedi.Helpers +import Fedi.Types +import Fedi.UserDetails +import Fedi.Routes.Helpers +import Web.Twain qualified as Twain +import Web.Twain.Types qualified as Twain + +-- * Followers + +matchFollowers :: UserDetails -> Twain.PathPattern +matchFollowers details = + fromString ("/" <> details.username <> "/followers") + +handleFollowers :: UserDetails -> Twain.ResponderM b +handleFollowers details = do + let + collection :: Collection () + collection = + emptyUnorderedCollection + { id = Just $ ObjectId $ actorUrl details <> "/followers" + , summary = Just $ fromString $ details.username <> "'s followers" + } + Twain.send $ jsonLD (A.encode collection) + +-- * Following + +matchFollowing :: UserDetails -> Twain.PathPattern +matchFollowing details = + fromString ("/" <> details.username <> "/following") + +handleFollowing :: UserDetails -> Twain.ResponderM b +handleFollowing details = do + let + collection :: Collection () + collection = + emptyUnorderedCollection + { id = Just $ ObjectId $ actorUrl details <> "/following" + , summary = Just $ fromString $ details.username <> " is following" + } + Twain.send $ jsonLD (A.encode collection) diff --git a/src/Fedi/Routes/Helpers.hs b/src/Fedi/Routes/Helpers.hs new file mode 100644 index 0000000..9defc39 --- /dev/null +++ b/src/Fedi/Routes/Helpers.hs @@ -0,0 +1,21 @@ +module Fedi.Routes.Helpers where + +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BSL +import Web.Twain qualified as Twain + +jsonLD :: BSL.ByteString -> Twain.Response +jsonLD = + Twain.raw + Twain.status200 + [(Twain.hContentType, "application/activity+json; charset=utf-8")] + +checkContentTypeAccept :: Twain.Request -> Bool +checkContentTypeAccept request = + case lookup Twain.hAccept request.requestHeaders of + Just bs -> + ("application/activity+json" `BS.isInfixOf` bs) + || ( ("application/ld+json" `BS.isInfixOf` bs) + && ("profile=\"https://www.w3.org/ns/activitystreams\"" `BS.isInfixOf` bs) + ) + Nothing -> False diff --git a/src/Fedi/Routes/Inbox.hs b/src/Fedi/Routes/Inbox.hs new file mode 100644 index 0000000..252eb1c --- /dev/null +++ b/src/Fedi/Routes/Inbox.hs @@ -0,0 +1,19 @@ +module Fedi.Routes.Inbox where + +import Fedi.Types +import Fedi.UserDetails +import Web.Twain qualified as Twain +import Web.Twain.Types qualified as Twain + +-- * Inbox + +matchInbox :: UserDetails -> Twain.PathPattern +matchInbox details = + fromString ("/" <> details.username <> "/inbox") + +handleInbox :: (AnyActivity -> Twain.ResponderM Twain.Response) -> Twain.ResponderM b +handleInbox handle = do + activity <- Twain.fromBody + -- sig <- Twain.header "Signature" + response <- handle activity + Twain.send response diff --git a/src/Fedi/Routes/Notes.hs b/src/Fedi/Routes/Notes.hs new file mode 100644 index 0000000..404226d --- /dev/null +++ b/src/Fedi/Routes/Notes.hs @@ -0,0 +1,51 @@ +module Fedi.Routes.Notes where + +import Data.Aeson qualified as A +import Fedi.Types +import Fedi.UserDetails +import Fedi.Routes.Helpers +import Web.Twain qualified as Twain +import Web.Twain.Types qualified as Twain + +-- * Create + +matchCreateNote :: UserDetails -> Twain.PathPattern +matchCreateNote details = fromString ("/" <> details.username <> "/notes/:note_id/create") + +handleCreateNote :: UserDetails -> [Create] -> Twain.ResponderM a +handleCreateNote details items = do + noteId <- Twain.param "note_id" + let + createUrl = + "https://" + <> details.domain + <> "/" + <> details.username + <> "/notes/" + <> noteId + <> "/create" + let + content = + find (\create -> create.id == Just (ObjectId createUrl)) items + Twain.send $ jsonLD (A.encode content) + +-- * Note + +matchNote :: UserDetails -> Twain.PathPattern +matchNote details = fromString ("/" <> details.username <> "/notes/:note_id") + +handleNote :: UserDetails -> [Note] -> Twain.ResponderM a +handleNote details items = do + noteId <- Twain.param "note_id" + let + noteUrl = + "https://" + <> details.domain + <> "/" + <> details.username + <> "/notes/" + <> noteId + let + content = + find (\note -> note.id == Just (ObjectId noteUrl)) items + Twain.send $ jsonLD (A.encode content) diff --git a/src/Fedi/Routes/Outbox.hs b/src/Fedi/Routes/Outbox.hs new file mode 100644 index 0000000..9710374 --- /dev/null +++ b/src/Fedi/Routes/Outbox.hs @@ -0,0 +1,66 @@ +module Fedi.Routes.Outbox where + +import Data.Aeson qualified as A +import Fedi.Helpers +import Fedi.Types +import Fedi.UserDetails +import Fedi.Routes.Helpers +import Web.Twain qualified as Twain +import Web.Twain.Types qualified as Twain + +-- * Outbox + +matchOutbox :: UserDetails -> Twain.PathPattern +matchOutbox details = + fromString ("/" <> details.username <> "/outbox") + +handleOutbox :: UserDetails -> [AnyActivity] -> Twain.ResponderM b +handleOutbox details items = do + isPage <- Twain.queryParamMaybe "page" + let + outboxUrl = + "https://" + <> details.domain + <> "/" + <> details.username + <> "/outbox" + response = + case isPage of + Just True -> + let + empty = emptyOrderedCollectionPage outboxUrl + content :: OutboxPage + content = + empty + { id = Just $ ObjectId $ outboxUrl <> "?page=true" + , otype = + empty.otype + { ctype = + empty.otype.ctype + { partOf = outboxUrl + , porderedItems = items + } + } + } + in + A.encode content + _ -> + let + content :: Outbox + content = + emptyOrderedCollection + { id = Just $ ObjectId outboxUrl + , summary = Just $ fromString $ details.username <> "'s notes" + , otype = + emptyOrderedCollection.otype + { ctype = + emptyOrderedCollection.otype.ctype + { orderedItems = items + } + , first = Just $ outboxUrl <> "?page=true" + , last = Just $ outboxUrl <> "?page=true" + } + } + in + A.encode content + Twain.send $ jsonLD response diff --git a/src/Fedi/Routes/User.hs b/src/Fedi/Routes/User.hs new file mode 100644 index 0000000..c76d503 --- /dev/null +++ b/src/Fedi/Routes/User.hs @@ -0,0 +1,36 @@ +module Fedi.Routes.User where + +import Data.Aeson qualified as A +import Fedi.Helpers +import Fedi.UserDetails +import Fedi.Webfinger +import Fedi.Routes.Helpers +import Web.Twain qualified as Twain +import Web.Twain.Types qualified as Twain + +-- * User + +matchUser :: UserDetails -> Twain.PathPattern +matchUser details = fromString ("/" <> details.username) + +handleUser :: UserDetails -> Twain.ResponderM a +handleUser details = do + let + content = makeActor details + Twain.send $ jsonLD (A.encode content) + +-- * Webfinger + +matchWebfinger :: Twain.PathPattern +matchWebfinger = "/.well-known/webfinger" + +handleWebfinger :: UserDetails -> Twain.ResponderM b +handleWebfinger details = do + resource <- Twain.param "resource" + let + webfinger = makeWebfinger details + if resource == ppSubject webfinger.subject + then do + Twain.send $ jsonLD (A.encode webfinger) + else do + Twain.next