feat: Add a Rel8 PostgreSQL adapter.

This will replace the Selda adapter in a subsequent commit. Tests are
forthcoming.

Notes:

- Rel8 communicates with the PostgreSQL database via Hasql, and Hasql
bubbles up database exceptions to the caller in-band via `Either`. We
want to handle these out-of-band, so we throw them to the creator of
the database thread, who presumably knows more about Hasql than core
Primer.

- Unlike Selda, Rel8 does not include support for creating tables.
This is possible in Hasql, but most best SQL practice seems to
recommend that schemas are created, migrated, etc. with a separate
tool. Therefore, I have not added an `initialize` action here to
mirror the one in our Selda adapter. Instead, we'll add support for
schema management in separate work.

Makefile

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

cabal.project

@@ -2,6 +2,7 @@ index-state: 2021-11-04T00:00:00Z
 
 packages:
   primer
+  primer-rel8
   primer-selda
   primer-service
 

flake.nix

@@ -78,6 +78,7 @@
                   # We want -Werror for Nix builds (primarily for CI).
                   packages = {
                     primer.ghcOptions = [ "-Werror" ];
+                    primer-rel8.ghcOptions = [ "-Werror" ];
                     primer-selda.ghcOptions = [ "-Werror" ];
                     primer-service.ghcOptions = [ "-Werror" ];
                   };
