fedi/src/Fedi/Routes.hs

module Fedi.Routes 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

-- * Routes

routes :: UserDetails -> [Twain.Middleware]
routes details =
  [ Twain.get (matchUser details) do
      handleUser details
  , Twain.get (matchOutbox details) do
      handleOutbox details []
  , Twain.get (matchCreateNote details) do
      handleCreateNote details []
  , Twain.get (matchNote details) do
      handleNote details []
  , -- , Twain.post (matchInbox details) do
    --   handleInbox details undefined

    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 :: 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/ld+json" `BS.isInfixOf` bs)
              && ("profile=\"https://www.w3.org/ns/activitystreams\"" `BS.isInfixOf` bs)
           )
    Nothing -> False