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 (lookupEnv)
|
||||
import Web.Twain qualified as Twain
|
||||
import Fedi qualified as Fedi
|
||||
import Data.Functor ((<&>))
|
||||
import qualified Data.Text.Encoding as T
|
||||
import qualified Data.Text.IO 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 Routes
|
||||
|
||||
data Command
|
||||
= Serve
|
||||
|
|
@ -131,102 +127,3 @@ mkFediApp connStr = do
|
|||
pure $ foldr ($)
|
||||
(Twain.notFound $ Twain.send $ Twain.text "Error: not found.")
|
||||
(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
|
||||
Html
|
||||
Css
|
||||
Routes
|
||||
-- other-extensions:
|
||||
build-depends:
|
||||
aeson
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue