chore(users/Profpatsch/cas-serve): remove dependency on superrecord

The use of superrecord here can be replaced by simple labelled tuples.

Change-Id: I23690cd0b88896440521fe81e83347ef4773d4a0
Reviewed-on: https://cl.tvl.fyi/c/depot/+/7713
Reviewed-by: sterni <sternenseemann@systemli.org>
Autosubmit: Profpatsch <mail@profpatsch.de>
Reviewed-by: Profpatsch <mail@profpatsch.de>
Tested-by: BuildkiteCI

third_party/overlays/haskell/default.nix

@@ -30,20 +30,6 @@ in
       dhall = dhall-source "dhall" hsSuper.dhall;
       dhall-nix = dhall-source "dhall-nix" hsSuper.dhall-nix;
 
-      # TODO(Profpatsch): move cas-serve off superrecord
-      # https://github.com/agrafix/superrecord/pull/35
-      # https://github.com/agrafix/superrecord/pull/37
-      superrecord = haskellLib.overrideSrc
-        {
-          src = self.fetchFromGitHub {
-            owner = "possehl-analytics";
-            repo = "superrecord";
-            rev = "05c8fdd724af5189a9a8be2f30dfa55a67f8b656";
-            sha256 = "0p6a280kils12ycdlp6dd7392940yzzy6xi8pjar975j38fm3x5a";
-          };
-        }
-        hsSuper.superrecord;
-
       # Use recently-released version that has 9.2 support
       graphmod = assert hsSuper.graphmod != "1.4.5.1";
         hsSelf.callPackage ./extra-pkgs/graphmod-1.4.5.1.nix { };

users/Profpatsch/cas-serve/CasServe.hs

