diff --git a/app/DB.hs b/app/DB.hs new file mode 100644 index 0000000..2779435 --- /dev/null +++ b/app/DB.hs @@ -0,0 +1,165 @@ +-- | Database interaction +module DB where + +import GHC.Stack (HasCallStack) +import Data.Text qualified as T +import Database.Sqlite.Easy qualified as DB +import Text.RawString.QQ +import Fedi + +----------------------- +-- * Database handler API + +data DB + = DB + { getNotes :: IO [Note] + , insertNote :: NoteEntry -> IO () + } + +-- * Data types + +data NoteEntry + = NoteEntry + { inReplyTo :: Maybe Url + , content :: T.Text + , name :: Maybe String + , url :: Maybe Url + } + +----------------------- +-- * Handler smart constructor + +mkDB :: DB.ConnectionString -> UserDetails -> IO DB +mkDB connstr details = do + pool <- DB.createSqlitePool connstr + DB.withPool pool runMigrations + pure DB + { getNotes = + DB.withPool pool (getNotesFromDb $ actorUrl details) + , insertNote = + \note -> DB.withPool pool (insertNoteToDb (actorUrl details) note) + } + +----------------------- +-- * Database migrations + +runMigrations :: HasCallStack => DB.SQLite () +runMigrations = DB.migrate migrations migrateUp migrateDown + +migrations :: [DB.MigrationName] +migrations = + [ "note" + ] + +migrateUp :: HasCallStack => DB.MigrationName -> DB.SQLite () +migrateUp = \case + "note" -> do + [] <- DB.run + [r| create table note( + id integer primary key autoincrement, + published datetime default (datetime('now')), + actor text not null, + content text not null, + name text, + inReplyTo text, + url text + ) + |] + + pure () + + name -> error $ "unexpected migration: " <> show name + +migrateDown :: HasCallStack => DB.MigrationName -> DB.SQLite () +migrateDown = \case + "notes" -> do + [] <- DB.run "DROP TABLE note" + pure () + name -> error $ "unexpected migration: " <> show name + +----------------------- +-- * Database actions + +getNotesFromDb :: Url -> DB.SQLite [Note] +getNotesFromDb url = + map decodeNoteRow <$> uncurry DB.runWith (getNotesSQL url) + +insertNoteToDb :: Url -> NoteEntry -> DB.SQLite () +insertNoteToDb actor note = do + _ <- uncurry DB.runWith (insertNoteSQL actor note) + pure () + +-- ** SQL + +getNotesSQL :: Url -> (DB.SQL, [DB.SQLData]) +getNotesSQL url = + ( [r| + SELECT + ? || '/notes/' || id, + published, + actor, + content, + name, + inReplyTo, + url + FROM note + ORDER BY published DESC + |] + , [DB.SQLText $ T.pack url] + ) + +insertNoteSQL :: Url -> NoteEntry -> (DB.SQL, [DB.SQLData]) +insertNoteSQL actor note = + ( [r| + INSERT INTO note(actor, inReplyTo, content, name, url) + VALUES (?, ?, ?, ?, ?) + |] + , [ DB.SQLText (T.pack actor) + , toNullableString note.inReplyTo + , DB.SQLText note.content + , toNullableString note.name + , toNullableString note.url + ] + ) + +----------------------- +-- ** Decode row + +decodeNoteRow :: [DB.SQLData] -> Note +decodeNoteRow = \case + [ DB.SQLText noteid, + DB.SQLText published, + DB.SQLText actor, + DB.SQLText content, + nullableString -> Just name, + nullableString -> Just inReplyTo, + nullableString -> Just url + ] -> + Note + { id = T.unpack noteid + , published = read (T.unpack published) + , actor = T.unpack actor + , inReplyTo = inReplyTo + , content = content + , url = url + , name = name + , replies = Collection + { id = T.unpack noteid <> "/replies" + , summary = "Replies" + , items = [] + , first = Nothing + , last = Nothing + } + } + row -> error $ "Couldn't decode row as Note: " <> show row + +nullableString :: DB.SQLData -> Maybe (Maybe String) +nullableString = \case + DB.SQLText text -> Just (Just $ T.unpack text) + DB.SQLNull -> Just Nothing + _ -> Nothing + +toNullableString :: Maybe String -> DB.SQLData +toNullableString = \case + Nothing -> DB.SQLNull + Just str -> DB.SQLText (T.pack str) diff --git a/app/Main.hs b/app/Main.hs index a5f464a..886c329 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,49 +1,172 @@ 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.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 DB + +data Command + = Serve + | Insert FilePath main :: IO () main = do - getArgs >>= \case - [] -> pure () + 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/jot_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 + + db.insertNote NoteEntry + { content = content + , inReplyTo = Nothing + , name = Nothing + , url = Nothing + } + + +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 Jot" + Just{} -> usageError + fediPort <- maybe 3001 read <$> lookupEnv "FEDI_PORT" - runServer fediPort =<< mkFediApp + conn <- maybe "/tmp/jot_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" + [ "Usage: fedi [ insert | serve ]" , "Env vars:" , " - FEDI_PORT=" , " - FEDI_DETAILS=" + , " - FEDI_CONN_STRING=" + , " - FEDI_CONN_STRING=" + , " - FEDI_AUTH=," ] -- | Run server at at specific port. -runServer :: Port -> Twain.Application -> IO () -runServer port app = do +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)" ] - run port (Logger.logStdoutDev app) + run port (Logger.logStdoutDev $ authMiddleware app) -- | Application description. -mkFediApp :: IO Twain.Application -mkFediApp = do +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.") - (Fedi.routes details) + (routes db detailsFile) + + +-- * Routes + +routes :: DB -> FilePath -> [Twain.Middleware] +routes db detailsFile = + [ -- Match actor + Twain.get (Fedi.matchUser $ unsafePerformIO $ fetchUserDetails detailsFile) do + details <- liftIO $ fetchUserDetails detailsFile + Fedi.handleUser details + + , -- 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 <- map noteToCreate <$> liftIO db.getNotes + Fedi.handleNote details notes + + , -- Match webfinger + Twain.get Fedi.matchWebfinger do + details <- liftIO $ fetchUserDetails detailsFile + Fedi.handleWebfinger details + ] + +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 + } diff --git a/fedi.cabal b/fedi.cabal index 0f0bb1f..ce8bd57 100644 --- a/fedi.cabal +++ b/fedi.cabal @@ -58,7 +58,8 @@ library executable fedi import: warnings main-is: Main.hs - -- other-modules: + other-modules: + DB -- other-extensions: build-depends: aeson @@ -69,6 +70,9 @@ executable fedi , warp , twain , text + , sqlite-easy + , raw-strings-qq + , securemem hs-source-dirs: app default-language: GHC2021 @@ -78,4 +82,7 @@ executable fedi OverloadedRecordDot OverloadedStrings QuasiQuotes + ViewPatterns + DuplicateRecordFields + NoFieldSelectors ghc-options: -Wall -O -threaded -rtsopts -with-rtsopts=-N diff --git a/src/Fedi/Activity.hs b/src/Fedi/Activity.hs index 8b7162e..12efa66 100644 --- a/src/Fedi/Activity.hs +++ b/src/Fedi/Activity.hs @@ -30,6 +30,7 @@ data Note = Note { id :: NoteId , published :: UTCTime + , inReplyTo :: Maybe Url , actor :: ActorId , content :: T.Text , name :: Maybe String @@ -74,7 +75,7 @@ instance A.ToJSON Note where , "id" A..= note.id , "type" A..= ("Note" :: String) , "summary" A..= (Nothing :: Maybe String) - , "inReplyTo" A..= (Nothing :: Maybe String) + , "inReplyTo" A..= note.inReplyTo , "published" A..= note.published , "attributedTo" A..= note.actor , "content" A..= note.content diff --git a/src/Fedi/Actor.hs b/src/Fedi/Actor.hs index 2cf816c..f194043 100644 --- a/src/Fedi/Actor.hs +++ b/src/Fedi/Actor.hs @@ -31,18 +31,17 @@ data PublicKey makeActor :: UserDetails -> Actor makeActor details = let - url = "https://" <> details.domain - actorUrl = url <> "/" <> details.username + actor = actorUrl details in Actor - { id = actorUrl + { id = actor , name = details.name , preferredUsername = details.username , summary = details.summary , icon = details.icon , publicKey = PublicKey - { id = actorUrl <> "#main-key" - , owner = actorUrl + { id = actor <> "#main-key" + , owner = actor , publicKeyPem = details.publicPem } } diff --git a/src/Fedi/Routes.hs b/src/Fedi/Routes.hs index f805139..2eb36ae 100644 --- a/src/Fedi/Routes.hs +++ b/src/Fedi/Routes.hs @@ -42,19 +42,20 @@ jsonLD = -- * Create matchCreate :: UserDetails -> Twain.PathPattern -matchCreate details = fromString ("/" <> details.username <> "/notes/create/:create_id") +matchCreate details = fromString ("/" <> details.username <> "/notes/:note_id/create") handleCreate :: UserDetails -> [Activity] -> Twain.ResponderM a handleCreate details items = do - noteId <- Twain.param "create_id" + noteId <- Twain.param "note_id" let createUrl = "https://" <> details.domain <> "/" <> details.username - <> "/notes/create/" + <> "/notes/" <> noteId + <> "/create" let content = find (\create -> create.id == createUrl) items diff --git a/src/Fedi/Types.hs b/src/Fedi/Types.hs index 2a99850..d303596 100644 --- a/src/Fedi/Types.hs +++ b/src/Fedi/Types.hs @@ -39,3 +39,7 @@ data UserDetails , privatePem :: FilePath } deriving (Generic, A.FromJSON) + +actorUrl :: UserDetails -> Url +actorUrl details = + "https://" <> details.domain <> "/" <> details.username