separate routes
This commit is contained in:
parent
76335812d3
commit
fa05ae4bf2
3 changed files with 111 additions and 104 deletions
105
app/Main.hs
105
app/Main.hs
|
|
@ -11,17 +11,13 @@ import Network.Wai.Middleware.RequestLogger qualified as Logger
|
||||||
import System.Environment (getArgs)
|
import System.Environment (getArgs)
|
||||||
import System.Environment (lookupEnv)
|
import System.Environment (lookupEnv)
|
||||||
import Web.Twain qualified as Twain
|
import Web.Twain qualified as Twain
|
||||||
import Fedi qualified as Fedi
|
|
||||||
import Data.Functor ((<&>))
|
import Data.Functor ((<&>))
|
||||||
import qualified Data.Text.Encoding as T
|
import qualified Data.Text.Encoding as T
|
||||||
import qualified Data.Text.IO as T
|
import qualified Data.Text.IO as T
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import System.IO.Unsafe (unsafePerformIO)
|
|
||||||
import Control.Monad.IO.Class (liftIO)
|
|
||||||
import Lucid qualified as H
|
|
||||||
|
|
||||||
import Html
|
|
||||||
import DB
|
import DB
|
||||||
|
import Routes
|
||||||
|
|
||||||
data Command
|
data Command
|
||||||
= Serve
|
= Serve
|
||||||
|
|
@ -131,102 +127,3 @@ mkFediApp connStr = do
|
||||||
pure $ foldr ($)
|
pure $ foldr ($)
|
||||||
(Twain.notFound $ Twain.send $ Twain.text "Error: not found.")
|
(Twain.notFound $ Twain.send $ Twain.text "Error: not found.")
|
||||||
(routes db detailsFile)
|
(routes db detailsFile)
|
||||||
|
|
||||||
|
|
||||||
-- * Routes
|
|
||||||
|
|
||||||
routes :: DB -> FilePath -> [Twain.Middleware]
|
|
||||||
routes db detailsFile =
|
|
||||||
[ -- Match actor
|
|
||||||
Twain.get (Fedi.matchUser $ unsafePerformIO $ fetchUserDetails detailsFile) do
|
|
||||||
request <- Twain.request
|
|
||||||
if Fedi.checkContentTypeAccept request
|
|
||||||
then do
|
|
||||||
details <- liftIO $ fetchUserDetails detailsFile
|
|
||||||
Fedi.handleUser details
|
|
||||||
else do
|
|
||||||
details <- liftIO $ fetchUserDetails detailsFile
|
|
||||||
notes <- liftIO db.getNotes
|
|
||||||
Twain.send $ Twain.html $ H.renderBS $ actorPage details notes
|
|
||||||
|
|
||||||
, -- Match outbox
|
|
||||||
Twain.get (Fedi.matchOutbox $ unsafePerformIO $ fetchUserDetails detailsFile) do
|
|
||||||
details <- liftIO $ fetchUserDetails detailsFile
|
|
||||||
notes <- map noteToCreate <$> liftIO db.getNotes
|
|
||||||
Fedi.handleOutbox details notes
|
|
||||||
|
|
||||||
, -- Match Create object
|
|
||||||
Twain.get (Fedi.matchCreate $ unsafePerformIO $ fetchUserDetails detailsFile) do
|
|
||||||
details <- liftIO $ fetchUserDetails detailsFile
|
|
||||||
notes <- map noteToCreate <$> liftIO db.getNotes
|
|
||||||
|
|
||||||
Fedi.handleCreate details notes
|
|
||||||
|
|
||||||
, -- Match Note object
|
|
||||||
Twain.get (Fedi.matchNote $ unsafePerformIO $ fetchUserDetails detailsFile) do
|
|
||||||
details <- liftIO $ fetchUserDetails detailsFile
|
|
||||||
notes <- liftIO db.getNotes
|
|
||||||
|
|
||||||
request <- Twain.request
|
|
||||||
if Fedi.checkContentTypeAccept request
|
|
||||||
then do
|
|
||||||
Fedi.handleNote details notes
|
|
||||||
else do
|
|
||||||
noteId <- Twain.param "note_id"
|
|
||||||
let
|
|
||||||
noteUrl =
|
|
||||||
"https://"
|
|
||||||
<> details.domain
|
|
||||||
<> "/"
|
|
||||||
<> details.username
|
|
||||||
<> "/notes/"
|
|
||||||
<> noteId
|
|
||||||
thenote = filter (\note -> note.id == noteUrl) notes
|
|
||||||
|
|
||||||
Twain.send $ Twain.html $ H.renderBS $ actorPage details thenote
|
|
||||||
|
|
||||||
, -- Match webfinger
|
|
||||||
Twain.get Fedi.matchWebfinger do
|
|
||||||
details <- liftIO $ fetchUserDetails detailsFile
|
|
||||||
Fedi.handleWebfinger details
|
|
||||||
|
|
||||||
, -- Admin page
|
|
||||||
Twain.get (fromString $ "/" <> (unsafePerformIO $ fetchUserDetails detailsFile).username <> "/admin") do
|
|
||||||
details <- liftIO $ fetchUserDetails detailsFile
|
|
||||||
notes <- liftIO db.getNotes
|
|
||||||
Twain.send $ Twain.html $ H.renderBS $ adminPage details notes
|
|
||||||
|
|
||||||
, -- New post
|
|
||||||
Twain.post (fromString $ "/" <> (unsafePerformIO $ fetchUserDetails detailsFile).username <> "/admin/new") do
|
|
||||||
title <- Twain.param "title"
|
|
||||||
content <- Twain.param "content"
|
|
||||||
url <- Twain.param "url"
|
|
||||||
details <- liftIO $ fetchUserDetails detailsFile
|
|
||||||
|
|
||||||
noteid <-
|
|
||||||
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))
|
|
||||||
]
|
|
||||||
|
|
||||||
trim :: String -> String
|
|
||||||
trim = unwords . words
|
|
||||||
|
|
||||||
fetchUserDetails :: FilePath -> IO Fedi.UserDetails
|
|
||||||
fetchUserDetails detailsFile =
|
|
||||||
A.eitherDecodeFileStrict detailsFile
|
|
||||||
<&> either (\err -> error $ "could not read file '" <> detailsFile <> "'.\n" <> err) id
|
|
||||||
|
|
||||||
noteToCreate :: Fedi.Note -> Fedi.Activity
|
|
||||||
noteToCreate note =
|
|
||||||
Fedi.Create
|
|
||||||
{ id =
|
|
||||||
note.id <> "/create"
|
|
||||||
, actor = note.actor
|
|
||||||
, object = Fedi.NoteObject note
|
|
||||||
}
|
|
||||||
|
|
|
||||||
109
app/Routes.hs
Normal file
109
app/Routes.hs
Normal file
|
|
@ -0,0 +1,109 @@
|
||||||
|
module Routes where
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
routes :: DB -> FilePath -> [Twain.Middleware]
|
||||||
|
routes db detailsFile =
|
||||||
|
[ -- Match actor
|
||||||
|
Twain.get (Fedi.matchUser $ unsafePerformIO $ fetchUserDetails detailsFile) do
|
||||||
|
request <- Twain.request
|
||||||
|
if Fedi.checkContentTypeAccept request
|
||||||
|
then do
|
||||||
|
details <- liftIO $ fetchUserDetails detailsFile
|
||||||
|
Fedi.handleUser details
|
||||||
|
else do
|
||||||
|
details <- liftIO $ fetchUserDetails detailsFile
|
||||||
|
notes <- liftIO db.getNotes
|
||||||
|
Twain.send $ Twain.html $ H.renderBS $ actorPage details notes
|
||||||
|
|
||||||
|
, -- Match outbox
|
||||||
|
Twain.get (Fedi.matchOutbox $ unsafePerformIO $ fetchUserDetails detailsFile) do
|
||||||
|
details <- liftIO $ fetchUserDetails detailsFile
|
||||||
|
notes <- map noteToCreate <$> liftIO db.getNotes
|
||||||
|
Fedi.handleOutbox details notes
|
||||||
|
|
||||||
|
, -- Match Create object
|
||||||
|
Twain.get (Fedi.matchCreate $ unsafePerformIO $ fetchUserDetails detailsFile) do
|
||||||
|
details <- liftIO $ fetchUserDetails detailsFile
|
||||||
|
notes <- map noteToCreate <$> liftIO db.getNotes
|
||||||
|
|
||||||
|
Fedi.handleCreate details notes
|
||||||
|
|
||||||
|
, -- Match Note object
|
||||||
|
Twain.get (Fedi.matchNote $ unsafePerformIO $ fetchUserDetails detailsFile) do
|
||||||
|
details <- liftIO $ fetchUserDetails detailsFile
|
||||||
|
notes <- liftIO db.getNotes
|
||||||
|
|
||||||
|
request <- Twain.request
|
||||||
|
if Fedi.checkContentTypeAccept request
|
||||||
|
then do
|
||||||
|
Fedi.handleNote details notes
|
||||||
|
else do
|
||||||
|
noteId <- Twain.param "note_id"
|
||||||
|
let
|
||||||
|
noteUrl =
|
||||||
|
"https://"
|
||||||
|
<> details.domain
|
||||||
|
<> "/"
|
||||||
|
<> details.username
|
||||||
|
<> "/notes/"
|
||||||
|
<> noteId
|
||||||
|
thenote = filter (\note -> note.id == noteUrl) notes
|
||||||
|
|
||||||
|
Twain.send $ Twain.html $ H.renderBS $ actorPage details thenote
|
||||||
|
|
||||||
|
, -- Match webfinger
|
||||||
|
Twain.get Fedi.matchWebfinger do
|
||||||
|
details <- liftIO $ fetchUserDetails detailsFile
|
||||||
|
Fedi.handleWebfinger details
|
||||||
|
|
||||||
|
, -- Admin page
|
||||||
|
Twain.get (fromString $ "/" <> (unsafePerformIO $ fetchUserDetails detailsFile).username <> "/admin") do
|
||||||
|
details <- liftIO $ fetchUserDetails detailsFile
|
||||||
|
notes <- liftIO db.getNotes
|
||||||
|
Twain.send $ Twain.html $ H.renderBS $ adminPage details notes
|
||||||
|
|
||||||
|
, -- New post
|
||||||
|
Twain.post (fromString $ "/" <> (unsafePerformIO $ fetchUserDetails detailsFile).username <> "/admin/new") do
|
||||||
|
title <- Twain.param "title"
|
||||||
|
content <- Twain.param "content"
|
||||||
|
url <- Twain.param "url"
|
||||||
|
details <- liftIO $ fetchUserDetails detailsFile
|
||||||
|
|
||||||
|
noteid <-
|
||||||
|
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))
|
||||||
|
]
|
||||||
|
|
||||||
|
trim :: String -> String
|
||||||
|
trim = unwords . words
|
||||||
|
|
||||||
|
fetchUserDetails :: FilePath -> IO Fedi.UserDetails
|
||||||
|
fetchUserDetails detailsFile =
|
||||||
|
A.eitherDecodeFileStrict detailsFile
|
||||||
|
<&> either (\err -> error $ "could not read file '" <> detailsFile <> "'.\n" <> err) id
|
||||||
|
|
||||||
|
noteToCreate :: Fedi.Note -> Fedi.Activity
|
||||||
|
noteToCreate note =
|
||||||
|
Fedi.Create
|
||||||
|
{ id =
|
||||||
|
note.id <> "/create"
|
||||||
|
, actor = note.actor
|
||||||
|
, object = Fedi.NoteObject note
|
||||||
|
}
|
||||||
|
|
@ -62,6 +62,7 @@ executable fedi
|
||||||
DB
|
DB
|
||||||
Html
|
Html
|
||||||
Css
|
Css
|
||||||
|
Routes
|
||||||
-- other-extensions:
|
-- other-extensions:
|
||||||
build-depends:
|
build-depends:
|
||||||
aeson
|
aeson
|
||||||
|
|
|
||||||
Loading…
Add table
Reference in a new issue