diff options
Diffstat (limited to 'users/Profpatsch')
| -rw-r--r-- | users/Profpatsch/cas-serve/CasServe.hs | 78 | ||||
| -rw-r--r-- | users/Profpatsch/cas-serve/cas-serve.cabal | 1 | ||||
| -rw-r--r-- | users/Profpatsch/cas-serve/default.nix | 1 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/Label.hs | 99 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/default.nix | 1 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/my-prelude.cabal | 4 |
6 files changed, 138 insertions, 46 deletions
diff --git a/users/Profpatsch/cas-serve/CasServe.hs b/users/Profpatsch/cas-serve/CasServe.hs index 3e658e58ccff..f7189d5f9acf 100644 --- a/users/Profpatsch/cas-serve/CasServe.hs +++ b/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) diff --git a/users/Profpatsch/cas-serve/cas-serve.cabal b/users/Profpatsch/cas-serve/cas-serve.cabal index 98a5ba1064b1..3d988e42273c 100644 --- a/users/Profpatsch/cas-serve/cas-serve.cabal +++ b/users/Profpatsch/cas-serve/cas-serve.cabal @@ -19,6 +19,5 @@ executable cas-serve bytestring, memory, cryptonite, - superrecord default-language: Haskell2010 diff --git a/users/Profpatsch/cas-serve/default.nix b/users/Profpatsch/cas-serve/default.nix index b25a5ac04414..6e4bfd324233 100644 --- a/users/Profpatsch/cas-serve/default.nix +++ b/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" ]; diff --git a/users/Profpatsch/my-prelude/Label.hs b/users/Profpatsch/my-prelude/Label.hs new file mode 100644 index 000000000000..f869343a1e7a --- /dev/null +++ b/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 diff --git a/users/Profpatsch/my-prelude/default.nix b/users/Profpatsch/my-prelude/default.nix index 88e67f7a50b1..797beda82eff 100644 --- a/users/Profpatsch/my-prelude/default.nix +++ b/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; diff --git a/users/Profpatsch/my-prelude/my-prelude.cabal b/users/Profpatsch/my-prelude/my-prelude.cabal index 731a075b80b4..508bbba055dc 100644 --- a/users/Profpatsch/my-prelude/my-prelude.cabal +++ b/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: |