feat: Add a new primer-selda package.

Selda's back! We'll use it for SQLite support. What's changed since we
dropped it last time?

* It appears to be relatively well-maintained again.

* We're only using it for SQLite support this time.

* We're not relying on it for migrations like we used to, as we now
use Sqitch.

* Based on fairly extensive research, the other popular alternatives
for SQLite either require TemplateHaskell (Persistent), have bad
compile-time asymptotics (Beam), or are a bit too raw and not very
type-safe (sqlite-simple).

Makefile

@@ -8,6 +8,7 @@ targets = build configure check test bench generate-fixtures docs clean realclea
 $(targets):
 	$(MAKE) -C primer $@
 	$(MAKE) -C primer-rel8 $@
+	$(MAKE) -C primer-selda $@
 	$(MAKE) -C primer-service $@
 	$(MAKE) -C primer-benchmark $@
 

cabal.project

@@ -3,6 +3,7 @@ index-state: 2023-02-02T00:00:00Z
 packages:
   primer
   primer-rel8
+  primer-selda
   primer-service
   primer-benchmark
 
@@ -19,3 +20,11 @@ package primer-service
   test-options: "--size-cutoff=32768"
 
 allow-newer: logging-effect:text
+
+-- We need a newer version of Selda than what's been released to Hackage.
+source-repository-package
+  type: git
+  location: https://github.com/valderman/selda.git
+  tag: ab9619db13b93867d1a244441bb4de03d3e1dadb
+  subdir: selda
+  --sha256: 0rdpazkhx6wfxlf6izg9xzxjr9wqywzqmk0c2a23qyfvih0ylj9z

flake.nix

@@ -211,7 +211,7 @@
             };
 
           packages = {
-            inherit (pkgs) primer-service primer-openapi-spec run-primer;
+            inherit (pkgs) primer-service primer-openapi-spec run-primer primer-selda;
             inherit (pkgs) primer-benchmark;
             inherit (pkgs)
               create-local-db
@@ -386,6 +386,10 @@
                           ghcOptions = [ "-Werror" ];
                           preCheck = preCheckTasty;
                         };