@@ -1,49 +1,38 @@
-{-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -Wall #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Main where
 
 import Control.Applicative
-import qualified Crypto.Hash as Crypto
-import qualified Data.ByteArray as ByteArray
-import qualified Data.ByteString.Lazy as ByteString.Lazy
-import qualified Data.ByteString.Lazy as Lazy
+import Control.Monad.Reader
+import Crypto.Hash qualified as Crypto
+import Data.ByteArray qualified as ByteArray
+import Data.ByteString.Lazy qualified as ByteString.Lazy
+import Data.ByteString.Lazy qualified as Lazy
 import Data.Functor.Compose
 import Data.Int (Int64)
-import qualified Data.List as List
+import Data.List qualified as List
 import Data.Maybe (fromMaybe)
-import qualified Data.Text as Text
-import qualified Data.Text.IO as Text
+import Data.Text qualified as Text
+import Data.Text.IO qualified as Text
 import Database.SQLite.Simple (NamedParam ((:=)))
-import qualified Database.SQLite.Simple as Sqlite
-import qualified Database.SQLite.Simple.FromField as Sqlite
-import qualified Database.SQLite.Simple.QQ as Sqlite
-import GHC.TypeLits (Symbol)
+import Database.SQLite.Simple qualified as Sqlite
+import Database.SQLite.Simple.FromField qualified as Sqlite
+import Database.SQLite.Simple.QQ qualified as Sqlite
+import Label
 import MyPrelude
-import qualified Network.HTTP.Types as Http
-import qualified Network.Wai as Wai
-import qualified Network.Wai.Handler.Warp as Warp
-import qualified SuperRecord as Rec
+import Network.HTTP.Types qualified as Http
+import Network.Wai qualified as Wai
+import Network.Wai.Handler.Warp qualified as Warp
 import System.IO (stderr)
-import Control.Monad.Reader
 
 main :: IO ()
 main = do
@@ -85,7 +74,7 @@ data Env = Env
 
 -- | I don’t need any fancy routing in this, so a handler is just something that returns a @Just (IO a)@ if it wants to handle the request.
 newtype Handler a
-  = Handler ( ReaderT (Wai.Request, Env) (Compose Maybe IO) a )
+  = Handler (ReaderT (Wai.Request, Env) (Compose Maybe IO) a)
   deriving newtype (Functor, Applicative, Alternative)
 
 handler :: ((Wai.Request, Env) -> Maybe (IO a)) -> Handler a
@@ -105,11 +94,13 @@ getById = handler $ \(req, env) -> do
   case req & Wai.pathInfo of
     ["v0", "by-id", filename] -> Just $ do
       Sqlite.queryNamed
-        @( Rec.Rec
-             [ "mimetype" Rec.:= Text,
-               "content" Rec.:= ByteString,
-               "size" Rec.:= Int
-             ]
+        @( T3
+             "mimetype"
+             Text
+             "content"
+             ByteString
+             "size"
+             Int
          )
         (env & envData)
         [Sqlite.sql|
@@ -129,11 +120,11 @@ getById = handler $ \(req, env) -> do
           [] -> Left (Http.status404, "File not found.")
           [res] ->
             Right
-              ( [ ("Content-Type", res & Rec.get #mimetype & textToBytesUtf8),
-                  ("Content-Length", res & Rec.get #size & showToText & textToBytesUtf8)
+              ( [ ("Content-Type", res.mimetype & textToBytesUtf8),
+                  ("Content-Length", res.size & showToText & textToBytesUtf8)
                 ],
                 -- TODO: should this be lazy/streamed?
-                res & Rec.get #content
+                res.content
               )
           _more -> Left "file_references must be unique (in type and name)" & unwrapError
     _ -> Nothing
@@ -235,13 +226,14 @@ getNameFromWordlist env =
 
 -- | We can use a Rec with a named list of types to parse a returning row of sqlite!!
 instance
-  ( Rec.UnsafeRecBuild rec rec FromFieldC
+  ( Sqlite.FromField t1,
+    Sqlite.FromField t2,
+    Sqlite.FromField t3
   ) =>
-  Sqlite.FromRow (Rec.Rec rec)
+  Sqlite.FromRow (T3 l1 t1 l2 t2 l3 t3)
   where
   fromRow = do
-    Rec.unsafeRecBuild @rec @rec @FromFieldC (\_lbl _proxy -> Sqlite.field)
-
-class (Sqlite.FromField a) => FromFieldC (lbl :: Symbol) a
-
-instance (Sqlite.FromField a) => FromFieldC lbl a
+    T3
+      <$> (label @l1 <$> Sqlite.field)
+      <*> (label @l2 <$> Sqlite.field)
+      <*> (label @l3 <$> Sqlite.field)

users/Profpatsch/cas-serve/cas-serve.cabal

@@ -19,6 +19,5 @@ executable cas-serve
         bytestring,
         memory,
         cryptonite,
-        superrecord
 
     default-language: Haskell2010

users/Profpatsch/cas-serve/default.nix

@@ -7,7 +7,6 @@ let
         pkgs.haskellPackages.wai
         pkgs.haskellPackages.warp
         pkgs.haskellPackages.sqlite-simple
-        pkgs.haskellPackages.superrecord
         depot.users.Profpatsch.my-prelude
       ];
       ghcArgs = [ "-threaded" ];

users/Profpatsch/my-prelude/Label.hs

@@ -0,0 +1,99 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Label
+  ( Label,
+    label,
+    label',
+    getLabel,
+    T2 (..),
+    T3 (..),
+  )
+where
+
+import Data.Data (Proxy (..))
+import Data.Function ((&))
+import Data.Typeable (Typeable)
+import GHC.Records (HasField (..))
+import GHC.TypeLits (Symbol)
+
+-- | A labelled value.
+--
+-- Use 'label'/'label'' to construct,
+-- then use dot-syntax to get the inner value.
+newtype Label (label :: Symbol) value = Label value
+  deriving stock (Show, Eq, Ord)
+  deriving newtype (Typeable)
+
+-- | Attach a label to a value; should be used with a type application to name the label.
+--
+-- @@
+-- let f = label @"foo" 'f' :: Label "foo" Char
+-- in f.foo :: Char
+-- @@
+--
+-- Use dot-syntax to get the labelled value.
+label :: forall label value. value -> Label label value
+label value = Label value
+
+-- | Attach a label to a value; Pass it a proxy with the label name in the argument type.
+-- This is intended for passing through the label value;
+-- you can also use 'label'.
+--
+--
+-- @@
+-- let f = label' (Proxy @"foo") 'f' :: Label "foo" Char
+-- in f.foo :: Char
+-- @@
+--
+-- Use dot-syntax to get the labelled value.
+label' :: forall label value. (Proxy label) -> value -> Label label value
+label' Proxy value = Label value
+
+-- | Fetches the labelled value.
+instance HasField label (Label label value) value where
+  getField :: (Label label value) -> value
+  getField (Label value) = value
+
+-- | Fetch a value from a record, like 'getField', but also keep it wrapped by its label.
+getLabel :: forall label record a. HasField label record a => record -> Label label a
+getLabel rec = rec & getField @label & label @label
+
+-- | A named 2-element tuple. Since the elements are named, you can access them with `.`.
+--
+-- @@
+-- let t2 = T2 (label @"myfield" 'c') (label @"otherfield" True) :: T2 "myfield" Char "otherfield" Bool
+-- in (
+--   t2.myfield :: Char,
+--   t2.otherfield :: Bool
+-- )
+-- @@
+data T2 (l1 :: Symbol) t1 (l2 :: Symbol) t2 = T2 (Label l1 t1) (Label l2 t2)
+
+-- | Access the first field by label
+instance HasField l1 (T2 l1 t1 l2 t2) t1 where
+  getField (T2 t1 _) = getField @l1 t1
+
+-- | Access the second field by label
+instance HasField l2 (T2 l1 t1 l2 t2) t2 where
+  getField (T2 _ t2) = getField @l2 t2
+
+-- | A named 3-element tuple. Since the elements are named, you can access them with `.`. See 'T2' for an example.
+data T3 (l1 :: Symbol) t1 (l2 :: Symbol) t2 (l3 :: Symbol) t3 = T3 (Label l1 t1) (Label l2 t2) (Label l3 t3)
+
+-- | Access the first field by label
+instance HasField l1 (T3 l1 t1 l2 t2 l3 t3) t1 where
+  getField (T3 t1 _ _) = getField @l1 t1
+
+-- | Access the second field by label
+instance HasField l2 (T3 l1 t1 l2 t2 l3 t3) t2 where
+  getField (T3 _ t2 _) = getField @l2 t2
+
+-- | Access the third field by label
+instance HasField l3 (T3 l1 t1 l2 t2 l3 t3) t3 where
+  getField (T3 _ _ t3) = getField @l3 t3

users/Profpatsch/my-prelude/default.nix

@@ -7,6 +7,7 @@ pkgs.haskellPackages.mkDerivation {
   src = depot.users.Profpatsch.exactSource ./. [
     ./my-prelude.cabal
     ./MyPrelude.hs
+    ./Label.hs
   ];
 
   isLibrary = true;

users/Profpatsch/my-prelude/my-prelude.cabal

@@ -5,7 +5,9 @@ author:             Profpatsch
 maintainer:         mail@profpatsch.de
 
 library
-    exposed-modules: MyPrelude
+    exposed-modules:
+      MyPrelude
+      Label
 
     -- Modules included in this executable, other than Main.
     -- other-modules: