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
This commit is contained in:
Profpatsch 2022-12-31 17:11:57 +01:00 committed by clbot
parent 319c03f634
commit e5fa10b209
7 changed files with 138 additions and 60 deletions

View file

@ -30,20 +30,6 @@ in
dhall = dhall-source "dhall" hsSuper.dhall; dhall = dhall-source "dhall" hsSuper.dhall;
dhall-nix = dhall-source "dhall-nix" hsSuper.dhall-nix; 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 # Use recently-released version that has 9.2 support
graphmod = assert hsSuper.graphmod != "1.4.5.1"; graphmod = assert hsSuper.graphmod != "1.4.5.1";
hsSelf.callPackage ./extra-pkgs/graphmod-1.4.5.1.nix { }; hsSelf.callPackage ./extra-pkgs/graphmod-1.4.5.1.nix { };

View file

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

View file

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

View file

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

View file

@ -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

View file

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

View file

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