+                        primer-selda = {
+                          ghcOptions = [ "-Werror" ];
+                          preCheck = preCheckTasty;
+                        };
                         primer-service = {
                           ghcOptions = [ "-Werror" ];
 
@@ -663,6 +667,8 @@
               primer-openapi = primerFlake.packages."primer-service:exe:primer-openapi";
               primer-benchmark = primerFlake.packages."primer-benchmark:bench:primer-benchmark";
 
+              primer-selda = primerFlake.packages."primer-selda:lib:primer-selda";
+
               inherit run-primer;
               inherit primer-service-docker-image;
 

hie.yaml

@@ -30,6 +30,9 @@ cradle:
     - path: "primer-rel8/test"
       component: "primer-rel8:test:primer-rel8-test"
 
+    - path: "primer-selda/src"
+      component: "lib:primer-selda"
+
     - path: "primer-service/src"
       component: "lib:primer-service"
 

primer-selda/Makefile

@@ -0,0 +1,29 @@
+# NOTE:
+#
+# Most commands assume you're running this from the top-level `nix
+# develop` shell.
+
+build:
+	cabal build
+
+configure:
+	cabal configure
+
+check:	test
+
+test:
+	cabal test
+
+docs:
+	cabal haddock
+
+clean:
+	cabal clean
+
+bench:
+
+realclean:
+
+deps:
+
+.PHONY: build bench configure test docs clean realclean deps

primer-selda/primer-selda.cabal

@@ -0,0 +1,40 @@
+cabal-version: 3.0
+name:          primer-selda
+version:       0.7.2.0
+license:       AGPL-3.0-or-later
+license-file:  COPYING
+copyright:     (c) 2023 Hackworth Ltd
+maintainer:    [email protected]
+author:        Hackworth Ltd <[email protected]>
+stability:     experimental
+synopsis:      Selda bindings for the Primer database
+category:      Database
+
+library
+  exposed-modules:    Primer.Database.Selda
+  hs-source-dirs:     src
+  default-language:   GHC2021
+  default-extensions:
+    NoImplicitPrelude
+    DataKinds
+    DeriveAnyClass
+    DerivingStrategies
+    DerivingVia
+    LambdaCase
+    OverloadedStrings
+
+  ghc-options:
+    -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates
+    -Wcompat -Widentities -Wredundant-constraints
+    -Wmissing-deriving-strategies -fhide-source-paths
+
+  build-depends:
+    , aeson       >=2.0      && <2.2
+    , base        >=4.12     && <4.17.0
+    , bytestring  >=0.10.8.2 && <0.12.0
+    , containers  >=0.6.0.1  && <0.7.0
+    , primer      ^>=0.7.2
+    , selda       ^>=0.5.2.1
+    , text        ^>=2.0
+    , time        ^>=1.11
+    , uuid        ^>=1.3.15

primer-selda/src/Primer/Database/Selda.hs

@@ -0,0 +1,165 @@
+{-# LANGUAGE OverloadedLabels #-}
+-- Note: this is on purpose. See 'MonadDb' instance below.
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Primer.Database.Selda (
+  MonadDb (..),
+  sessions, -- exported for testing
+  SessionRow (..), -- exported for testing
+) where
+
+import Foreword hiding ((:*:))
+
+import Data.Aeson qualified as Aeson (
+  decode,
+  encode,
+ )
+import Data.ByteString.Lazy as BL hiding (take)
+import Data.Time.Clock (UTCTime)
+import Data.UUID (UUID)
+import Database.Selda (
+  Assignment ((:=)),
+  Attr ((:-)),
+  SeldaM,
+  SqlRow,
+  Table,
+  ascending,
+  deleteFrom,
+  insert_,
+  literal,
+  order,
+  primary,
+  query,
+  restrict,
+  select,
+  table,
+  update_,
+  with,
+  (!),
+  (.==),
+  (:*:) (..),
+ )
+import Database.Selda qualified as Selda
+import Primer.Database (
+  DbError (AppDecodingError, SessionIdNotFound),
+  LastModified (..),
+  MonadDb (..),
+  OffsetLimit (limit, offset),
+  Page (Page, pageContents, total),
+  Session (Session),
+  SessionData (..),
+  Version,
+  fromSessionName,
+  safeMkSessionName,
+ )
+
+-- | A database session table row.
+--
+-- This table is effectively just a key-value store, where the
+-- session's UUID is the primary key and the value is a record
+-- consisting of the session's 'App', the git version of Primer that
+-- last updated it, and the session's name.
+data SessionRow = SessionRow
+  { uuid :: UUID
+  -- ^ The session's UUID.
+  , gitversion :: Version
+  -- ^ Primer's git version. We would prefer that this were a git
+  -- rev, but for technical reasons, it may also be a last-modified
+  -- date.
+  , app :: BL.ByteString
+  -- ^ The session's 'App'. Note that the 'App' is serialized to
+  -- JSON before being stored as a bytestring in the database.
+  , name :: Text
+  -- ^ The session's name.
+  , lastmodified :: UTCTime
+  -- ^ The session's last modified time.
+  --
+  -- This should be of type 'SessionName', but Selda doesn't make it
+  -- particularly easy to derive @SqlType@ from a newtype wrapper
+  -- around 'Text', so rather than copy-pasting the 'Text' instance,
+  -- we just convert back to 'Text' before serializing to the
+  -- database.
+  }
+  deriving stock (Generic)
+
+instance SqlRow SessionRow
+
+-- | The database's sessions table.
+sessions :: Table SessionRow
+sessions = table "sessions" [#uuid :- primary]
+
+-- | A 'MonadDb' instance for 'SeldaM'.
+--
+-- Note: this is purposely an orphan instance, and it should be fine,
+-- since this is the canonical implementation, and is simply factored
+-- out of the core Primer package for technical reasons.
+instance MonadDb (SeldaM b) where
+  insertSession v s a n t =
+    insert_ sessions [SessionRow s v (Aeson.encode a) (fromSessionName n) (utcTime t)]
+
+  updateSessionApp v s a t =
+    update_
+      sessions
+      (\session -> session ! #uuid .== literal s)
+      (\session -> session `with` [#gitversion := literal v, #app := literal (Aeson.encode a), #lastmodified := literal (utcTime t)])
+
+  updateSessionName v s n t =
+    update_
+      sessions
+      (\session -> session ! #uuid .== literal s)
+      (\session -> session `with` [#gitversion := literal v, #name := literal (fromSessionName n), #lastmodified := literal (utcTime t)])
+
+  listSessions ol = do
+    n' <- query $
+      Selda.aggregate $ do
+        session <- select sessions
+        pure $ Selda.count $ session ! #uuid
+    let n = case n' of
+          [n''] -> n''
+          -- something has gone terribly wrong: selda will return a singleton
+          -- for a 'count' query. For now, return a default value.
+          -- TODO: this should log an error and cause a HTTP 5xx code to be,
+          -- returned. See https://github.com/hackworthltd/primer/issues/179
+          _ -> 0
+    ss <- query $
+      Selda.limit (offset ol) (fromMaybe n $ limit ol) $ do
+        session <- select sessions
+        order (session ! #uuid) ascending
+        pure (session ! #uuid :*: session ! #name :*: session ! #lastmodified)
+    pure $ Page{total = n, pageContents = safeMkSession <$> ss}
+    where
+      -- See comment in 'querySessionId' re: dealing with invalid
+      -- session names loaded from the database.
+      safeMkSession (s :*: n :*: t) = Session s (safeMkSessionName n) (LastModified t)
+
+  -- Note: we ignore the stored Primer version for now.
+  querySessionId sid = do
+    result <- query $ do
+      session <- select sessions
+      restrict (session ! #uuid .== literal sid)
+      pure (session ! #gitversion :*: session ! #app :*: session ! #name :*: session ! #lastmodified)
+    case result of
+      [] -> pure $ Left $ SessionIdNotFound sid
+      (_ :*: bs :*: n :*: t) : _ ->
+        case Aeson.decode bs of
+          Nothing -> pure $ Left $ AppDecodingError sid
+          Just decodedApp -> do
+            -- Note that we have 2 choices here if @n@ is not a valid
+            -- 'SessionName': either we can return a failure, or we
+            -- can convert it to a valid 'SessionName', possibly
+            -- including a helpful message. This situation can only
+            -- ever happen if we've made a mistake (e.g., we've
+            -- changed the rules on what's a valid 'SessionName' and
+            -- didn't run a migration), or if someone has edited the
+            -- database directly, without going through the API. In
+            -- either case, it would be bad if a student can't load
+            -- their session just because a session name was invalid,
+            -- so we opt for "convert it to a valid 'SessionName'".
+            -- For now, we elide the helpful message.
+            pure $ Right (SessionData decodedApp (safeMkSessionName n) (LastModified t))
+
+  deleteSession sid = do
+    n <- deleteFrom sessions (\session -> session ! #uuid .== literal sid)
+    case n of
+      0 -> pure $ Left $ SessionIdNotFound sid
+      _ -> pure $ Right ()

primer/src/Primer/Database.hs

@@ -367,6 +367,9 @@ data DbError
   = -- | A database operation failed because the given 'SessionId'
     -- wasn't found in the database.
     SessionIdNotFound SessionId
+  | -- | A database operation failed because the stored 'App' couldn't
+    -- be decoded.
+    AppDecodingError SessionId
   deriving stock (Eq, Show, Generic)
 
 -- | A "null" database type with no persistent backing store.
@@ -513,6 +516,8 @@ serve (ServiceCfg q v) =
           case queryResult of
             Left (SessionIdNotFound s) ->
               pure $ Failure $ "Couldn't load the requested session: no such session ID " <> UUID.toText s
+            Left (AppDecodingError s) ->
+              pure $ Failure $ "Couldn't load the requested session: couldn't decode the app for session ID " <> UUID.toText s
             Right sd -> do
               liftIO $ atomically $ StmMap.insert sd sid memdb
               pure Success
@@ -525,4 +530,9 @@ serve (ServiceCfg q v) =
           case deletionResult of
             Left (SessionIdNotFound s) ->
               pure $ Failure $ "Couldn't delete the requested session: no such session ID " <> UUID.toText s
+            Left (AppDecodingError s) ->
+              -- This seems very unlikely to happen, as it's hard to
+              -- imagine not being able to delete a session because
+              -- its app couldn't be decoded.
+              pure $ Failure $ "Couldn't delete the requested session: couldn't decode the app for session ID " <> UUID.toText s
             Right _ -> pure Success