use sqlite and create an app

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)

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
+  command <- getArgs >>= \case
-    [] -> pure ()
+    ["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 <FILE> | serve ]"
     , "Env vars:"
     , " - FEDI_PORT=<PORT>"
     , " - FEDI_DETAILS=<FILE>"
+    , " - FEDI_CONN_STRING=<SQLITE_CONN_STR>"
+    , " - FEDI_CONN_STRING=<SQLITE_CONN_STR>"
+    , " - FEDI_AUTH=<user>,<password>"
     ]
 
 -- | Run server at at specific port.
-runServer :: Port -> Twain.Application -> IO ()
+runServer :: Port -> Twain.Middleware -> Twain.Application -> IO ()
-runServer port app = do
+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 :: Sqlite.ConnectionString -> IO Twain.Application
-mkFediApp = do
+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
+      }

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

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

src/Fedi/Actor.hs

@@ -31,18 +31,17 @@ data PublicKey
 makeActor :: UserDetails -> Actor
 makeActor details =
   let
-    url = "https://" <> details.domain
+    actor = actorUrl details
-    actorUrl = url <> "/" <> details.username
   in Actor
-    { id = actorUrl
+    { id = actor
     , name = details.name
     , preferredUsername = details.username
     , summary = details.summary
     , icon = details.icon
     , publicKey =
       PublicKey
-        { id = actorUrl <> "#main-key"
+        { id = actor <> "#main-key"
-        , owner = actorUrl
+        , owner = actor
         , publicKeyPem = details.publicPem
         }
     }

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

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