chore(users/Profpatsch/*): more cabal maintenance
Change-Id: Ib1714abce2815873eb50dbeac088e812fa9098ab Reviewed-on: https://cl.tvl.fyi/c/depot/+/8686 Tested-by: BuildkiteCI Reviewed-by: Profpatsch <mail@profpatsch.de> Autosubmit: Profpatsch <mail@profpatsch.de>
This commit is contained in:
parent
ee21f725a3
commit
8c4730c433
24 changed files with 264 additions and 203 deletions
|
@ -1,20 +1,17 @@
|
||||||
{-# LANGUAGE LambdaCase #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
|
||||||
module ArglibNetencode where
|
module ArglibNetencode where
|
||||||
|
|
||||||
import qualified Data.Attoparsec.ByteString as Atto
|
import Data.Attoparsec.ByteString qualified as Atto
|
||||||
import Data.Maybe (fromMaybe)
|
|
||||||
import ExecHelpers
|
import ExecHelpers
|
||||||
import MyPrelude
|
import Label
|
||||||
import Netencode
|
import Netencode qualified
|
||||||
import qualified System.Environment as Env
|
import PossehlAnalyticsPrelude
|
||||||
import qualified System.Posix.Env.ByteString as ByteEnv
|
import System.Posix.Env.ByteString qualified as ByteEnv
|
||||||
|
|
||||||
arglibNetencode :: CurrentProgramName -> Maybe Text -> IO T
|
arglibNetencode :: CurrentProgramName -> Maybe (Label "arglibEnvvar" Text) -> IO Netencode.T
|
||||||
arglibNetencode progName mEnvvar = do
|
arglibNetencode progName mEnvvar = do
|
||||||
let envvar = mEnvvar & fromMaybe "ARGLIB_NETENCODE" & textToBytesUtf8
|
let envvar = mEnvvar <&> (.arglibEnvvar) & fromMaybe "ARGLIB_NETENCODE" & textToBytesUtf8
|
||||||
ByteEnv.getEnv envvar >>= \case
|
ByteEnv.getEnv envvar >>= \case
|
||||||
Nothing -> dieUserError progName [fmt|could not read args, envvar {envvar} not set|]
|
Nothing -> dieUserError progName [fmt|could not read args, envvar {envvar} not set|]
|
||||||
Just bytes ->
|
Just bytes ->
|
||||||
|
|
|
@ -1,17 +1,65 @@
|
||||||
cabal-version: 2.4
|
cabal-version: 3.0
|
||||||
name: arglib-netencode
|
name: arglib-netencode
|
||||||
version: 0.1.0.0
|
version: 0.1.0.0
|
||||||
author: Profpatsch
|
author: Profpatsch
|
||||||
maintainer: mail@profpatsch.de
|
maintainer: mail@profpatsch.de
|
||||||
|
|
||||||
|
common common-options
|
||||||
|
ghc-options:
|
||||||
|
-Wall
|
||||||
|
-Wno-type-defaults
|
||||||
|
-Wunused-packages
|
||||||
|
-Wredundant-constraints
|
||||||
|
-fwarn-missing-deriving-strategies
|
||||||
|
|
||||||
|
-- See https://downloads.haskell.org/ghc/latest/docs/users_guide/exts.html
|
||||||
|
-- for a description of all these extensions
|
||||||
|
default-extensions:
|
||||||
|
-- Infer Applicative instead of Monad where possible
|
||||||
|
ApplicativeDo
|
||||||
|
|
||||||
|
-- Allow literal strings to be Text
|
||||||
|
OverloadedStrings
|
||||||
|
|
||||||
|
-- Syntactic sugar improvements
|
||||||
|
LambdaCase
|
||||||
|
MultiWayIf
|
||||||
|
|
||||||
|
-- Makes the (deprecated) usage of * instead of Data.Kind.Type an error
|
||||||
|
NoStarIsType
|
||||||
|
|
||||||
|
-- Convenient and crucial to deal with ambiguous field names, commonly
|
||||||
|
-- known as RecordDotSyntax
|
||||||
|
OverloadedRecordDot
|
||||||
|
|
||||||
|
-- does not export record fields as functions, use OverloadedRecordDot to access instead
|
||||||
|
NoFieldSelectors
|
||||||
|
|
||||||
|
-- Record punning
|
||||||
|
RecordWildCards
|
||||||
|
|
||||||
|
-- Improved Deriving
|
||||||
|
DerivingStrategies
|
||||||
|
DerivingVia
|
||||||
|
|
||||||
|
-- Type-level strings
|
||||||
|
DataKinds
|
||||||
|
|
||||||
|
-- to enable the `type` keyword in import lists (ormolu uses this automatically)
|
||||||
|
ExplicitNamespaces
|
||||||
|
|
||||||
|
default-language: GHC2021
|
||||||
|
|
||||||
|
|
||||||
library
|
library
|
||||||
|
import: common-options
|
||||||
exposed-modules: ArglibNetencode
|
exposed-modules: ArglibNetencode
|
||||||
|
|
||||||
build-depends:
|
build-depends:
|
||||||
base >=4.15 && <5,
|
base >=4.15 && <5,
|
||||||
my-prelude,
|
pa-prelude,
|
||||||
|
pa-label,
|
||||||
netencode,
|
netencode,
|
||||||
exec-helpers,
|
exec-helpers,
|
||||||
attoparsec,
|
attoparsec,
|
||||||
unix
|
unix
|
||||||
default-language: Haskell2010
|
|
||||||
|
|
|
@ -57,7 +57,9 @@ let
|
||||||
];
|
];
|
||||||
|
|
||||||
libraryHaskellDepends = [
|
libraryHaskellDepends = [
|
||||||
depot.users.Profpatsch.my-prelude
|
pkgs.haskellPackages.pa-prelude
|
||||||
|
pkgs.haskellPackages.pa-label
|
||||||
|
pkgs.haskellPackages.pa-error-tree
|
||||||
depot.users.Profpatsch.netencode.netencode-hs
|
depot.users.Profpatsch.netencode.netencode-hs
|
||||||
depot.users.Profpatsch.execline.exec-helpers-hs
|
depot.users.Profpatsch.execline.exec-helpers-hs
|
||||||
];
|
];
|
||||||
|
|
|
@ -1,3 +1,8 @@
|
||||||
packages:
|
packages:
|
||||||
./my-prelude/my-prelude.cabal
|
./my-prelude/my-prelude.cabal
|
||||||
|
./netencode/netencode.cabal
|
||||||
|
./arglib/arglib-netencode.cabal
|
||||||
|
./execline/exec-helpers.cabal
|
||||||
./htmx-experiment/htmx-experiment.cabal
|
./htmx-experiment/htmx-experiment.cabal
|
||||||
|
./cas-serve/cas-serve.cabal
|
||||||
|
./jbovlaste-sqlite/jbovlaste-sqlite.cabal
|
||||||
|
|
|
@ -1,16 +1,9 @@
|
||||||
{-# LANGUAGE DataKinds #-}
|
|
||||||
{-# LANGUAGE DerivingStrategies #-}
|
|
||||||
{-# LANGUAGE LambdaCase #-}
|
|
||||||
{-# LANGUAGE OverloadedRecordDot #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
|
||||||
{-# LANGUAGE TypeApplications #-}
|
|
||||||
{-# OPTIONS_GHC -Wall #-}
|
|
||||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||||
|
|
||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
|
import ArglibNetencode (arglibNetencode)
|
||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
import Crypto.Hash qualified as Crypto
|
import Crypto.Hash qualified as Crypto
|
||||||
|
@ -20,7 +13,6 @@ import Data.ByteString.Lazy qualified as Lazy
|
||||||
import Data.Functor.Compose
|
import Data.Functor.Compose
|
||||||
import Data.Int (Int64)
|
import Data.Int (Int64)
|
||||||
import Data.List qualified as List
|
import Data.List qualified as List
|
||||||
import Data.Maybe (fromMaybe)
|
|
||||||
import Data.Text qualified as Text
|
import Data.Text qualified as Text
|
||||||
import Data.Text.IO qualified as Text
|
import Data.Text.IO qualified as Text
|
||||||
import Database.SQLite.Simple (NamedParam ((:=)))
|
import Database.SQLite.Simple (NamedParam ((:=)))
|
||||||
|
@ -28,12 +20,29 @@ import Database.SQLite.Simple qualified as Sqlite
|
||||||
import Database.SQLite.Simple.FromField qualified as Sqlite
|
import Database.SQLite.Simple.FromField qualified as Sqlite
|
||||||
import Database.SQLite.Simple.QQ qualified as Sqlite
|
import Database.SQLite.Simple.QQ qualified as Sqlite
|
||||||
import Label
|
import Label
|
||||||
import MyPrelude
|
import Netencode.Parse qualified as Net
|
||||||
import Network.HTTP.Types qualified as Http
|
import Network.HTTP.Types qualified as Http
|
||||||
import Network.Wai qualified as Wai
|
import Network.Wai qualified as Wai
|
||||||
import Network.Wai.Handler.Warp qualified as Warp
|
import Network.Wai.Handler.Warp qualified as Warp
|
||||||
|
import PossehlAnalyticsPrelude
|
||||||
import System.IO (stderr)
|
import System.IO (stderr)
|
||||||
|
|
||||||
|
parseArglib = do
|
||||||
|
let env = label @"arglibEnvvar" "CAS_SERVE_ARGS"
|
||||||
|
let asApi =
|
||||||
|
Net.asRecord >>> do
|
||||||
|
address <- label @"bindToAddress" <$> (Net.key "bindToAddress" >>> Net.asText)
|
||||||
|
port <- label @"port" <$> (Net.key "port" >>> Net.asText)
|
||||||
|
pure (T2 address port)
|
||||||
|
arglibNetencode "cas-serve" (Just env)
|
||||||
|
<&> Net.runParse
|
||||||
|
[fmt|Cannot parse arguments in "{env.arglibEnvvar}"|]
|
||||||
|
( Net.asRecord >>> do
|
||||||
|
publicApi <- label @"publicApi" <$> (Net.key "publicApi" >>> asApi)
|
||||||
|
privateApi <- label @"privateApi" <$> (Net.key "privateApi" >>> asApi)
|
||||||
|
pure $ T2 publicApi privateApi
|
||||||
|
)
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = do
|
main = do
|
||||||
withEnv $ \env ->
|
withEnv $ \env ->
|
||||||
|
@ -64,8 +73,7 @@ api env req respond = do
|
||||||
Wai.responseLBS
|
Wai.responseLBS
|
||||||
Http.status200
|
Http.status200
|
||||||
headers
|
headers
|
||||||
( body & toLazyBytes
|
(body & toLazyBytes)
|
||||||
)
|
|
||||||
|
|
||||||
data Env = Env
|
data Env = Env
|
||||||
{ envWordlist :: Sqlite.Connection,
|
{ envWordlist :: Sqlite.Connection,
|
||||||
|
@ -102,7 +110,7 @@ getById = handler $ \(req, env) -> do
|
||||||
"size"
|
"size"
|
||||||
Int
|
Int
|
||||||
)
|
)
|
||||||
(env & envData)
|
(env.envData)
|
||||||
[Sqlite.sql|
|
[Sqlite.sql|
|
||||||
SELECT
|
SELECT
|
||||||
mimetype,
|
mimetype,
|
||||||
|
@ -172,7 +180,7 @@ insertById = handler $ \(req, env) -> do
|
||||||
name <- getNameFromWordlist env
|
name <- getNameFromWordlist env
|
||||||
let fullname = name <> extension
|
let fullname = name <> extension
|
||||||
|
|
||||||
let conn = env & envData
|
let conn = env.envData
|
||||||
Sqlite.withTransaction conn $ do
|
Sqlite.withTransaction conn $ do
|
||||||
Sqlite.executeNamed
|
Sqlite.executeNamed
|
||||||
conn
|
conn
|
||||||
|
@ -218,7 +226,7 @@ getNameFromWordlist env =
|
||||||
do
|
do
|
||||||
let numberOfWords = 3 :: Int
|
let numberOfWords = 3 :: Int
|
||||||
Sqlite.queryNamed @(Sqlite.Only Text)
|
Sqlite.queryNamed @(Sqlite.Only Text)
|
||||||
(env & envWordlist)
|
(env.envWordlist)
|
||||||
[Sqlite.sql|SELECT word FROM wordlist ORDER BY RANDOM() LIMIT :words|]
|
[Sqlite.sql|SELECT word FROM wordlist ORDER BY RANDOM() LIMIT :words|]
|
||||||
[":words" Sqlite.:= numberOfWords]
|
[":words" Sqlite.:= numberOfWords]
|
||||||
<&> map Sqlite.fromOnly
|
<&> map Sqlite.fromOnly
|
||||||
|
|
|
@ -1,23 +1,74 @@
|
||||||
cabal-version: 2.4
|
cabal-version: 3.0
|
||||||
name: cas-serve
|
name: cas-serve
|
||||||
version: 0.1.0.0
|
version: 0.1.0.0
|
||||||
author: Profpatsch
|
author: Profpatsch
|
||||||
maintainer: mail@profpatsch.de
|
maintainer: mail@profpatsch.de
|
||||||
|
|
||||||
|
common common-options
|
||||||
|
ghc-options:
|
||||||
|
-Wall
|
||||||
|
-Wno-type-defaults
|
||||||
|
-Wunused-packages
|
||||||
|
-Wredundant-constraints
|
||||||
|
-fwarn-missing-deriving-strategies
|
||||||
|
|
||||||
|
-- See https://downloads.haskell.org/ghc/latest/docs/users_guide/exts.html
|
||||||
|
-- for a description of all these extensions
|
||||||
|
default-extensions:
|
||||||
|
-- Infer Applicative instead of Monad where possible
|
||||||
|
ApplicativeDo
|
||||||
|
|
||||||
|
-- Allow literal strings to be Text
|
||||||
|
OverloadedStrings
|
||||||
|
|
||||||
|
-- Syntactic sugar improvements
|
||||||
|
LambdaCase
|
||||||
|
MultiWayIf
|
||||||
|
|
||||||
|
-- Makes the (deprecated) usage of * instead of Data.Kind.Type an error
|
||||||
|
NoStarIsType
|
||||||
|
|
||||||
|
-- Convenient and crucial to deal with ambiguous field names, commonly
|
||||||
|
-- known as RecordDotSyntax
|
||||||
|
OverloadedRecordDot
|
||||||
|
|
||||||
|
-- does not export record fields as functions, use OverloadedRecordDot to access instead
|
||||||
|
NoFieldSelectors
|
||||||
|
|
||||||
|
-- Record punning
|
||||||
|
RecordWildCards
|
||||||
|
|
||||||
|
-- Improved Deriving
|
||||||
|
DerivingStrategies
|
||||||
|
DerivingVia
|
||||||
|
|
||||||
|
-- Type-level strings
|
||||||
|
DataKinds
|
||||||
|
|
||||||
|
-- to enable the `type` keyword in import lists (ormolu uses this automatically)
|
||||||
|
ExplicitNamespaces
|
||||||
|
|
||||||
|
default-language: GHC2021
|
||||||
|
|
||||||
|
|
||||||
executable cas-serve
|
executable cas-serve
|
||||||
|
import: common-options
|
||||||
|
|
||||||
main-is: CasServe.hs
|
main-is: CasServe.hs
|
||||||
|
|
||||||
build-depends:
|
build-depends:
|
||||||
base >=4.15 && <5,
|
base >=4.15 && <5,
|
||||||
|
pa-prelude,
|
||||||
|
pa-label,
|
||||||
|
arglib-netencode,
|
||||||
|
netencode,
|
||||||
text,
|
text,
|
||||||
sqlite-simple,
|
sqlite-simple,
|
||||||
http-types,
|
http-types,
|
||||||
|
ihp-hsx,
|
||||||
wai,
|
wai,
|
||||||
warp,
|
warp,
|
||||||
mtl,
|
mtl,
|
||||||
my-prelude,
|
|
||||||
bytestring,
|
bytestring,
|
||||||
memory,
|
memory,
|
||||||
cryptonite,
|
cryptonite,
|
||||||
|
|
||||||
default-language: Haskell2010
|
|
||||||
|
|
|
@ -1,17 +1,38 @@
|
||||||
{ depot, pkgs, lib, ... }:
|
{ depot, pkgs, lib, ... }:
|
||||||
|
|
||||||
let
|
let
|
||||||
cas-serve = pkgs.writers.writeHaskell "cas-serve"
|
bins = depot.nix.getBins pkgs.sqlite [ "sqlite3" ];
|
||||||
{
|
|
||||||
libraries = [
|
cas-serve = pkgs.haskellPackages.mkDerivation {
|
||||||
|
pname = "cas-serve";
|
||||||
|
version = "0.1.0";
|
||||||
|
|
||||||
|
src = depot.users.Profpatsch.exactSource ./. [
|
||||||
|
./cas-serve.cabal
|
||||||
|
./CasServe.hs
|
||||||
|
];
|
||||||
|
|
||||||
|
libraryHaskellDepends = [
|
||||||
|
pkgs.haskellPackages.pa-prelude
|
||||||
|
pkgs.haskellPackages.pa-label
|
||||||
|
pkgs.haskellPackages.ihp-hsx
|
||||||
pkgs.haskellPackages.wai
|
pkgs.haskellPackages.wai
|
||||||
pkgs.haskellPackages.warp
|
pkgs.haskellPackages.warp
|
||||||
pkgs.haskellPackages.sqlite-simple
|
pkgs.haskellPackages.sqlite-simple
|
||||||
depot.users.Profpatsch.my-prelude
|
depot.users.Profpatsch.arglib.netencode.haskell
|
||||||
|
depot.users.Profpatsch.netencode.netencode-hs
|
||||||
];
|
];
|
||||||
ghcArgs = [ "-threaded" ];
|
|
||||||
|
|
||||||
} ./CasServe.hs;
|
isExecutable = true;
|
||||||
|
isLibrary = false;
|
||||||
|
license = lib.licenses.mit;
|
||||||
|
};
|
||||||
|
|
||||||
|
create-cas-database = depot.nix.writeExecline "create-cas-database" { readNArgs = 1; } [
|
||||||
|
bins.sqlite3
|
||||||
|
"$1"
|
||||||
|
"-init"
|
||||||
|
./schema.sql
|
||||||
|
];
|
||||||
in
|
in
|
||||||
cas-serve
|
cas-serve
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
cabal-version: 2.4
|
cabal-version: 3.0
|
||||||
name: exec-helpers
|
name: exec-helpers
|
||||||
version: 0.1.0.0
|
version: 0.1.0.0
|
||||||
author: Profpatsch
|
author: Profpatsch
|
||||||
|
|
|
@ -2,10 +2,19 @@ cradle:
|
||||||
cabal:
|
cabal:
|
||||||
- path: "./my-prelude"
|
- path: "./my-prelude"
|
||||||
component: "lib:my-prelude"
|
component: "lib:my-prelude"
|
||||||
|
- path: "./netencode"
|
||||||
|
component: "lib:netencode"
|
||||||
|
- path: "./arglib"
|
||||||
|
component: "lib:arglib-netencode"
|
||||||
|
- path: "./execline"
|
||||||
|
component: "lib:exec-helpers"
|
||||||
- path: "./htmx-experiment/src"
|
- path: "./htmx-experiment/src"
|
||||||
component: "lib:htmx-experiment"
|
component: "lib:htmx-experiment"
|
||||||
- path: "./htmx-experiment/src"
|
- path: "./htmx-experiment/src"
|
||||||
component: "lib:htmx-experiment"
|
component: "lib:htmx-experiment"
|
||||||
- path: "./htmx-experiment/Main.hs"
|
- path: "./htmx-experiment/Main.hs"
|
||||||
component: "htmx-experiment:exe:htmx-experiment"
|
component: "htmx-experiment:exe:htmx-experiment"
|
||||||
|
- path: "./cas-serve/CasServe.hs"
|
||||||
|
component: "cas-serve:exe:cas-serve"
|
||||||
|
- path: "./jbovlaste-sqlite/JbovlasteSqlite.hs"
|
||||||
|
component: "jbovlaste-sqlite:exe:jbovlaste-sqlite"
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
cabal-version: 2.4
|
cabal-version: 3.0
|
||||||
name: htmx-experiment
|
name: htmx-experiment
|
||||||
version: 0.1.0.0
|
version: 0.1.0.0
|
||||||
author: Profpatsch
|
author: Profpatsch
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
cabal-version: 2.4
|
cabal-version: 3.0
|
||||||
name: ical-smolify
|
name: ical-smolify
|
||||||
version: 0.1.0.0
|
version: 0.1.0.0
|
||||||
author: Profpatsch
|
author: Profpatsch
|
||||||
|
|
|
@ -4,7 +4,7 @@ module AesonQQ where
|
||||||
|
|
||||||
import Data.Aeson qualified as Json
|
import Data.Aeson qualified as Json
|
||||||
import Data.Either qualified as Either
|
import Data.Either qualified as Either
|
||||||
import MyPrelude
|
import PossehlAnalyticsPrelude
|
||||||
import PyF qualified
|
import PyF qualified
|
||||||
import PyF.Internal.QQ qualified as PyFConf
|
import PyF.Internal.QQ qualified as PyFConf
|
||||||
|
|
||||||
|
|
|
@ -6,6 +6,7 @@
|
||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
{-# LANGUAGE OverloadedRecordDot #-}
|
{-# LANGUAGE OverloadedRecordDot #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE PackageImports #-}
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
{-# LANGUAGE NoFieldSelectors #-}
|
{-# LANGUAGE NoFieldSelectors #-}
|
||||||
|
@ -24,7 +25,7 @@ import Data.Aeson.KeyMap qualified as KeyMap
|
||||||
import Data.ByteString qualified as ByteString
|
import Data.ByteString qualified as ByteString
|
||||||
import Data.ByteString.Lazy qualified as Lazy
|
import Data.ByteString.Lazy qualified as Lazy
|
||||||
import Data.Char qualified as Char
|
import Data.Char qualified as Char
|
||||||
import Data.Error.Tree
|
import "pa-error-tree" Data.Error.Tree
|
||||||
import Data.Functor.Compose
|
import Data.Functor.Compose
|
||||||
import Data.List qualified as List
|
import Data.List qualified as List
|
||||||
import Data.Map.Strict qualified as Map
|
import Data.Map.Strict qualified as Map
|
||||||
|
@ -32,11 +33,11 @@ import Data.Text qualified as Text
|
||||||
import ExecHelpers
|
import ExecHelpers
|
||||||
import GHC.Records (HasField (..))
|
import GHC.Records (HasField (..))
|
||||||
import Label
|
import Label
|
||||||
import MyPrelude
|
|
||||||
import Netencode qualified
|
import Netencode qualified
|
||||||
import Netencode.Parse qualified as NetParse
|
import Netencode.Parse qualified as NetParse
|
||||||
import Network.HTTP.Conduit qualified as Client
|
import Network.HTTP.Conduit qualified as Client
|
||||||
import Network.HTTP.Simple qualified as Client
|
import Network.HTTP.Simple qualified as Client
|
||||||
|
import PossehlAnalyticsPrelude
|
||||||
import Pretty
|
import Pretty
|
||||||
import System.Directory qualified as File
|
import System.Directory qualified as File
|
||||||
import System.Environment qualified as Env
|
import System.Environment qualified as Env
|
||||||
|
|
|
@ -16,6 +16,8 @@ let
|
||||||
depot.users.Profpatsch.execline.exec-helpers-hs
|
depot.users.Profpatsch.execline.exec-helpers-hs
|
||||||
depot.users.Profpatsch.arglib.netencode.haskell
|
depot.users.Profpatsch.arglib.netencode.haskell
|
||||||
pkgs.haskellPackages.pa-prelude
|
pkgs.haskellPackages.pa-prelude
|
||||||
|
pkgs.haskellPackages.pa-label
|
||||||
|
pkgs.haskellPackages.pa-error-tree
|
||||||
pkgs.haskellPackages.aeson
|
pkgs.haskellPackages.aeson
|
||||||
pkgs.haskellPackages.http-conduit
|
pkgs.haskellPackages.http-conduit
|
||||||
pkgs.haskellPackages.aeson-better-errors
|
pkgs.haskellPackages.aeson-better-errors
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
cabal-version: 2.4
|
cabal-version: 3.0
|
||||||
name: mailbox-org
|
name: mailbox-org
|
||||||
version: 0.1.0.0
|
version: 0.1.0.0
|
||||||
author: Profpatsch
|
author: Profpatsch
|
||||||
|
@ -10,7 +10,9 @@ executable mailbox-org
|
||||||
build-depends:
|
build-depends:
|
||||||
base >=4.15 && <5,
|
base >=4.15 && <5,
|
||||||
my-prelude,
|
my-prelude,
|
||||||
|
pa-prelude,
|
||||||
pa-label,
|
pa-label,
|
||||||
|
pa-error-tree,
|
||||||
exec-helpers,
|
exec-helpers,
|
||||||
netencode,
|
netencode,
|
||||||
text,
|
text,
|
||||||
|
|
|
@ -1,113 +0,0 @@
|
||||||
{-# LANGUAGE DerivingStrategies #-}
|
|
||||||
{-# LANGUAGE GHC2021 #-}
|
|
||||||
{-# LANGUAGE OverloadedRecordDot #-}
|
|
||||||
|
|
||||||
module Data.Error.Tree where
|
|
||||||
|
|
||||||
import Data.String (IsString (..))
|
|
||||||
import Data.Tree qualified as Tree
|
|
||||||
import MyPrelude
|
|
||||||
|
|
||||||
-- | A tree of 'Error's, with a single root 'Error' and 0..n nested 'ErrorTree's.
|
|
||||||
--
|
|
||||||
-- @@
|
|
||||||
-- top error
|
|
||||||
-- |
|
|
||||||
-- |-- error 1
|
|
||||||
-- | |
|
|
||||||
-- | -- error 1.1
|
|
||||||
-- |
|
|
||||||
-- |-- error 2
|
|
||||||
-- @@
|
|
||||||
newtype ErrorTree = ErrorTree {unErrorTree :: (Tree.Tree Error)}
|
|
||||||
deriving stock (Show)
|
|
||||||
|
|
||||||
instance IsString ErrorTree where
|
|
||||||
fromString = singleError . fromString
|
|
||||||
|
|
||||||
-- deriving newtype (Ord) -- TODO: Add this instance with containers-0.6.5
|
|
||||||
|
|
||||||
-- | Turn a single 'Error' into an 'ErrorTree', a leaf.
|
|
||||||
singleError :: Error -> ErrorTree
|
|
||||||
singleError e = ErrorTree $ Tree.Node e []
|
|
||||||
|
|
||||||
-- | Take a list of errors & create a new 'ErrorTree' with the given 'Error' as the root.
|
|
||||||
errorTree :: Error -> NonEmpty Error -> ErrorTree
|
|
||||||
errorTree topLevelErr nestedErrs =
|
|
||||||
ErrorTree
|
|
||||||
( Tree.Node
|
|
||||||
topLevelErr
|
|
||||||
(nestedErrs <&> (\e -> Tree.Node e []) & toList)
|
|
||||||
)
|
|
||||||
|
|
||||||
-- | Attach more context to the root 'Error' of the 'ErrorTree', via 'errorContext'.
|
|
||||||
errorTreeContext :: Text -> ErrorTree -> ErrorTree
|
|
||||||
errorTreeContext context (ErrorTree tree) =
|
|
||||||
ErrorTree $
|
|
||||||
tree
|
|
||||||
{ Tree.rootLabel = tree.rootLabel & errorContext context
|
|
||||||
}
|
|
||||||
|
|
||||||
-- | Nest the given 'Error' around the ErrorTree
|
|
||||||
--
|
|
||||||
-- @@
|
|
||||||
-- top level error
|
|
||||||
-- |
|
|
||||||
-- -- nestedError
|
|
||||||
-- |
|
|
||||||
-- -- error 1
|
|
||||||
-- |
|
|
||||||
-- -- error 2
|
|
||||||
-- @@
|
|
||||||
nestedError ::
|
|
||||||
Error -> -- top level
|
|
||||||
ErrorTree -> -- nested
|
|
||||||
ErrorTree
|
|
||||||
nestedError topLevelErr nestedErr =
|
|
||||||
ErrorTree $
|
|
||||||
Tree.Node
|
|
||||||
{ Tree.rootLabel = topLevelErr,
|
|
||||||
Tree.subForest = [nestedErr.unErrorTree]
|
|
||||||
}
|
|
||||||
|
|
||||||
-- | Nest the given 'Error' around the list of 'ErrorTree's.
|
|
||||||
--
|
|
||||||
-- @@
|
|
||||||
-- top level error
|
|
||||||
-- |
|
|
||||||
-- |- nestedError1
|
|
||||||
-- | |
|
|
||||||
-- | -- error 1
|
|
||||||
-- | |
|
|
||||||
-- | -- error 2
|
|
||||||
-- |
|
|
||||||
-- |- nestedError 2
|
|
||||||
-- @@
|
|
||||||
nestedMultiError ::
|
|
||||||
Error -> -- top level
|
|
||||||
NonEmpty ErrorTree -> -- nested
|
|
||||||
ErrorTree
|
|
||||||
nestedMultiError topLevelErr nestedErrs =
|
|
||||||
ErrorTree $
|
|
||||||
Tree.Node
|
|
||||||
{ Tree.rootLabel = topLevelErr,
|
|
||||||
Tree.subForest = nestedErrs & toList <&> (.unErrorTree)
|
|
||||||
}
|
|
||||||
|
|
||||||
prettyErrorTree :: ErrorTree -> Text
|
|
||||||
prettyErrorTree (ErrorTree tree) =
|
|
||||||
tree
|
|
||||||
<&> prettyError
|
|
||||||
<&> textToString
|
|
||||||
& Tree.drawTree
|
|
||||||
& stringToText
|
|
||||||
|
|
||||||
prettyErrorTrees :: NonEmpty ErrorTree -> Text
|
|
||||||
prettyErrorTrees forest =
|
|
||||||
forest
|
|
||||||
<&> (.unErrorTree)
|
|
||||||
<&> fmap prettyError
|
|
||||||
<&> fmap textToString
|
|
||||||
& toList
|
|
||||||
& Tree.drawForest
|
|
||||||
& stringToText
|
|
|
@ -8,7 +8,6 @@ pkgs.haskellPackages.mkDerivation {
|
||||||
./my-prelude.cabal
|
./my-prelude.cabal
|
||||||
./MyPrelude.hs
|
./MyPrelude.hs
|
||||||
./Pretty.hs
|
./Pretty.hs
|
||||||
./Data/Error/Tree.hs
|
|
||||||
./Aeson.hs
|
./Aeson.hs
|
||||||
./RunCommand.hs
|
./RunCommand.hs
|
||||||
./Test.hs
|
./Test.hs
|
||||||
|
@ -18,6 +17,7 @@ pkgs.haskellPackages.mkDerivation {
|
||||||
|
|
||||||
libraryHaskellDepends = [
|
libraryHaskellDepends = [
|
||||||
pkgs.haskellPackages.pa-label
|
pkgs.haskellPackages.pa-label
|
||||||
|
pkgs.haskellPackages.pa-error-tree
|
||||||
pkgs.haskellPackages.aeson
|
pkgs.haskellPackages.aeson
|
||||||
pkgs.haskellPackages.aeson-better-errors
|
pkgs.haskellPackages.aeson-better-errors
|
||||||
pkgs.haskellPackages.PyF
|
pkgs.haskellPackages.PyF
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
cabal-version: 2.4
|
cabal-version: 3.0
|
||||||
name: my-prelude
|
name: my-prelude
|
||||||
version: 0.0.1.0
|
version: 0.0.1.0
|
||||||
author: Profpatsch
|
author: Profpatsch
|
||||||
|
@ -8,7 +8,6 @@ library
|
||||||
exposed-modules:
|
exposed-modules:
|
||||||
MyPrelude
|
MyPrelude
|
||||||
Pretty
|
Pretty
|
||||||
Data.Error.Tree
|
|
||||||
Aeson
|
Aeson
|
||||||
RunCommand
|
RunCommand
|
||||||
Test
|
Test
|
||||||
|
@ -21,6 +20,7 @@ library
|
||||||
build-depends:
|
build-depends:
|
||||||
base >=4.15 && <5
|
base >=4.15 && <5
|
||||||
, pa-label
|
, pa-label
|
||||||
|
, pa-error-tree
|
||||||
, aeson
|
, aeson
|
||||||
, aeson-better-errors
|
, aeson-better-errors
|
||||||
, PyF
|
, PyF
|
||||||
|
|
|
@ -1,15 +1,6 @@
|
||||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||||
{-# LANGUAGE DeriveFunctor #-}
|
|
||||||
{-# LANGUAGE DerivingStrategies #-}
|
|
||||||
{-# LANGUAGE GHC2021 #-}
|
|
||||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
||||||
{-# LANGUAGE LambdaCase #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
{-# LANGUAGE TypeApplications #-}
|
|
||||||
|
|
||||||
module Netencode where
|
module Netencode where
|
||||||
|
|
||||||
|
@ -20,15 +11,12 @@ import Data.ByteString qualified as ByteString
|
||||||
import Data.ByteString.Builder (Builder)
|
import Data.ByteString.Builder (Builder)
|
||||||
import Data.ByteString.Builder qualified as Builder
|
import Data.ByteString.Builder qualified as Builder
|
||||||
import Data.ByteString.Lazy qualified as ByteString.Lazy
|
import Data.ByteString.Lazy qualified as ByteString.Lazy
|
||||||
import Data.Coerce (coerce)
|
|
||||||
import Data.Fix (Fix (Fix))
|
import Data.Fix (Fix (Fix))
|
||||||
import Data.Fix qualified as Fix
|
import Data.Fix qualified as Fix
|
||||||
import Data.Functor.Classes (Eq1 (liftEq))
|
import Data.Functor.Classes (Eq1 (liftEq))
|
||||||
import Data.Int (Int16, Int32, Int64, Int8)
|
import Data.Int (Int16, Int32, Int64, Int8)
|
||||||
import Data.List.NonEmpty (nonEmpty)
|
|
||||||
import Data.Map.NonEmpty (NEMap)
|
import Data.Map.NonEmpty (NEMap)
|
||||||
import Data.Map.NonEmpty qualified as NEMap
|
import Data.Map.NonEmpty qualified as NEMap
|
||||||
import Data.Maybe (fromMaybe)
|
|
||||||
import Data.Semigroup qualified as Semi
|
import Data.Semigroup qualified as Semi
|
||||||
import Data.String (IsString)
|
import Data.String (IsString)
|
||||||
import Data.Word (Word16, Word32, Word64)
|
import Data.Word (Word16, Word32, Word64)
|
||||||
|
@ -36,7 +24,7 @@ import GHC.Exts (fromString)
|
||||||
import Hedgehog qualified as Hedge
|
import Hedgehog qualified as Hedge
|
||||||
import Hedgehog.Gen qualified as Gen
|
import Hedgehog.Gen qualified as Gen
|
||||||
import Hedgehog.Range qualified as Range
|
import Hedgehog.Range qualified as Range
|
||||||
import MyPrelude
|
import PossehlAnalyticsPrelude
|
||||||
import Text.Show.Deriving
|
import Text.Show.Deriving
|
||||||
import Prelude hiding (sum)
|
import Prelude hiding (sum)
|
||||||
|
|
||||||
|
@ -74,7 +62,7 @@ instance Eq1 TF where
|
||||||
liftEq _ (I6 i64) (I6 i64') = i64 == i64'
|
liftEq _ (I6 i64) (I6 i64') = i64 == i64'
|
||||||
liftEq _ (Text t) (Text t') = t == t'
|
liftEq _ (Text t) (Text t') = t == t'
|
||||||
liftEq _ (Bytes b) (Bytes b') = b == b'
|
liftEq _ (Bytes b) (Bytes b') = b == b'
|
||||||
liftEq eq (Sum t) (Sum t') = eq (t & tagVal) (t' & tagVal)
|
liftEq eq (Sum t) (Sum t') = eq (t.tagVal) (t'.tagVal)
|
||||||
liftEq eq (Record m) (Record m') = liftEq eq m m'
|
liftEq eq (Record m) (Record m') = liftEq eq m m'
|
||||||
liftEq eq (List xs) (List xs') = liftEq eq xs xs'
|
liftEq eq (List xs) (List xs') = liftEq eq xs xs'
|
||||||
liftEq _ _ _ = False
|
liftEq _ _ _ = False
|
||||||
|
@ -292,7 +280,7 @@ netencodeParserF inner = do
|
||||||
Just tags ->
|
Just tags ->
|
||||||
pure $
|
pure $
|
||||||
tags
|
tags
|
||||||
<&> (\t -> (t & tagTag, t & tagVal))
|
<&> (\t -> (t.tagTag, t.tagVal))
|
||||||
-- later keys are preferred if they are duplicates, according to the standard
|
-- later keys are preferred if they are duplicates, according to the standard
|
||||||
& NEMap.fromList
|
& NEMap.fromList
|
||||||
_ <- Atto.Char.char '}' Atto.<?> "record did not end with }"
|
_ <- Atto.Char.char '}' Atto.<?> "record did not end with }"
|
||||||
|
|
|
@ -1,14 +1,4 @@
|
||||||
{-# LANGUAGE ApplicativeDo #-}
|
|
||||||
{-# LANGUAGE DataKinds #-}
|
|
||||||
{-# LANGUAGE DerivingVia #-}
|
|
||||||
{-# LANGUAGE GHC2021 #-}
|
|
||||||
{-# LANGUAGE LambdaCase #-}
|
|
||||||
{-# LANGUAGE OverloadedRecordDot #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
|
||||||
{-# LANGUAGE NoFieldSelectors #-}
|
|
||||||
{-# OPTIONS_GHC -Wall #-}
|
|
||||||
|
|
||||||
module Netencode.Parse where
|
module Netencode.Parse where
|
||||||
|
|
||||||
|
@ -23,8 +13,9 @@ import Data.Map.NonEmpty qualified as NEMap
|
||||||
import Data.Semigroupoid qualified as Semigroupiod
|
import Data.Semigroupoid qualified as Semigroupiod
|
||||||
import Data.Semigroupoid qualified as Semigroupoid
|
import Data.Semigroupoid qualified as Semigroupoid
|
||||||
import Data.Text qualified as Text
|
import Data.Text qualified as Text
|
||||||
import MyPrelude
|
import Label
|
||||||
import Netencode qualified
|
import Netencode qualified
|
||||||
|
import PossehlAnalyticsPrelude
|
||||||
import Prelude hiding (log)
|
import Prelude hiding (log)
|
||||||
|
|
||||||
newtype Parse from to
|
newtype Parse from to
|
||||||
|
|
|
@ -28,7 +28,9 @@ let
|
||||||
pkgs.haskellPackages.data-fix
|
pkgs.haskellPackages.data-fix
|
||||||
pkgs.haskellPackages.bytestring
|
pkgs.haskellPackages.bytestring
|
||||||
pkgs.haskellPackages.attoparsec
|
pkgs.haskellPackages.attoparsec
|
||||||
depot.users.Profpatsch.my-prelude
|
pkgs.haskellPackages.pa-prelude
|
||||||
|
pkgs.haskellPackages.pa-label
|
||||||
|
pkgs.haskellPackages.pa-error-tree
|
||||||
];
|
];
|
||||||
|
|
||||||
isLibrary = true;
|
isLibrary = true;
|
||||||
|
|
|
@ -1,25 +1,74 @@
|
||||||
cabal-version: 2.4
|
cabal-version: 3.0
|
||||||
name: netencode
|
name: netencode
|
||||||
version: 0.1.0.0
|
version: 0.1.0.0
|
||||||
author: Profpatsch
|
author: Profpatsch
|
||||||
maintainer: mail@profpatsch.de
|
maintainer: mail@profpatsch.de
|
||||||
|
|
||||||
|
|
||||||
|
common common-options
|
||||||
|
ghc-options:
|
||||||
|
-Wall
|
||||||
|
-Wno-type-defaults
|
||||||
|
-Wunused-packages
|
||||||
|
-Wredundant-constraints
|
||||||
|
-fwarn-missing-deriving-strategies
|
||||||
|
|
||||||
|
-- See https://downloads.haskell.org/ghc/latest/docs/users_guide/exts.html
|
||||||
|
-- for a description of all these extensions
|
||||||
|
default-extensions:
|
||||||
|
-- Infer Applicative instead of Monad where possible
|
||||||
|
ApplicativeDo
|
||||||
|
|
||||||
|
-- Allow literal strings to be Text
|
||||||
|
OverloadedStrings
|
||||||
|
|
||||||
|
-- Syntactic sugar improvements
|
||||||
|
LambdaCase
|
||||||
|
MultiWayIf
|
||||||
|
|
||||||
|
-- Makes the (deprecated) usage of * instead of Data.Kind.Type an error
|
||||||
|
NoStarIsType
|
||||||
|
|
||||||
|
-- Convenient and crucial to deal with ambiguous field names, commonly
|
||||||
|
-- known as RecordDotSyntax
|
||||||
|
OverloadedRecordDot
|
||||||
|
|
||||||
|
-- does not export record fields as functions, use OverloadedRecordDot to access instead
|
||||||
|
NoFieldSelectors
|
||||||
|
|
||||||
|
-- Record punning
|
||||||
|
RecordWildCards
|
||||||
|
|
||||||
|
-- Improved Deriving
|
||||||
|
DerivingStrategies
|
||||||
|
DerivingVia
|
||||||
|
|
||||||
|
-- Type-level strings
|
||||||
|
DataKinds
|
||||||
|
|
||||||
|
-- to enable the `type` keyword in import lists (ormolu uses this automatically)
|
||||||
|
ExplicitNamespaces
|
||||||
|
|
||||||
|
default-language: GHC2021
|
||||||
|
|
||||||
|
|
||||||
library
|
library
|
||||||
|
import: common-options
|
||||||
exposed-modules:
|
exposed-modules:
|
||||||
Netencode,
|
Netencode,
|
||||||
Netencode.Parse
|
Netencode.Parse
|
||||||
|
|
||||||
build-depends:
|
build-depends:
|
||||||
base >=4.15 && <5,
|
base >=4.15 && <5,
|
||||||
|
pa-prelude,
|
||||||
|
pa-label,
|
||||||
|
pa-error-tree,
|
||||||
hedgehog,
|
hedgehog,
|
||||||
nonempty-containers,
|
nonempty-containers,
|
||||||
deriving-compat,
|
deriving-compat,
|
||||||
my-prelude,
|
|
||||||
data-fix,
|
data-fix,
|
||||||
bytestring,
|
bytestring,
|
||||||
attoparsec,
|
attoparsec,
|
||||||
text,
|
text,
|
||||||
semigroupoids,
|
semigroupoids,
|
||||||
selective
|
selective
|
||||||
|
|
||||||
default-language: Haskell2010
|
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
cabal-version: 2.4
|
cabal-version: 3.0
|
||||||
name: reverse-haskell-deps
|
name: reverse-haskell-deps
|
||||||
version: 0.1.0.0
|
version: 0.1.0.0
|
||||||
author: Profpatsch
|
author: Profpatsch
|
||||||
|
|
|
@ -21,6 +21,7 @@ pkgs.mkShell {
|
||||||
h.ihp-hsx
|
h.ihp-hsx
|
||||||
h.PyF
|
h.PyF
|
||||||
h.unliftio
|
h.unliftio
|
||||||
|
h.xml-conduit
|
||||||
h.wai
|
h.wai
|
||||||
h.wai-extra
|
h.wai-extra
|
||||||
h.warp
|
h.warp
|
||||||
|
@ -42,11 +43,8 @@ pkgs.mkShell {
|
||||||
h.case-insensitive
|
h.case-insensitive
|
||||||
h.hscolour
|
h.hscolour
|
||||||
h.nicify-lib
|
h.nicify-lib
|
||||||
|
h.hspec
|
||||||
h.hspec-expectations-pretty-diff
|
h.hspec-expectations-pretty-diff
|
||||||
depot.users.Profpatsch.my-prelude
|
|
||||||
depot.users.Profpatsch.netencode.netencode-hs
|
|
||||||
depot.users.Profpatsch.arglib.netencode.haskell
|
|
||||||
depot.users.Profpatsch.execline.exec-helpers-hs
|
|
||||||
]))
|
]))
|
||||||
|
|
||||||
pkgs.rustup
|
pkgs.rustup
|
||||||
|
|
Loading…
Reference in a new issue