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 | serve ]" , "Env vars:" , " - FEDI_PORT=" , " - FEDI_DETAILS=" , " - FEDI_CONN_STRING=" , " - FEDI_AUTH=," ] -- | 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 }