fedi/app/Main.hs

module Main where

import Data.SecureMem (secureMemFromByteString)
import Data.String (fromString)
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.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 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

data Command
  = Serve
  | Insert FilePath

main :: IO ()
main = do
  command <- getArgs >>= \case
    ["insert", file] -> pure (Insert file)
    ["serve"] -> pure Serve
    _ -> usageError

  case command of
    Insert file -> do
      insertNoteFromFile file
    Serve ->
      serve

insertNoteFromFile :: FilePath -> IO ()
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

  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
    }

  putStrLn "Inserted."
  print note


serve :: IO ()
serve = do
  auth <- fmap (T.splitOn "," . T.pack) <$> lookupEnv "FEDI_AUTH"
  authMiddleware <-
    case auth of
      Nothing -> do
        putStrLn "Starting server with authentication disabled."
        pure id
      Just [user, pass] -> do
        putStrLn "Starting server with authentication enabled,"
        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

  fediPort <- maybe 3001 read <$> lookupEnv "FEDI_PORT"
  conn <- maybe "/tmp/fediserve_sqlite_db.sqlite" fromString <$> lookupEnv "FEDI_CONN_STRING"
  putStrLn $ "and with connection string " <> show (Sqlite.unConnectionString conn) <> "."

  runServer fediPort authMiddleware =<< mkFediApp conn

usageError :: err
usageError =
  errorWithoutStackTrace $ unlines
    [ "Usage: fedi [ insert <FILE> | serve ]"
    , "Env vars:"
    , " - FEDI_PORT=<PORT>"
    , " - FEDI_DETAILS=<FILE>"
    , " - FEDI_CONN_STRING=<SQLITE_CONN_STR>"
    , " - FEDI_AUTH=<user>,<password>"
    ]

-- | 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)"
    ]
  auth <- Wai.routedMiddleware matchAdmin <$> pure authMiddleware
  run port (Logger.logStdoutDev $ auth app)


matchAdmin :: [T.Text] -> Bool
matchAdmin = any (=="admin")

-- | Application description.
mkFediApp :: Sqlite.ConnectionString -> IO Twain.Application
mkFediApp connStr = do
  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

  db <- mkDB connStr details

  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
      }