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
|
@ -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)
|
||||
|
|
|
@ -19,6 +19,5 @@ executable cas-serve
|
|||
bytestring,
|
||||
memory,
|
||||
cryptonite,
|
||||
superrecord
|
||||
|
||||
default-language: Haskell2010
|
||||
|
|
|
@ -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" ];
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue