about summary refs log tree commit diff
path: root/users/Profpatsch
diff options
context:
space:
mode:
Diffstat (limited to 'users/Profpatsch')
-rw-r--r--users/Profpatsch/cas-serve/CasServe.hs247
-rw-r--r--users/Profpatsch/cas-serve/cas-serve.cabal24
-rw-r--r--users/Profpatsch/cas-serve/default.nix27
-rw-r--r--users/Profpatsch/cas-serve/schema.sql38
-rw-r--r--users/Profpatsch/cas-serve/wordlist.json1
-rw-r--r--users/Profpatsch/cas-serve/wordlist.sqlitebin0 -> 36864 bytes
-rw-r--r--users/Profpatsch/my-prelude/MyPrelude.hs540
-rw-r--r--users/Profpatsch/my-prelude/default.nix24
-rw-r--r--users/Profpatsch/my-prelude/my-prelude.cabal27
9 files changed, 928 insertions, 0 deletions
diff --git a/users/Profpatsch/cas-serve/CasServe.hs b/users/Profpatsch/cas-serve/CasServe.hs
new file mode 100644
index 000000000000..3e658e58ccff
--- /dev/null
+++ b/users/Profpatsch/cas-serve/CasServe.hs
@@ -0,0 +1,247 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# 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 Data.Functor.Compose
+import Data.Int (Int64)
+import qualified Data.List as List
+import Data.Maybe (fromMaybe)
+import qualified Data.Text as Text
+import qualified Data.Text.IO 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 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 System.IO (stderr)
+import Control.Monad.Reader
+
+main :: IO ()
+main = do
+  withEnv $ \env ->
+    Warp.runSettings
+      (Warp.defaultSettings & Warp.setPort 7070)
+      (api env)
+
+withEnv :: (Env -> IO a) -> IO a
+withEnv inner = do
+  withSqlite "./data.sqlite" $ \envData -> do
+    withSqlite "./wordlist.sqlite" $ \envWordlist -> inner Env {..}
+
+withSqlite :: String -> (Sqlite.Connection -> IO a) -> IO a
+withSqlite fileName inner = Sqlite.withConnection fileName $ \conn -> do
+  Sqlite.setTrace conn (Just (\msg -> Text.hPutStrLn stderr [fmt|{fileName}: {msg}|]))
+  Sqlite.execute conn [Sqlite.sql|PRAGMA foreign_keys = ON|] ()
+  inner conn
+
+api :: Env -> Wai.Application
+api env req respond = do
+  case runHandler (getById <|> insertById) req env of
+    Nothing -> respond $ Wai.responseLBS Http.status404 [] "endpoint does not exist."
+    Just handler' -> do
+      handler' >>= \case
+        Left (status, err) -> respond $ Wai.responseLBS status [] (err & toLazyBytes)
+        Right (headers, body) ->
+          respond $
+            Wai.responseLBS
+              Http.status200
+              headers
+              ( body & toLazyBytes
+              )
+
+data Env = Env
+  { envWordlist :: Sqlite.Connection,
+    envData :: Sqlite.Connection
+  }
+
+-- | 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 )
+  deriving newtype (Functor, Applicative, Alternative)
+
+handler :: ((Wai.Request, Env) -> Maybe (IO a)) -> Handler a
+handler f = Handler (ReaderT (Compose . f))
+
+runHandler :: Handler a -> Wai.Request -> Env -> Maybe (IO a)
+runHandler (Handler handler') req env = getCompose $ handler' & (\readerT -> runReaderT readerT (req, env))
+
+getById ::
+  Handler
+    ( Either
+        (Http.Status, ByteString)
+        ([(Http.HeaderName, ByteString)], ByteString)
+    )
+getById = handler $ \(req, env) -> do
+  guard ((req & Wai.requestMethod) == Http.methodGet)
+  case req & Wai.pathInfo of
+    ["v0", "by-id", filename] -> Just $ do
+      Sqlite.queryNamed
+        @( Rec.Rec
+             [ "mimetype" Rec.:= Text,
+               "content" Rec.:= ByteString,
+               "size" Rec.:= Int
+             ]
+         )
+        (env & envData)
+        [Sqlite.sql|
+        SELECT
+          mimetype,
+          cast (content AS blob) as content,
+          size
+        FROM file_content
+        JOIN file_references
+          ON file_references.file_content = file_content.hash_sha256
+        WHERE
+          file_references.reference_type = 'by-id'
+          AND (file_references.name || file_references.extension) = :filename
+       |]
+        [":filename" Sqlite.:= filename]
+        <&> \case
+          [] -> Left (Http.status404, "File not found.")
+          [res] ->
+            Right
+              ( [ ("Content-Type", res & Rec.get #mimetype & textToBytesUtf8),
+                  ("Content-Length", res & Rec.get #size & showToText & textToBytesUtf8)
+                ],
+                -- TODO: should this be lazy/streamed?
+                res & Rec.get #content
+              )
+          _more -> Left "file_references must be unique (in type and name)" & unwrapError
+    _ -> Nothing
+
+insertById :: Handler (Either a ([(Http.HeaderName, ByteString)], ByteString))
+insertById = handler $ \(req, env) -> do
+  guard ((req & Wai.requestMethod) == Http.methodPost)
+  case req & Wai.pathInfo of
+    ["v0", "by-id"] -> Just $ do
+      let maybeText bytes = case bytesToTextUtf8 bytes of
+            Left _err -> Nothing
+            Right t -> Just t
+      let mimeType =
+            ( (req & Wai.requestHeaders & List.lookup "X-Cas-Serve-Mimetype" >>= maybeText)
+                <|> (req & Wai.requestHeaders & List.lookup "Content-Type" >>= maybeText)
+            )
+              & fromMaybe "application/octet-stream"
+
+      let magicFileEnding mimeType' = case Text.split (== '/') mimeType' of
+            [_, ""] -> Nothing
+            ["", _] -> Nothing
+            [_, "any"] -> Nothing
+            ["image", ty] -> Just (Text.cons '.' ty)
+            ["video", ty] -> Just (Text.cons '.' ty)
+            ["text", "plain"] -> Just ".txt"
+            ["text", "html"] -> Just ".html"
+            ["application", "pdf"] -> Just ".pdf"
+            ["application", "json"] -> Just ".json"
+            _ -> Nothing
+
+      let extension =
+            ( (req & Wai.requestHeaders & List.lookup "X-Cas-Serve-FileExtension" >>= maybeText)
+                <|> ( (req & Wai.requestHeaders & List.lookup "Content-Type")
+                        >>= maybeText
+                        >>= magicFileEnding
+                    )
+            )
+              -- Just the empty extension if we can’t figure it out.
+              & fromMaybe ""
+
+      body <- Wai.consumeRequestBodyStrict req
+      let hash :: Crypto.Digest Crypto.SHA256 = Crypto.hashlazy body
+      let hashBytes = hash & ByteArray.convert @(Crypto.Digest Crypto.SHA256) @ByteString
+      let len = ByteString.Lazy.length body
+      name <- getNameFromWordlist env
+      let fullname = name <> extension
+
+      let conn = env & envData
+      Sqlite.withTransaction conn $ do
+        Sqlite.executeNamed
+          conn
+          [Sqlite.sql|
+            INSERT INTO file_content
+              (content, hash_sha256, size)
+              VALUES
+              (:content, :hash_sha256, :size)
+              ON CONFLICT (hash_sha256) DO NOTHING
+          |]
+          [ ":content" := (body :: Lazy.ByteString),
+            ":hash_sha256" := (hashBytes :: ByteString),
+            ":size" := (len :: Int64)
+          ]
+
+        -- TODO: we are not checking if the name already exists,
+        -- we just assume that 1633^3 is enough to not get any collisions for now.
+        -- If the name exists, the user gets a 500.
+        Sqlite.executeNamed
+          conn
+          [Sqlite.sql|
+            INSERT INTO file_references
+              (file_content, reference_type, name, extension, mimetype)
+            VALUES
+              (:file_content, :reference_type, :name, :extension, :mimetype)
+          |]
+          [ ":file_content" := (hashBytes :: ByteString),
+            ":reference_type" := ("by-id" :: Text),
+            ":name" := name,
+            ":extension" := (extension :: Text),
+            ":mimetype" := (mimeType :: Text)
+          ]
+      pure $
+        Right
+          ( [("Content-Type", "text/plain")],
+            [fmt|/v0/by-id/{fullname}|]
+          )
+    _ -> Nothing
+
+-- Get a random name from a wordlist, that is three words connected by @-@.
+getNameFromWordlist :: Env -> IO Text
+getNameFromWordlist env =
+  do
+    let numberOfWords = 3 :: Int
+    Sqlite.queryNamed @(Sqlite.Only Text)
+      (env & envWordlist)
+      [Sqlite.sql|SELECT word FROM wordlist ORDER BY RANDOM() LIMIT :words|]
+      [":words" Sqlite.:= numberOfWords]
+    <&> map Sqlite.fromOnly
+    <&> Text.intercalate "-"
+
+-- | 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.FromRow (Rec.Rec rec)
+  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
diff --git a/users/Profpatsch/cas-serve/cas-serve.cabal b/users/Profpatsch/cas-serve/cas-serve.cabal
new file mode 100644
index 000000000000..8740e8737de8
--- /dev/null
+++ b/users/Profpatsch/cas-serve/cas-serve.cabal
@@ -0,0 +1,24 @@
+cabal-version:      2.4
+name:               cas-serve
+version:            0.1.0.0
+author:             Profpatsch
+maintainer:         mail@profpatsch.de
+
+executable cas-serve
+    main-is:          CasServe.hs
+
+    build-depends:
+        base ^>=4.15.1.0,
+        text,
+        sqlite-simple,
+        http-types,
+        wai,
+        warp,
+        mtl,
+        my-prelude,
+        bytestring,
+        memory,
+        cryptonite,
+        superrecord
+
+    default-language: Haskell2010
diff --git a/users/Profpatsch/cas-serve/default.nix b/users/Profpatsch/cas-serve/default.nix
new file mode 100644
index 000000000000..2236e92c8e13
--- /dev/null
+++ b/users/Profpatsch/cas-serve/default.nix
@@ -0,0 +1,27 @@
+{ depot, pkgs, lib, ... }:
+
+let
+  cas-serve = pkgs.writers.writeHaskell "cas-serve"
+    {
+      libraries = [
+        pkgs.haskellPackages.wai
+        pkgs.haskellPackages.warp
+        pkgs.haskellPackages.sqlite-simple
+        depot.users.Profpatsch.my-prelude
+        (pkgs.haskell.lib.dontCheck
+          (pkgs.haskell.lib.overrideSrc pkgs.haskellPackages.superrecord {
+            src = pkgs.fetchFromGitHub {
+              owner = "Profpatsch";
+              repo = "superrecord";
+              rev = "c00e933f582e3fb8d209f6cece91d464faf09082";
+              sha256 = "sha256-UQ2wCoBpUEPcRsI7wNOFGH+vceKF4dcbbGHFVVTkOWw=";
+            };
+          }))
+
+      ];
+      ghcArgs = [ "-threaded" ];
+
+    } ./CasServe.hs;
+
+in
+cas-serve
diff --git a/users/Profpatsch/cas-serve/schema.sql b/users/Profpatsch/cas-serve/schema.sql
new file mode 100644
index 000000000000..b61a7a1ad57d
--- /dev/null
+++ b/users/Profpatsch/cas-serve/schema.sql
@@ -0,0 +1,38 @@
+-- SQLite
+.dump
+
+PRAGMA foreign_keys = ON;
+
+BEGIN transaction;
+
+create table if not exists file_content (
+  content blob NOT NULL,
+  hash_sha256 blob PRIMARY KEY,
+  size integer NOT NULL
+) WITHOUT ROWID;
+
+
+create table if not exists file_references (
+  rowid integer PRIMARY KEY,
+  file_content NOT NULL REFERENCES file_content ON DELETE CASCADE,
+  reference_type text NOT NULL,
+  name text NOT NULL,
+  extension text NOT NULL,
+  mimetype text NOT NULL
+);
+
+create unique index if not exists file_references_type_name_unique on file_references (reference_type, name);
+
+-- insert into file_content values ('mycontent', 'myhash', 9);
+-- insert into file_references values (NULL, 'myhash', 'by-id', 'myschranz', '.txt', 'text/plain');
+-- insert into file_content values (readfile('/home/philip/Pictures/screenshot.png'), 'anotherhash', 999);
+-- insert into file_references values (NULL, 'anotherhash', 'by-id', 'img', '.png', 'image/png');
+
+select * from file_content;
+
+select * from file_references;
+
+COMMIT;
+
+-- drop table file_content;
+-- drop table file_references;
diff --git a/users/Profpatsch/cas-serve/wordlist.json b/users/Profpatsch/cas-serve/wordlist.json
new file mode 100644
index 000000000000..cc4bc62ad153
--- /dev/null
+++ b/users/Profpatsch/cas-serve/wordlist.json
@@ -0,0 +1 @@
+ [ "acrobat", "africa", "alaska", "albert", "albino", "album", "alcohol", "alex", "alpha", "amadeus", "amanda", "amazon", "america", "analog", "animal", "antenna", "antonio", "apollo", "april", "aroma", "artist", "aspirin", "athlete", "atlas", "banana", "bandit", "banjo", "bikini", "bingo", "bonus", "camera", "canada", "carbon", "casino", "catalog", "cinema", "citizen", "cobra", "comet", "compact", "complex", "context", "credit", "critic", "crystal", "culture", "david", "delta", "dialog", "diploma", "doctor", "domino", "dragon", "drama", "extra", "fabric", "final", "focus", "forum", "galaxy", "gallery", "global", "harmony", "hotel", "humor", "index", "japan", "kilo", "lemon", "liter", "lotus", "mango", "melon", "menu", "meter", "metro", "mineral", "model", "music", "object", "piano", "pirate", "plastic", "radio", "report", "signal", "sport", "studio", "subject", "super", "tango", "taxi", "tempo", "tennis", "textile", "tokyo", "total", "tourist", "video", "visa", "academy", "alfred", "atlanta", "atomic", "barbara", "bazaar", "brother", "budget", "cabaret", "cadet", "candle", "capsule", "caviar", "channel", "chapter", "circle", "cobalt", "comrade", "condor", "crimson", "cyclone", "darwin", "declare", "denver", "desert", "divide", "dolby", "domain", "double", "eagle", "echo", "eclipse", "editor", "educate", "edward", "effect", "electra", "emerald", "emotion", "empire", "eternal", "evening", "exhibit", "expand", "explore", "extreme", "ferrari", "forget", "freedom", "friday", "fuji", "galileo", "genesis", "gravity", "habitat", "hamlet", "harlem", "helium", "holiday", "hunter", "ibiza", "iceberg", "imagine", "infant", "isotope", "jackson", "jamaica", "jasmine", "java", "jessica", "kitchen", "lazarus", "letter", "license", "lithium", "loyal", "lucky", "magenta", "manual", "marble", "maxwell", "mayor", "monarch", "monday", "money", "morning", "mother", "mystery", "native", "nectar", "nelson", "network", "nikita", "nobel", "nobody", "nominal", "norway", "nothing", "number", "october", "office", "oliver", "opinion", "option", "order", "outside", "package", "pandora", "panther", "papa", "pattern", "pedro", "pencil", "people", "phantom", "philips", "pioneer", "pluto", "podium", "portal", "potato", "process", "proxy", "pupil", "python", "quality", "quarter", "quiet", "rabbit", "radical", "radius", "rainbow", "ramirez", "ravioli", "raymond", "respect", "respond", "result", "resume", "richard", "river", "roger", "roman", "rondo", "sabrina", "salary", "salsa", "sample", "samuel", "saturn", "savage", "scarlet", "scorpio", "sector", "serpent", "shampoo", "sharon", "silence", "simple", "society", "sonar", "sonata", "soprano", "sparta", "spider", "sponsor", "abraham", "action", "active", "actor", "adam", "address", "admiral", "adrian", "agenda", "agent", "airline", "airport", "alabama", "aladdin", "alarm", "algebra", "alibi", "alice", "alien", "almond", "alpine", "amber", "amigo", "ammonia", "analyze", "anatomy", "angel", "annual", "answer", "apple", "archive", "arctic", "arena", "arizona", "armada", "arnold", "arsenal", "arthur", "asia", "aspect", "athena", "audio", "august", "austria", "avenue", "average", "axiom", "aztec", "bagel", "baker", "balance", "ballad", "ballet", "bambino", "bamboo", "baron", "basic", "basket", "battery", "belgium", "benefit", "berlin", "bermuda", "bernard", "bicycle", "binary", "biology", "bishop", "blitz", "block", "blonde", "bonjour", "boris", "boston", "bottle", "boxer", "brandy", "bravo", "brazil", "bridge", "british", "bronze", "brown", "bruce", "bruno", "brush", "burger", "burma", "cabinet", "cactus", "cafe", "cairo", "calypso", "camel", "campus", "canal", "cannon", "canoe", "cantina", "canvas", "canyon", "capital", "caramel", "caravan", "career", "cargo", "carlo", "carol", "carpet", "cartel", "cartoon", "castle", "castro", "cecilia", "cement", "center", "century", "ceramic", "chamber", "chance", "change", "chaos", "charlie", "charm", "charter", "cheese", "chef", "chemist", "cherry", "chess", "chicago", "chicken", "chief", "china", "cigar", "circus", "city", "clara", "classic", "claudia", "clean", "client", "climax", "clinic", "clock", "club", "cockpit", "coconut", "cola", "collect", "colombo", "colony", "color", "combat", "comedy", "command", "company", "concert", "connect", "consul", "contact", "contour", "control", "convert", "copy", "corner", "corona", "correct", "cosmos", "couple", "courage", "cowboy", "craft", "crash", "cricket", "crown", "cuba", "dallas", "dance", "daniel", "decade", "decimal", "degree", "delete", "deliver", "delphi", "deluxe", "demand", "demo", "denmark", "derby", "design", "detect", "develop", "diagram", "diamond", "diana", "diego", "diesel", "diet", "digital", "dilemma", "direct", "disco", "disney", "distant", "dollar", "dolphin", "donald", "drink", "driver", "dublin", "duet", "dynamic", "earth", "east", "ecology", "economy", "edgar", "egypt", "elastic", "elegant", "element", "elite", "elvis", "email", "empty", "energy", "engine", "english", "episode", "equator", "escape", "escort", "ethnic", "europe", "everest", "evident", "exact", "example", "exit", "exotic", "export", "express", "factor", "falcon", "family", "fantasy", "fashion", "fiber", "fiction", "fidel", "fiesta", "figure", "film", "filter", "finance", "finish", "finland", "first", "flag", "flash", "florida", "flower", "fluid", "flute", "folio", "ford", "forest", "formal", "formula", "fortune", "forward", "fragile", "france", "frank", "fresh", "friend", "frozen", "future", "gabriel", "gamma", "garage", "garcia", "garden", "garlic", "gemini", "general", "genetic", "genius", "germany", "gloria", "gold", "golf", "gondola", "gong", "good", "gordon", "gorilla", "grand", "granite", "graph", "green", "group", "guide", "guitar", "guru", "hand", "happy", "harbor", "harvard", "havana", "hawaii", "helena", "hello", "henry", "hilton", "history", "horizon", "house", "human", "icon", "idea", "igloo", "igor", "image", "impact", "import", "india", "indigo", "input", "insect", "instant", "iris", "italian", "jacket", "jacob", "jaguar", "janet", "jargon", "jazz", "jeep", "john", "joker", "jordan", "judo", "jumbo", "june", "jungle", "junior", "jupiter", "karate", "karma", "kayak", "kermit", "king", "koala", "korea", "labor", "lady", "lagoon", "laptop", "laser", "latin", "lava", "lecture", "left", "legal", "level", "lexicon", "liberal", "libra", "lily", "limbo", "limit", "linda", "linear", "lion", "liquid", "little", "llama", "lobby", "lobster", "local", "logic", "logo", "lola", "london", "lucas", "lunar", "machine", "macro", "madam", "madonna", "madrid", "maestro", "magic", "magnet", "magnum", "mailbox", "major", "mama", "mambo", "manager", "manila", "marco", "marina", "market", "mars", "martin", "marvin", "mary", "master", "matrix", "maximum", "media", "medical", "mega", "melody", "memo", "mental", "mentor", "mercury", "message", "metal", "meteor", "method", "mexico", "miami", "micro", "milk", "million", "minimum", "minus", "minute", "miracle", "mirage", "miranda", "mister", "mixer", "mobile", "modem", "modern", "modular", "moment", "monaco", "monica", "monitor", "mono", "monster", "montana", "morgan", "motel", "motif", "motor", "mozart", "multi", "museum", "mustang", "natural", "neon", "nepal", "neptune", "nerve", "neutral", "nevada", "news", "next", "ninja", "nirvana", "normal", "nova", "novel", "nuclear", "numeric", "nylon", "oasis", "observe", "ocean", "octopus", "olivia", "olympic", "omega", "opera", "optic", "optimal", "orange", "orbit", "organic", "orient", "origin", "orlando", "oscar", "oxford", "oxygen", "ozone", "pablo", "pacific", "pagoda", "palace", "pamela", "panama", "pancake", "panda", "panel", "panic", "paradox", "pardon", "paris", "parker", "parking", "parody", "partner", "passage", "passive", "pasta", "pastel", "patent", "patient", "patriot", "patrol", "pegasus", "pelican", "penguin", "pepper", "percent", "perfect", "perfume", "period", "permit", "person", "peru", "phone", "photo", "picasso", "picnic", "picture", "pigment", "pilgrim", "pilot", "pixel", "pizza", "planet", "plasma", "plaza", "pocket", "poem", "poetic", "poker", "polaris", "police", "politic", "polo", "polygon", "pony", "popcorn", "popular", "postage", "precise", "prefix", "premium", "present", "price", "prince", "printer", "prism", "private", "prize", "product", "profile", "program", "project", "protect", "proton", "public", "pulse", "puma", "pump", "pyramid", "queen", "radar", "ralph", "random", "rapid", "rebel", "record", "recycle", "reflex", "reform", "regard", "regular", "relax", "reptile", "reverse", "ricardo", "right", "ringo", "risk", "ritual", "robert", "robot", "rocket", "rodeo", "romeo", "royal", "russian", "safari", "salad", "salami", "salmon", "salon", "salute", "samba", "sandra", "santana", "sardine", "school", "scoop", "scratch", "screen", "script", "scroll", "second", "secret", "section", "segment", "select", "seminar", "senator", "senior", "sensor", "serial", "service", "shadow", "sharp", "sheriff", "shock", "short", "shrink", "sierra", "silicon", "silk", "silver", "similar", "simon", "single", "siren", "slang", "slogan", "smart", "smoke", "snake", "social", "soda", "solar", "solid", "solo", "sonic", "source", "soviet", "special", "speed", "sphere", "spiral", "spirit", "spring", "static", "status", "stereo", "stone", "stop", "street", "strong", "student", "style", "sultan", "susan", "sushi", "suzuki", "switch", "symbol", "system", "tactic", "tahiti", "talent", "tarzan", "telex", "texas", "theory", "thermos", "tiger", "titanic", "tomato", "topic", "tornado", "toronto", "torpedo", "totem", "tractor", "traffic", "transit", "trapeze", "travel", "tribal", "trick", "trident", "trilogy", "tripod", "tropic", "trumpet", "tulip", "tuna", "turbo", "twist", "ultra", "uniform", "union", "uranium", "vacuum", "valid", "vampire", "vanilla", "vatican", "velvet", "ventura", "venus", "vertigo", "veteran", "victor", "vienna", "viking", "village", "vincent", "violet", "violin", "virtual", "virus", "vision", "visitor", "visual", "vitamin", "viva", "vocal", "vodka", "volcano", "voltage", "volume", "voyage", "water", "weekend", "welcome", "western", "window", "winter", "wizard", "wolf", "world", "xray", "yankee", "yoga", "yogurt", "yoyo", "zebra", "zero", "zigzag", "zipper", "zodiac", "zoom", "acid", "adios", "agatha", "alamo", "alert", "almanac", "aloha", "andrea", "anita", "arcade", "aurora", "avalon", "baby", "baggage", "balloon", "bank", "basil", "begin", "biscuit", "blue", "bombay", "botanic", "brain", "brenda", "brigade", "cable", "calibre", "carmen", "cello", "celtic", "chariot", "chrome", "citrus", "civil", "cloud", "combine", "common", "cool", "copper", "coral", "crater", "cubic", "cupid", "cycle", "depend", "door", "dream", "dynasty", "edison", "edition", "enigma", "equal", "eric", "event", "evita", "exodus", "extend", "famous", "farmer", "food", "fossil", "frog", "fruit", "geneva", "gentle", "george", "giant", "gilbert", "gossip", "gram", "greek", "grille", "hammer", "harvest", "hazard", "heaven", "herbert", "heroic", "hexagon", "husband", "immune", "inca", "inch", "initial", "isabel", "ivory", "jason", "jerome", "joel", "joshua", "journal", "judge", "juliet", "jump", "justice", "kimono", "kinetic", "leonid", "leopard", "lima", "maze", "medusa", "member", "memphis", "michael", "miguel", "milan", "mile", "miller", "mimic", "mimosa", "mission", "monkey", "moral", "moses", "mouse", "nancy", "natasha", "nebula", "nickel", "nina", "noise", "orchid", "oregano", "origami", "orinoco", "orion", "othello", "paper", "paprika", "prelude", "prepare", "pretend", "promise", "prosper", "provide", "puzzle", "remote", "repair", "reply", "rival", "riviera", "robin", "rose", "rover", "rudolf", "saga", "sahara", "scholar", "shelter", "ship", "shoe", "sigma", "sister", "sleep", "smile", "spain", "spark", "split", "spray", "square", "stadium", "star", "storm", "story", "strange", "stretch", "stuart", "subway", "sugar", "sulfur", "summer", "survive", "sweet", "swim", "table", "taboo", "target", "teacher", "telecom", "temple", "tibet", "ticket", "tina", "today", "toga", "tommy", "tower", "trivial", "tunnel", "turtle", "twin", "uncle", "unicorn", "unique", "update", "valery", "vega", "version", "voodoo", "warning", "william", "wonder", "year", "yellow", "young", "absent", "absorb", "absurd", "accent", "alfonso", "alias", "ambient", "anagram", "andy", "anvil", "appear", "apropos", "archer", "ariel", "armor", "arrow", "austin", "avatar", "axis", "baboon", "bahama", "bali", "balsa", "barcode", "bazooka", "beach", "beast", "beatles", "beauty", "before", "benny", "betty", "between", "beyond", "billy", "bison", "blast", "bless", "bogart", "bonanza", "book", "border", "brave", "bread", "break", "broken", "bucket", "buenos", "buffalo", "bundle", "button", "buzzer", "byte", "caesar", "camilla", "canary", "candid", "carrot", "cave", "chant", "child", "choice", "chris", "cipher", "clarion", "clark", "clever", "cliff", "clone", "conan", "conduct", "congo", "costume", "cotton", "cover", "crack", "current", "danube", "data", "decide", "deposit", "desire", "detail", "dexter", "dinner", "donor", "druid", "drum", "easy", "eddie", "enjoy", "enrico", "epoxy", "erosion", "except", "exile", "explain", "fame", "fast", "father", "felix", "field", "fiona", "fire", "fish", "flame", "flex", "flipper", "float", "flood", "floor", "forbid", "forever", "fractal", "frame", "freddie", "front", "fuel", "gallop", "game", "garbo", "gate", "gelatin", "gibson", "ginger", "giraffe", "gizmo", "glass", "goblin", "gopher", "grace", "gray", "gregory", "grid", "griffin", "ground", "guest", "gustav", "gyro", "hair", "halt", "harris", "heart", "heavy", "herman", "hippie", "hobby", "honey", "hope", "horse", "hostel", "hydro", "imitate", "info", "ingrid", "inside", "invent", "invest", "invite", "ivan", "james", "jester", "jimmy", "join", "joseph", "juice", "julius", "july", "kansas", "karl", "kevin", "kiwi", "ladder", "lake", "laura", "learn", "legacy", "legend", "lesson", "life", "light", "list", "locate", "lopez", "lorenzo", "love", "lunch", "malta", "mammal", "margin", "margo", "marion", "mask", "match", "mayday", "meaning", "mercy", "middle", "mike", "mirror", "modest", "morph", "morris", "mystic", "nadia", "nato", "navy", "needle", "neuron", "never", "newton", "nice", "night", "nissan", "nitro", "nixon", "north", "oberon", "octavia", "ohio", "olga", "open", "opus", "orca", "oval", "owner", "page", "paint", "palma", "parent", "parlor", "parole", "paul", "peace", "pearl", "perform", "phoenix", "phrase", "pierre", "pinball", "place", "plate", "plato", "plume", "pogo", "point", "polka", "poncho", "powder", "prague", "press", "presto", "pretty", "prime", "promo", "quest", "quick", "quiz", "quota", "race", "rachel", "raja", "ranger", "region", "remark", "rent", "reward", "rhino", "ribbon", "rider", "road", "rodent", "round", "rubber", "ruby", "rufus", "sabine", "saddle", "sailor", "saint", "salt", "scale", "scuba", "season", "secure", "shake", "shallow", "shannon", "shave", "shelf", "sherman", "shine", "shirt", "side", "sinatra", "sincere", "size", "slalom", "slow", "small", "snow", "sofia", "song", "sound", "south", "speech", "spell", "spend", "spoon", "stage", "stamp", "stand", "state", "stella", "stick", "sting", "stock", "store", "sunday", "sunset", "support", "supreme", "sweden", "swing", "tape", "tavern", "think", "thomas", "tictac", "time", "toast", "tobacco", "tonight", "torch", "torso", "touch", "toyota", "trade", "tribune", "trinity", "triton", "truck", "trust", "type", "under", "unit", "urban", "urgent", "user", "value", "vendor", "venice", "verona", "vibrate", "virgo", "visible", "vista", "vital", "voice", "vortex", "waiter", "watch", "wave", "weather", "wedding", "wheel", "whiskey", "wisdom", "android", "annex", "armani", "cake", "confide", "deal", "define", "dispute", "genuine", "idiom", "impress", "include", "ironic", "null", "nurse", "obscure", "prefer", "prodigy", "ego", "fax", "jet", "job", "rio", "ski", "yes" ]
diff --git a/users/Profpatsch/cas-serve/wordlist.sqlite b/users/Profpatsch/cas-serve/wordlist.sqlite
new file mode 100644
index 000000000000..5074474ba0a6
--- /dev/null
+++ b/users/Profpatsch/cas-serve/wordlist.sqlite
Binary files differdiff --git a/users/Profpatsch/my-prelude/MyPrelude.hs b/users/Profpatsch/my-prelude/MyPrelude.hs
new file mode 100644
index 000000000000..a2c99bc9ead2
--- /dev/null
+++ b/users/Profpatsch/my-prelude/MyPrelude.hs
@@ -0,0 +1,540 @@
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module MyPrelude
+  ( -- * Text conversions
+    Text,
+    ByteString,
+    Word8,
+    fmt,
+    textToString,
+    stringToText,
+    showToText,
+    textToBytesUtf8,
+    textToBytesUtf8Lazy,
+    bytesToTextUtf8,
+    bytesToTextUtf8Lazy,
+    bytesToTextUtf8Lenient,
+    bytesToTextUtf8LenientLazy,
+    bytesToTextUtf8Unsafe,
+    bytesToTextUtf8UnsafeLazy,
+    toStrict,
+    toLazy,
+    toStrictBytes,
+    toLazyBytes,
+    charToWordUnsafe,
+
+    -- * IO
+    putStrLn,
+    putStderrLn,
+    exitWithMessage,
+
+    -- * WIP code
+    todo,
+
+    -- * Control flow
+    (&),
+    (<&>),
+    (<|>),
+    foldMap1,
+    foldMap',
+    join,
+    when,
+    unless,
+    guard,
+    ExceptT,
+    runExceptT,
+    MonadError,
+    throwError,
+    MonadIO,
+    liftIO,
+    MonadReader,
+    asks,
+    Bifunctor,
+    first,
+    second,
+    bimap,
+    foldMap,
+    fold,
+    foldl',
+    mapMaybe,
+    findMaybe,
+    Traversable,
+    for,
+    for_,
+    traverse,
+    traverse_,
+    traverseFold,
+    traverseFold1,
+    traverseFoldDefault,
+
+    -- * Data types
+    Coercible,
+    coerce,
+    Proxy (Proxy),
+    Map,
+    annotate,
+    Validation (Success, Failure),
+    failure,
+    successes,
+    failures,
+    eitherToValidation,
+    eitherToListValidation,
+    validationToEither,
+    These (This, That, These),
+    eitherToThese,
+    eitherToListThese,
+    validationToThese,
+    thenThese,
+    thenValidate,
+    NonEmpty ((:|)),
+    singleton,
+    nonEmpty,
+    nonEmptyDef,
+    toList,
+    toNonEmptyDefault,
+    maximum1,
+    minimum1,
+    Generic,
+    Semigroup,
+    sconcat,
+    Monoid,
+    mconcat,
+    Void,
+    absurd,
+    Identity (Identity, runIdentity),
+    Natural,
+    intToNatural,
+    Contravariant,
+    contramap,
+    (>$<),
+    (>&<),
+    Profunctor,
+    dimap,
+    lmap,
+    rmap,
+    Semigroupoid,
+    Category,
+    (<<<),
+    (>>>),
+
+    -- * Enum definition
+    inverseFunction,
+    inverseMap,
+
+    -- * Error handling
+    HasCallStack,
+    module Data.Error,
+    smushErrors,
+  )
+where
+
+import Control.Applicative ((<|>))
+import Control.Category (Category, (<<<), (>>>))
+import Control.Monad (guard, join, unless, when)
+import Control.Monad.Except
+  ( ExceptT,
+    MonadError,
+    runExceptT,
+    throwError,
+  )
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Control.Monad.Identity (Identity (Identity))
+import Control.Monad.Reader (MonadReader, asks)
+import Data.Bifunctor (Bifunctor, bimap, first, second)
+import Data.ByteString
+  ( ByteString,
+  )
+import qualified Data.ByteString.Lazy
+import qualified Data.Char
+import Data.Coerce (Coercible, coerce)
+import Data.Data (Proxy (Proxy))
+import Data.Error
+import Data.Foldable (Foldable (foldMap', toList), fold, foldl', for_, traverse_)
+import qualified Data.Foldable as Foldable
+import Data.Function ((&))
+import Data.Functor ((<&>))
+import Data.Functor.Contravariant (Contravariant (contramap), (>$<))
+import Data.Functor.Identity (Identity (runIdentity))
+import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty)
+import Data.Map.Strict
+  ( Map,
+  )
+import qualified Data.Map.Strict as Map
+import Data.Maybe (mapMaybe)
+import qualified Data.Maybe as Maybe
+import Data.Profunctor (Profunctor, dimap, lmap, rmap)
+import Data.Semigroup (Max (Max, getMax), Min (Min, getMin), sconcat)
+import Data.Semigroup.Foldable (Foldable1 (fold1), foldMap1)
+import Data.Semigroup.Traversable (Traversable1)
+import Data.Semigroupoid (Semigroupoid)
+import Data.Text
+  ( Text,
+  )
+import qualified Data.Text
+import qualified Data.Text.Encoding
+import qualified Data.Text.Encoding.Error
+import qualified Data.Text.Lazy
+import qualified Data.Text.Lazy.Encoding
+import Data.These (These (That, These, This))
+import Data.Traversable (for)
+import Data.Void (Void, absurd)
+import Data.Word (Word8)
+import GHC.Exception (errorCallWithCallStackException)
+import GHC.Exts (RuntimeRep, TYPE, raise#)
+import GHC.Generics (Generic)
+import GHC.Natural (Natural)
+import GHC.Stack (HasCallStack)
+import PyF (fmt)
+import qualified System.Exit
+import qualified System.IO
+import Validation
+  ( Validation (Failure, Success),
+    eitherToValidation,
+    failure,
+    failures,
+    successes,
+    validationToEither,
+  )
+
+-- | Forward-applying 'contramap', like '&'/'$' and '<&>'/'<$>' but for '>$<'.
+(>&<) :: Contravariant f => f b -> (a -> b) -> f a
+(>&<) = flip contramap
+
+infixl 5 >&<
+
+-- | encode a Text to a UTF-8 encoded Bytestring
+textToBytesUtf8 :: Text -> ByteString
+textToBytesUtf8 = Data.Text.Encoding.encodeUtf8
+
+-- | encode a lazy Text to a UTF-8 encoded lazy Bytestring
+textToBytesUtf8Lazy :: Data.Text.Lazy.Text -> Data.ByteString.Lazy.ByteString
+textToBytesUtf8Lazy = Data.Text.Lazy.Encoding.encodeUtf8
+
+bytesToTextUtf8 :: ByteString -> Either Error Text
+bytesToTextUtf8 = first exceptionToError . Data.Text.Encoding.decodeUtf8'
+
+bytesToTextUtf8Lazy :: Data.ByteString.Lazy.ByteString -> Either Error Data.Text.Lazy.Text
+bytesToTextUtf8Lazy = first exceptionToError . Data.Text.Lazy.Encoding.decodeUtf8'
+
+-- | decode a Text from a ByteString that is assumed to be UTF-8 (crash if that is not the case)
+bytesToTextUtf8Unsafe :: ByteString -> Text
+bytesToTextUtf8Unsafe = Data.Text.Encoding.decodeUtf8
+
+-- | decode a Text from a ByteString that is assumed to be UTF-8 (crash if that is not the case)
+bytesToTextUtf8UnsafeLazy :: Data.ByteString.Lazy.ByteString -> Data.Text.Lazy.Text
+bytesToTextUtf8UnsafeLazy = Data.Text.Lazy.Encoding.decodeUtf8
+
+-- | decode a Text from a ByteString that is assumed to be UTF-8,
+-- replace non-UTF-8 characters with the replacment char U+FFFD.
+bytesToTextUtf8Lenient :: Data.ByteString.ByteString -> Data.Text.Text
+bytesToTextUtf8Lenient =
+  Data.Text.Encoding.decodeUtf8With Data.Text.Encoding.Error.lenientDecode
+
+-- | decode a lazy Text from a lazy ByteString that is assumed to be UTF-8,
+-- replace non-UTF-8 characters with the replacment char U+FFFD.
+bytesToTextUtf8LenientLazy :: Data.ByteString.Lazy.ByteString -> Data.Text.Lazy.Text
+bytesToTextUtf8LenientLazy =
+  Data.Text.Lazy.Encoding.decodeUtf8With Data.Text.Encoding.Error.lenientDecode
+
+-- | Make a lazy text strict
+toStrict :: Data.Text.Lazy.Text -> Text
+toStrict = Data.Text.Lazy.toStrict
+
+-- | Make a strict text lazy
+toLazy :: Text -> Data.Text.Lazy.Text
+toLazy = Data.Text.Lazy.fromStrict
+
+toStrictBytes :: Data.ByteString.Lazy.ByteString -> ByteString
+toStrictBytes = Data.ByteString.Lazy.toStrict
+
+toLazyBytes :: ByteString -> Data.ByteString.Lazy.ByteString
+toLazyBytes = Data.ByteString.Lazy.fromStrict
+
+textToString :: Text -> String
+textToString = Data.Text.unpack
+
+stringToText :: String -> Text
+stringToText = Data.Text.pack
+
+showToText :: (Show a) => a -> Text
+showToText = stringToText . show
+
+-- | Unsafe conversion between 'Char' and 'Word8'. This is a no-op and
+-- silently truncates to 8 bits Chars > '\255'. It is provided as
+-- convenience for ByteString construction.
+--
+-- Use if you want to get the 'Word8' representation of a character literal.
+-- Don’t use on arbitrary characters!
+--
+-- >>> charToWordUnsafe ','
+-- 44
+charToWordUnsafe :: Char -> Word8
+charToWordUnsafe = fromIntegral . Data.Char.ord
+{-# INLINE charToWordUnsafe #-}
+
+-- | Single element in a (non-empty) list.
+singleton :: a -> NonEmpty a
+singleton a = a :| []
+
+-- | If the given list is empty, use the given default element and return a non-empty list.
+nonEmptyDef :: a -> [a] -> NonEmpty a
+nonEmptyDef def xs =
+  xs & nonEmpty & \case
+    Nothing -> def :| []
+    Just ne -> ne
+
+-- | Construct a non-empty list, given a default value if the ist list was empty.
+toNonEmptyDefault :: a -> [a] -> NonEmpty a
+toNonEmptyDefault def xs = case xs of
+  [] -> def :| []
+  (x : xs') -> x :| xs'
+
+-- | @O(n)@. Get the maximum element from a non-empty structure.
+maximum1 :: (Foldable1 f, Ord a) => f a -> a
+maximum1 xs = xs & foldMap1 Max & getMax
+
+-- | @O(n)@. Get the minimum element from a non-empty structure.
+minimum1 :: (Foldable1 f, Ord a) => f a -> a
+minimum1 xs = xs & foldMap1 Min & getMin
+
+-- | Annotate a 'Maybe' with an error message and turn it into an 'Either'.
+annotate :: err -> Maybe a -> Either err a
+annotate err = \case
+  Nothing -> Left err
+  Just a -> Right a
+
+-- | Find the first element for which pred returns `Just a`, and return the `a`.
+--
+-- Example:
+-- @
+-- >>> :set -XTypeApplications
+-- >>> import qualified Text.Read
+--
+-- >>> findMaybe (Text.Read.readMaybe @Int) ["foo"]
+-- Nothing
+-- >>> findMaybe (Text.Read.readMaybe @Int) ["foo", "34.40", "34", "abc"]
+-- Just 34
+findMaybe :: Foldable t => (a -> Maybe b) -> t a -> Maybe b
+findMaybe mPred list =
+  let pred' x = Maybe.isJust $ mPred x
+   in case Foldable.find pred' list of
+        Just a -> mPred a
+        Nothing -> Nothing
+
+-- | Like 'eitherToValidation', but puts the Error side into a NonEmpty list
+-- to make it combine with other validations.
+eitherToListValidation :: Either a c -> Validation (NonEmpty a) c
+eitherToListValidation = first singleton . eitherToValidation
+
+-- | Convert an 'Either' to a 'These'.
+eitherToThese :: Either err a -> These err a
+eitherToThese (Left err) = This err
+eitherToThese (Right a) = That a
+
+-- | Like 'eitherToThese', but puts the Error side into a NonEmpty list
+-- to make it combine with other theses.
+eitherToListThese :: Either err a -> These (NonEmpty err) a
+eitherToListThese (Left e) = This (singleton e)
+eitherToListThese (Right a) = That a
+
+-- | Convert a 'Validation' to a 'These'.
+validationToThese :: Validation err a -> These err a
+validationToThese (Failure err) = This err
+validationToThese (Success a) = That a
+
+-- | Nested '>>=' of a These inside some other @m@.
+--
+-- Use if you want to collect errors and successes, and want to chain multiple function returning 'These'.
+thenThese ::
+  (Monad m, Semigroup err) =>
+  (a -> m (These err b)) ->
+  m (These err a) ->
+  m (These err b)
+thenThese f x = do
+  th <- x
+  join <$> traverse f th
+
+-- | Nested validating bind-like combinator inside some other @m@.
+--
+-- Use if you want to collect errors, and want to chain multiple functions returning 'Validation'.
+thenValidate ::
+  (Monad m) =>
+  (a -> m (Validation err b)) ->
+  m (Validation err a) ->
+  m (Validation err b)
+thenValidate f x =
+  eitherToValidation <$> do
+    x' <- validationToEither <$> x
+    case x' of
+      Left err -> pure $ Left err
+      Right a -> validationToEither <$> f a
+
+-- | Put the text to @stderr@.
+putStderrLn :: Text -> IO ()
+putStderrLn msg =
+  System.IO.hPutStrLn System.IO.stderr $ textToString msg
+
+exitWithMessage :: Text -> IO a
+exitWithMessage msg = do
+  putStderrLn msg
+  System.Exit.exitWith $ System.Exit.ExitFailure (-1)
+
+-- | Run some function producing applicative over a traversable data structure,
+-- then collect the results in a Monoid.
+--
+-- Very helpful with side-effecting functions returning @(Validation err a)@:
+--
+-- @
+-- let
+--   f :: Text -> IO (Validation (NonEmpty Error) Text)
+--   f t = pure $ if t == "foo" then Success t else Failure (singleton ("not foo: " <> t))
+--
+-- in traverseFold f [ "foo", "bar", "baz" ]
+--   == Failure ("not foo bar" :| ["not foo baz"])
+-- @
+--
+-- … since @(Semigroup err => Validation err a)@ is a @Semigroup@/@Monoid@ itself.
+traverseFold :: (Applicative ap, Traversable t, Monoid m) => (a -> ap m) -> t a -> ap m
+traverseFold f xs =
+  -- note: could be weakened to (Foldable t) via `getAp . foldMap (Ap . f)`
+  fold <$> traverse f xs
+{-# INLINE traverseFold #-}
+
+-- | Like 'traverseFold', but fold over a semigroup instead of a Monoid, by providing a starting element.
+traverseFoldDefault :: (Applicative ap, Traversable t, Semigroup m) => m -> (a -> ap m) -> t a -> ap m
+traverseFoldDefault def f xs = foldDef def <$> traverse f xs
+  where
+    foldDef = foldr (<>)
+{-# INLINE traverseFoldDefault #-}
+
+-- | Same as 'traverseFold', but with a 'Semigroup' and 'Traversable1' restriction.
+traverseFold1 :: (Applicative ap, Traversable1 t, Semigroup s) => (a -> ap s) -> t a -> ap s
+-- note: cannot be weakened to (Foldable1 t) because there is no `Ap` for Semigroup (No `Apply` typeclass)
+traverseFold1 f xs = fold1 <$> traverse f xs
+{-# INLINE traverseFold1 #-}
+
+-- | Use this in places where the code is still to be implemented.
+--
+-- It always type-checks and will show a warning at compile time if it was forgotten in the code.
+--
+-- Use instead of 'error' and 'undefined' for code that hasn’t been written.
+--
+-- Uses the same trick as https://hackage.haskell.org/package/protolude-0.3.0/docs/src/Protolude.Error.html#error
+{-# WARNING todo "'todo' (undefined code) remains in code" #-}
+todo :: forall (r :: RuntimeRep). forall (a :: TYPE r). HasCallStack => a
+todo = raise# (errorCallWithCallStackException "This code was not yet implemented: TODO" ?callStack)
+
+-- TODO: use a Text.Builder?
+
+-- | Pretty print a bunch of errors, on multiple lines, prefixed by the given message,
+-- then turn the result back into an 'Error'.
+--
+-- Example:
+--
+-- smushErrors "There was a problem with the frobl"
+--   [ (anyhow "frobz")
+--   , (errorContext "oh no" (anyhow "barz"))
+--   ]
+--
+-- ==>
+-- "There was a problem with the frobl\n\
+-- - frobz\n\
+-- - oh no: barz\n"
+-- @
+--
+-- TODO how do we make this compatible with/integrate it into the Error library?
+smushErrors :: Foldable t => Text -> t Error -> Error
+smushErrors msg errs =
+  errs
+    -- hrm, pretty printing and then creating a new error is kinda shady
+    & foldMap (\err -> "\n- " <> prettyError err)
+    & newError
+    & errorContext msg
+
+-- | Convert an integer to a 'Natural' if possible
+--
+-- Named the same as the function from "GHC.Natural", but does not crash.
+intToNatural :: Integral a => a -> Maybe Natural
+intToNatural i =
+  if i < 0
+    then Nothing
+    else Just $ fromIntegral i
+
+-- | @inverseFunction f@ creates a function that is the inverse of a given function
+-- @f@. It does so by constructing 'M.Map' internally for each value @f a@. The
+-- implementation makes sure that the 'M.Map' is constructed only once and then
+-- shared for every call.
+--
+-- __Memory usage note:__ don't inverse functions that have types like 'Int'
+-- as their result. In this case the created 'M.Map' will have huge size.
+--
+-- The complexity of reversed mapping is \(\mathcal{O}(\log n)\).
+--
+-- __Performance note:__ make sure to specialize monomorphic type of your functions
+-- that use 'inverseFunction' to avoid 'M.Map' reconstruction.
+--
+-- One of the common 'inverseFunction' use-case is inverting the 'show' or a 'show'-like
+-- function.
+--
+-- >>> data Color = Red | Green | Blue deriving (Show, Enum, Bounded)
+-- >>> parse = inverseFunction show :: String -> Maybe Color
+-- >>> parse "Red"
+-- Just Red
+-- >>> parse "Black"
+-- Nothing
+--
+-- __Correctness note:__ 'inverseFunction' expects /injective function/ as its argument,
+-- i.e. the function must map distinct arguments to distinct values.
+--
+-- Typical usage of this function looks like this:
+--
+-- @
+-- __data__ GhcVer
+--    = Ghc802
+--    | Ghc822
+--    | Ghc844
+--    | Ghc865
+--    | Ghc881
+--    __deriving__ ('Eq', 'Ord', 'Show', 'Enum', 'Bounded')
+--
+-- showGhcVer :: GhcVer -> 'Text'
+-- showGhcVer = \\__case__
+--    Ghc802 -> "8.0.2"
+--    Ghc822 -> "8.2.2"
+--    Ghc844 -> "8.4.4"
+--    Ghc865 -> "8.6.5"
+--    Ghc881 -> "8.8.1"
+--
+-- parseGhcVer :: 'Text' -> 'Maybe' GhcVer
+-- parseGhcVer = 'inverseFunction' showGhcVer
+--
+-- Taken from relude’s @Relude.Extra.Enum@.
+inverseFunction ::
+  forall a k.
+  (Bounded a, Enum a, Ord k) =>
+  (a -> k) ->
+  (k -> Maybe a)
+inverseFunction f k = Map.lookup k $ inverseMap f
+
+-- | Like `inverseFunction`, but instead of returning the function
+-- it returns a mapping from all possible outputs to their possible inputs.
+--
+-- This has the same restrictions of 'inverseFunction'.
+inverseMap ::
+  forall a k.
+  (Bounded a, Enum a, Ord k) =>
+  (a -> k) ->
+  Map k a
+inverseMap f =
+  universe
+    <&> (\a -> (f a, a))
+    & Map.fromList
+  where
+    universe :: (Bounded a, Enum a) => [a]
+    universe = [minBound .. maxBound]
diff --git a/users/Profpatsch/my-prelude/default.nix b/users/Profpatsch/my-prelude/default.nix
new file mode 100644
index 000000000000..d4da8d97f033
--- /dev/null
+++ b/users/Profpatsch/my-prelude/default.nix
@@ -0,0 +1,24 @@
+{ depot, pkgs, lib, ... }:
+
+pkgs.haskellPackages.mkDerivation {
+  pname = "my-prelude";
+  version = "0.0.1-unreleased";
+
+  src = ./.;
+
+  isLibrary = true;
+
+  libraryHaskellDepends = [
+    pkgs.haskellPackages.PyF
+    pkgs.haskellPackages.errors
+    pkgs.haskellPackages.profunctors
+    pkgs.haskellPackages.semigroupoids
+    pkgs.haskellPackages.these
+    pkgs.haskellPackages.validation-selective
+    pkgs.haskellPackages.error
+
+  ];
+
+  license = lib.licenses.mit;
+
+}
diff --git a/users/Profpatsch/my-prelude/my-prelude.cabal b/users/Profpatsch/my-prelude/my-prelude.cabal
new file mode 100644
index 000000000000..7de057e9e151
--- /dev/null
+++ b/users/Profpatsch/my-prelude/my-prelude.cabal
@@ -0,0 +1,27 @@
+cabal-version:      2.4
+name:               my-prelude
+version:            0.0.1.0
+author:             Profpatsch
+maintainer:         mail@profpatsch.de
+
+library
+    exposed-modules: MyPrelude
+
+    -- Modules included in this executable, other than Main.
+    -- other-modules:
+
+    -- LANGUAGE extensions used by modules in this package.
+    -- other-extensions:
+    build-depends:
+       base ^>=4.15.1.0
+     , PyF
+     , validation-selective
+     , these
+     , text
+     , semigroupoids
+     , profunctors
+     , containers
+     , error
+     , bytestring
+     , mtl
+    default-language: Haskell2010
generated by cgit-pink 1.4.1 (git 2.44.2) at 2024-11-01T17·19+0000