@@ -97,9 +98,10 @@
                   doHoogle = true;
                 }
                 {
-                  # mtl-compat doesn't generate HIE files.
+                  # These packages don't generate HIE files. See:
                   # https://github.com/input-output-hk/haskell.nix/issues/1242
                   packages.mtl-compat.writeHieFiles = false;
+                  packages.bytestring-builder.writeHieFiles = false;
                 }
                 {
                   #TODO This shouldn't be necessary - see the commented-out `build-tool-depends` in primer.cabal.

hie.yaml

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

primer-rel8/Makefile

@@ -0,0 +1,27 @@
+# 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
+
+realclean:
+
+deps:
+
+.PHONY: build configure test docs clean realclean deps

primer-rel8/primer-rel8.cabal

@@ -0,0 +1,51 @@
+cabal-version: 2.4
+name:          primer-rel8
+version:       0.7.0.0
+license:       AGPL-3.0-or-later
+license-file:  COPYING
+copyright:     (c) 2021 Hackworth Ltd
+maintainer:    [email protected]
+author:        Hackworth Ltd <[email protected]>
+stability:     experimental
+synopsis:      Rel8 bindings for the Primer database
+category:      Database
+
+library
+  exposed-modules:
+    Primer.Database.Rel8
+    Primer.Database.Rel8.Rel8Db
+    Primer.Database.Rel8.Schema
+
+  hs-source-dirs:     src
+  default-language:   Haskell2010
+  default-extensions:
+    NoImplicitPrelude
+    DataKinds
+    DeriveDataTypeable
+    DeriveGeneric
+    DerivingStrategies
+    DerivingVia
+    FlexibleContexts
+    FlexibleInstances
+    GeneralizedNewtypeDeriving
+    LambdaCase
+    MultiParamTypeClasses
+    OverloadedStrings
+    ScopedTypeVariables
+
+  ghc-options:
+    -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates
+    -Wcompat -Widentities -Wredundant-constraints -fhide-source-paths
+
+  build-depends:
+    , aeson       >=1.5.2.0  && <=2.1
+    , base        >=4.12     && <=4.17
+    , bytestring  >=0.10.8.2 && <=0.12
+    , containers  >=0.6.0.1  && <=0.7
+    , exceptions  ^>=0.10.4
+    , hasql       ^>=1.4.5.3
+    , mtl         ^>=2.2.2
+    , primer      ^>=0.7
+    , rel8        ^>=1.1
+    , text        >=1.2.3.2  && <=1.3
+    , uuid        ^>=1.3

primer-rel8/src/Primer/Database/Rel8.hs

@@ -0,0 +1,7 @@
+module Primer.Database.Rel8 (
+  module Schema,
+  module Rel8Db,
+) where
+
+import Primer.Database.Rel8.Rel8Db as Rel8Db
+import Primer.Database.Rel8.Schema as Schema

primer-rel8/src/Primer/Database/Rel8/Rel8Db.hs

@@ -0,0 +1,261 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+-- Note: this is on purpose. See 'MonadDb' instance below.
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Primer.Database.Rel8.Rel8Db (
+  Rel8DbT (..),
+  Rel8Db,
+) where
+
+import Foreword hiding (filter)
+
+import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow, throwM)
+import Control.Monad.Cont (MonadCont)
+import Control.Monad.Fix (MonadFix)
+import Control.Monad.Trans (MonadTrans)
+import Control.Monad.Writer (MonadWriter)
+import Control.Monad.Zip (MonadZip)
+import qualified Data.Aeson as Aeson (
+  decode,
+  encode,
+ )
+import Data.Functor.Contravariant ((>$<))
+import Data.UUID (UUID)
+import qualified Data.UUID as UUID (toText)
+import Hasql.Connection (Connection)
+import Hasql.Session (run, statement)
+import Hasql.Statement (Statement)
+import Primer.Database (
+  MonadDb (..),
+  OffsetLimit (OL),
+  Page (Page, pageContents, total),
+  Session (Session),
+  SessionData (..),
+  fromSessionName,
+  safeMkSessionName,
+ )
+import Rel8 (
+  Expr,
+  Insert (Insert, into, onConflict, returning, rows),
+  OnConflict (Abort),
+  Query,
+  Returning (NumberOfRowsAffected),
+  Update (Update, from, returning, set, target, updateWhere),
+  asc,
+  countRows,
+  each,
+  filter,
+  insert,
+  limit,
+  lit,
+  litExpr,
+  offset,
+  orderBy,
+  select,
+  update,
+  values,
+  (==.),
+ )
+
+import Primer.Database.Rel8.Schema as Schema (
+  SessionRow (..),
+  sessionRowSchema,
+ )
+
+-- | A wrapper type for managing Rel8 operations.
+newtype Rel8DbT m a = Rel8DbT {unRel8DbT :: ReaderT Connection m a}
+  deriving
+    ( Functor
+    , Applicative
+    , Alternative
+    , Monad
+    , MonadError e
+    , MonadThrow
+    , MonadCatch
+    , MonadMask
+    , MonadReader Connection
+    , MonadIO
+    , MonadFail
+    , MonadFix
+    , MonadPlus
+    , MonadTrans
+    , MonadState s
+    , MonadWriter w
+    , MonadZip
+    , MonadCont
+    )
+
+-- | The 'Rel8DbT' monad transformer applied to 'IO'.
+type Rel8Db a = Rel8DbT IO a
+
+-- | A 'MonadDb' instance for 'Rel8DbT'.
+--
+-- This monad throws unexpected exceptions via its 'MonadThrow'
+-- instance. Unexpected exceptions include any database errors raised
+-- by "Hasql.Session". It's the responsibility of the caller to handle
+-- them, as opposed to run-of-the-mill exceptions that may occur;
+-- e.g., looking up a session ID that doesn't exist in the database.
+-- The latter sorts of exceptions are expressed via the types of the
+-- 'MonadDb' methods and are handled by Primer internally.
+--
+-- 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 (MonadThrow m, MonadIO m) => MonadDb (Rel8DbT m) where
+  insertSession v s a n =
+    runStatement_ $
+      insert
+        Insert
+          { into = Schema.sessionRowSchema
+          , rows =
+              values
+                [ lit
+                    Schema.SessionRow
+                      { Schema.uuid = s
+                      , Schema.gitversion = v
+                      , Schema.app = Aeson.encode a
+                      , Schema.name = fromSessionName n
+                      }
+                ]
+          , onConflict = Abort
+          , returning = NumberOfRowsAffected
+          }
+  updateSessionApp v s a =
+    runStatement_ $
+      update
+        Update
+          { target = Schema.sessionRowSchema
+          , from = allSessions
+          , set = \_ row ->
+              row
+                { Schema.gitversion = lit v
+                , Schema.app = lit (Aeson.encode a)
+                }
+          , updateWhere = \_ row -> Schema.uuid row ==. litExpr s
+          , returning = NumberOfRowsAffected
+          }
+  updateSessionName v s n =
+    runStatement_ $
+      update
+        Update
+          { target = Schema.sessionRowSchema
+          , from = allSessions
+          , set = \_ row ->
+              row
+                { Schema.gitversion = lit v
+                , Schema.name = lit $ fromSessionName n
+                }
+          , updateWhere = \_ row -> Schema.uuid row ==. litExpr s
+          , returning = NumberOfRowsAffected
+          }
+  listSessions ol = do
+    n' <- runStatement $ select numSessions
+    let n = case n' of
+          -- Currently, our page size is 'Int', but Rel8 gives
+          -- 'Int64'. This needs fixing, but has implications for API
+          -- clients, so for now we downcast, as we will not hit 2
+          -- billion rows anytime soon. See:
+          -- https://github.com/hackworthltd/primer/issues/238
+          [n''] -> fromIntegral n''
+          -- This case should never occur, as 'numSessions' should
+          -- always return a number equal to or greater than '0' (per
+          -- the Rel8 documentation). However, we have no good way to
+          -- express this invariant in the type, so we handle this
+          -- case with a default value of '0'.
+          --
+          -- TODO: this should log an error and cause an HTTP 5xx code
+          -- to be returned. See:
+          -- https://github.com/hackworthltd/primer/issues/179
+          _ -> 0
+    ss :: [(UUID, Text)] <- runStatement $ select $ paginatedSessionMeta ol
+    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) = Session s (safeMkSessionName n)
+
+  -- Note: we ignore the stored Primer version for now.
+  querySessionId _ sid = do
+    result <- runStatement $ select $ sessionById sid
+    case result of
+      [] -> return $ Left $ "No such session ID " <> UUID.toText sid
+      (s : _) ->
+        case Aeson.decode (Schema.app s) of
+          Nothing -> pure $ Left $ "Failed to decode stored program for session ID " <> UUID.toText sid
+          Just decodedApp -> do
+            -- Note that we have 2 choices here if the session name
+            -- returned by the database 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 the "convert it
+            -- to a valid 'SessionName'" strategy. For now, we elide
+            -- the helpful message.
+            --
+            -- We should probably log an event when this occurs. See:
+            -- https://github.com/hackworthltd/primer/issues/179
+            pure $ Right (SessionData decodedApp (safeMkSessionName $ Schema.name s))
+
+-- Helper to make dealing with "Hasql.Session" easier.
+--
+-- See the note on 'Rel8DbT's 'MonadDb' instance for an explanation of
+-- why we handle "Hasql.Session" exceptions the way we do.
+runStatement :: (MonadIO m, MonadThrow m, MonadReader Connection m) => Statement () a -> m a
+runStatement s = do
+  conn <- ask
+  result <- liftIO $ flip run conn $ statement () s
+  case result of
+    Left e ->
+      -- Something went wrong with the database or database
+      -- connection. This is the responsibility of the caller to
+      -- handle.
+      throwM e
+    Right r -> pure r
+
+-- As 'runStatement', except this discards the result.
+runStatement_ :: (MonadIO m, MonadThrow m, MonadReader Connection m) => Statement () a -> m ()
+runStatement_ = void . runStatement
+
+-- "Rel8" queries and other operations.
+
+-- All sessions in the database.
+allSessions :: Query (Schema.SessionRow Expr)
+allSessions = each Schema.sessionRowSchema
+
+-- Select a session by session ID. The session ID is unique, so this
+-- should only return at most 1 session, though Hasql's types are not
+-- robust enough to represent this invariant.
+sessionById :: UUID -> Query (Schema.SessionRow Expr)
+sessionById sid =
+  allSessions >>= filter \p -> Schema.uuid p ==. litExpr sid
+
+-- Return the number of sessions in the database.
+numSessions :: Query (Expr Int64)
+numSessions = countRows allSessions
+
+-- Paginate a query.
+--
+-- Note: the order of operations here is important.
+--
+-- TODO: review use of 'fromIntegral' here and
+-- https://github.com/hackworthltd/primer/issues/238
+paginate :: OffsetLimit -> Query a -> Query a
+paginate (OL o (Just l)) = limit (fromIntegral l) . offset (fromIntegral o)
+paginate (OL o _) = offset (fromIntegral o)
+
+-- Return the metadata (represented as a tuple) for all sessions in
+-- the database.
+sessionMeta :: Query (Expr UUID, Expr Text)
+sessionMeta = do
+  s <- allSessions
+  return (Schema.uuid s, Schema.name s)
+
+-- Paginated session metadata, sorted by session name.
+paginatedSessionMeta :: OffsetLimit -> Query (Expr UUID, Expr Text)
+paginatedSessionMeta ol = paginate ol $ orderBy (snd >$< asc) sessionMeta