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:
parent
319c03f634
commit
e5fa10b209
7 changed files with 138 additions and 60 deletions
14
third_party/overlays/haskell/default.nix
vendored
14
third_party/overlays/haskell/default.nix
vendored
|
@ -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 { };
|
||||||
|
|
|
@ -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 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.
|
-- | 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
|
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
|
|
||||||
|
|
|
@ -19,6 +19,5 @@ executable cas-serve
|
||||||
bytestring,
|
bytestring,
|
||||||
memory,
|
memory,
|
||||||
cryptonite,
|
cryptonite,
|
||||||
superrecord
|
|
||||||
|
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
|
|
@ -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" ];
|
||||||
|
|
99
users/Profpatsch/my-prelude/Label.hs
Normal file
99
users/Profpatsch/my-prelude/Label.hs
Normal 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
|
|
@ -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;
|
||||||
|
|
|
@ -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:
|
||||||
|
|
Loading…
Reference in a new issue