├── .envrc ├── frontend ├── versions.dat ├── review │ ├── .gitignore │ ├── suppressed │ │ ├── NoPrematureLetComputation.json │ │ ├── NoUnused.CustomTypeConstructorArgs.json │ │ ├── NoUnused.Exports.json │ │ └── NoUnused.CustomTypeConstructors.json │ ├── elm.json │ └── src │ │ └── ReviewConfig.elm ├── .gitignore ├── elm-srcs.nix ├── elm-analyse.json ├── source │ ├── Main.elm │ ├── Mensam │ │ ├── Clipboard.elm │ │ ├── Application.elm │ │ ├── Http │ │ │ ├── Status.elm │ │ │ └── Tracker.elm │ │ ├── NameOrIdentifier.elm │ │ ├── Color.elm │ │ ├── Auth │ │ │ ├── Basic.elm │ │ │ └── Bearer.elm │ │ ├── Flags.elm │ │ ├── Auth.elm │ │ ├── Reservation.elm │ │ ├── Storage.elm │ │ ├── Svg │ │ │ └── Color.elm │ │ ├── Element │ │ │ ├── Color.elm │ │ │ └── Font.elm │ │ ├── Space.elm │ │ ├── Element.elm │ │ ├── Api │ │ │ ├── PictureDownload.elm │ │ │ ├── SpacePictureDownload.elm │ │ │ ├── Logout.elm │ │ │ ├── ConfirmationRequest.elm │ │ │ └── PictureDelete.elm │ │ ├── Error │ │ │ └── Incorporation.elm │ │ ├── Widget │ │ │ └── Month.elm │ │ ├── Screen │ │ │ └── Landing.elm │ │ └── Url.elm │ ├── List │ │ └── Extra.elm │ ├── Element │ │ └── Events │ │ │ └── Pointer.elm │ └── TimeZone │ │ └── Extra.elm ├── registry.dat ├── README.adoc └── elm.json ├── static ├── .gitignore ├── source │ ├── icons │ │ ├── feed.png │ │ ├── GitHub.png │ │ └── GitLab.png │ ├── favicon.xpm │ ├── default-profile-picture.xpm │ └── default-space-picture.xpm ├── README.adoc ├── Makefile └── subflake.nix ├── fallback ├── README.adoc ├── subflake.nix └── source │ └── fallback.html ├── server ├── .gitignore ├── source │ ├── executable │ │ ├── Main.hs │ │ ├── client │ │ │ └── Main.hs │ │ ├── server │ │ │ └── Main.hs │ │ ├── test │ │ │ └── Main.hs │ │ └── openapi │ │ │ └── Main.hs │ ├── test │ │ └── Main.hs │ └── library │ │ ├── Mensam │ │ ├── Client.hs │ │ ├── API │ │ │ ├── Route │ │ │ │ ├── Static.hs │ │ │ │ ├── Haddock.hs │ │ │ │ ├── Frontend.hs │ │ │ │ ├── Api │ │ │ │ │ └── OpenApi.hs │ │ │ │ ├── OpenApi.hs │ │ │ │ └── Api.hs │ │ │ ├── API.hs │ │ │ ├── Route.hs │ │ │ ├── Order.hs │ │ │ ├── Update.hs │ │ │ ├── Aeson │ │ │ │ ├── StaticText │ │ │ │ │ ├── Internal.hs │ │ │ │ │ └── Internal │ │ │ │ │ │ └── Union.hs │ │ │ │ └── StaticText.hs │ │ │ ├── Aeson.hs │ │ │ ├── Pretty.hs │ │ │ └── Data │ │ │ │ ├── User │ │ │ │ ├── Username.hs │ │ │ │ └── Password.hs │ │ │ │ ├── Space │ │ │ │ └── Permission.hs │ │ │ │ └── User.hs │ │ ├── Server.hs │ │ ├── Client │ │ │ ├── UI │ │ │ │ ├── Brick │ │ │ │ │ ├── Draw.hs │ │ │ │ │ ├── Names.hs │ │ │ │ │ ├── Events.hs │ │ │ │ │ ├── State.hs │ │ │ │ │ └── AttrMap.hs │ │ │ │ ├── Login.hs │ │ │ │ └── Menu.hs │ │ │ ├── Application │ │ │ │ ├── HttpClient │ │ │ │ │ └── Class.hs │ │ │ │ ├── Event │ │ │ │ │ └── Class.hs │ │ │ │ ├── Options │ │ │ │ │ └── Class.hs │ │ │ │ ├── Event.hs │ │ │ │ ├── HttpClient.hs │ │ │ │ ├── MensamClient.hs │ │ │ │ └── Options.hs │ │ │ ├── Application.hs │ │ │ └── OrphanInstances.hs │ │ ├── Server │ │ │ ├── Configuration │ │ │ │ ├── Email.hs │ │ │ │ ├── SQLite.hs │ │ │ │ └── BaseUrl.hs │ │ │ ├── Application │ │ │ │ ├── Secret │ │ │ │ │ └── Class.hs │ │ │ │ ├── Configured │ │ │ │ │ ├── Class.hs │ │ │ │ │ └── Acquisition.hs │ │ │ │ ├── Environment │ │ │ │ │ └── Class.hs │ │ │ │ ├── Email │ │ │ │ │ └── Class.hs │ │ │ │ ├── SeldaPool │ │ │ │ │ ├── Servant.hs │ │ │ │ │ └── Class.hs │ │ │ │ ├── Environment.hs │ │ │ │ ├── Configured.hs │ │ │ │ ├── Secret.hs │ │ │ │ └── LoggerCustom │ │ │ │ │ └── Class.hs │ │ │ ├── Server │ │ │ │ ├── Handler │ │ │ │ │ ├── Profiler │ │ │ │ │ │ └── Class.hs │ │ │ │ │ ├── Profiler.hs │ │ │ │ │ └── RequestHash.hs │ │ │ │ ├── Route │ │ │ │ │ ├── Static.hs │ │ │ │ │ ├── Haddock.hs │ │ │ │ │ ├── Api.hs │ │ │ │ │ └── Api │ │ │ │ │ │ └── OpenApi.hs │ │ │ │ ├── FileServer.hs │ │ │ │ ├── Route.hs │ │ │ │ ├── Handler.hs │ │ │ │ └── Err404.hs │ │ │ ├── Options.hs │ │ │ ├── Configuration.hs │ │ │ ├── Jpeg.hs │ │ │ ├── Environment.hs │ │ │ ├── Secrets.hs │ │ │ └── Application.hs │ │ └── Main.hs │ │ ├── Control │ │ └── Monad │ │ │ └── Logger │ │ │ └── OrphanInstances.hs │ │ ├── System │ │ └── Posix │ │ │ └── Signals │ │ │ └── Patterns.hs │ │ ├── Text │ │ └── Email │ │ │ ├── Text.hs │ │ │ └── OrphanInstances.hs │ │ ├── Servant │ │ ├── Auth │ │ │ ├── JWT │ │ │ │ └── WithSession.hs │ │ │ └── OrphanInstances.hs │ │ └── API │ │ │ └── ImageJpeg.hs │ │ ├── Data │ │ └── Time │ │ │ └── Zones │ │ │ └── All │ │ │ └── OrphanInstances.hs │ │ └── Deriving │ │ └── Aeson │ │ └── OrphanInstances.hs ├── .hlint.yaml ├── fourmolu.yaml ├── hie.yaml ├── weeder.toml └── README.adoc ├── setup ├── README.adoc └── subflake.nix ├── .gitignore ├── final ├── nixos │ └── test │ │ ├── nixos-mensam-minimal.nix │ │ └── nixos-mensam-docker-minimal.nix └── README.adoc ├── .devcontainer ├── devcontainer.json └── Dockerfile └── .github └── workflows ├── release.yml └── default.yml /.envrc: -------------------------------------------------------------------------------- 1 | use_flake 2 | -------------------------------------------------------------------------------- /frontend/versions.dat: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /static/.gitignore: -------------------------------------------------------------------------------- 1 | build 2 | -------------------------------------------------------------------------------- /frontend/review/.gitignore: -------------------------------------------------------------------------------- 1 | /elm-stuff 2 | -------------------------------------------------------------------------------- /frontend/.gitignore: -------------------------------------------------------------------------------- 1 | /elm-stuff 2 | /index.html 3 | /elm.js 4 | -------------------------------------------------------------------------------- /fallback/README.adoc: -------------------------------------------------------------------------------- 1 | = Fallback 2 | 3 | A static fallback page. 4 | -------------------------------------------------------------------------------- /server/.gitignore: -------------------------------------------------------------------------------- 1 | dist-newstyle 2 | mensam.sqlite 3 | mensam-jwk.secret 4 | -------------------------------------------------------------------------------- /frontend/elm-srcs.nix: -------------------------------------------------------------------------------- 1 | import ./elm-srcs-mensam.nix // import ./review/elm-srcs.nix 2 | -------------------------------------------------------------------------------- /server/source/executable/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Mensam.Main (main) 4 | -------------------------------------------------------------------------------- /server/source/test/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | main :: IO () 4 | main = pure () 5 | -------------------------------------------------------------------------------- /server/source/executable/client/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Mensam.Client (main) 4 | -------------------------------------------------------------------------------- /server/source/executable/server/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Mensam.Server (main) 4 | -------------------------------------------------------------------------------- /static/source/icons/feed.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jumper149/mensam/HEAD/static/source/icons/feed.png -------------------------------------------------------------------------------- /setup/README.adoc: -------------------------------------------------------------------------------- 1 | = Setup 2 | 3 | There is not a lot going on here, just an overlay that is used everywhere. 4 | -------------------------------------------------------------------------------- /setup/subflake.nix: -------------------------------------------------------------------------------- 1 | { self, nixpkgs }: rec { 2 | 3 | overlays.default = final: prev: { 4 | }; 5 | 6 | } 7 | -------------------------------------------------------------------------------- /static/source/icons/GitHub.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jumper149/mensam/HEAD/static/source/icons/GitHub.png -------------------------------------------------------------------------------- /static/source/icons/GitLab.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jumper149/mensam/HEAD/static/source/icons/GitLab.png -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .direnv/ 2 | result* 3 | README.pdf 4 | README.html 5 | CHANGELOG.pdf 6 | CHANGELOG.html 7 | *.sqlite 8 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Client.hs: -------------------------------------------------------------------------------- 1 | module Mensam.Client where 2 | 3 | import Mensam.Client.UI 4 | 5 | main :: IO () 6 | main = ui 7 | -------------------------------------------------------------------------------- /final/nixos/test/nixos-mensam-minimal.nix: -------------------------------------------------------------------------------- 1 | moduleMensam: { ... }: { 2 | imports = [ moduleMensam ]; 3 | services.mensam = { 4 | enable = true; 5 | }; 6 | } 7 | -------------------------------------------------------------------------------- /server/source/executable/test/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Mensam.Server.Application 4 | 5 | main :: IO () 6 | main = runApplicationT $ pure () 7 | -------------------------------------------------------------------------------- /server/source/executable/openapi/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Mensam.Server.OpenApi (openapiJsonStdout) 4 | 5 | main :: IO () 6 | main = openapiJsonStdout 7 | -------------------------------------------------------------------------------- /final/README.adoc: -------------------------------------------------------------------------------- 1 | = Final 2 | 3 | Here is a template link:./configuration.json[`configuration.json`] to configure the `mensam` executable. 4 | 5 | == NixOS 6 | 7 | We also provide a NixOS module. 8 | -------------------------------------------------------------------------------- /server/source/library/Mensam/API/Route/Static.hs: -------------------------------------------------------------------------------- 1 | module Mensam.API.Route.Static where 2 | 3 | import Data.Kind 4 | import Servant.RawM qualified as RawM 5 | 6 | type API :: Type 7 | type API = RawM.RawM 8 | -------------------------------------------------------------------------------- /server/source/library/Mensam/API/Route/Haddock.hs: -------------------------------------------------------------------------------- 1 | module Mensam.API.Route.Haddock where 2 | 3 | import Data.Kind 4 | import Servant.RawM qualified as RawM 5 | 6 | type API :: Type 7 | type API = RawM.RawM 8 | -------------------------------------------------------------------------------- /server/source/library/Mensam/API/API.hs: -------------------------------------------------------------------------------- 1 | module Mensam.API.API where 2 | 3 | import Mensam.API.Route 4 | 5 | import Data.Kind 6 | import Servant.API 7 | 8 | type API :: Type 9 | type API = ToServantApi Routes 10 | -------------------------------------------------------------------------------- /frontend/elm-analyse.json: -------------------------------------------------------------------------------- 1 | { "checks" : 2 | { "TriggerWords": false 3 | , "ExposeAll": false 4 | , "MapNothingToNothing": false 5 | , "MultiLineRecordFormatting": false 6 | , "SingleFieldRecord": false 7 | } 8 | } -------------------------------------------------------------------------------- /frontend/source/Main.elm: -------------------------------------------------------------------------------- 1 | module Main exposing (main) 2 | 3 | import Json.Encode as Encode 4 | import Mensam.Main as Mensam 5 | 6 | 7 | main : Program Encode.Value Mensam.Model Mensam.Message 8 | main = 9 | Mensam.main 10 | -------------------------------------------------------------------------------- /static/README.adoc: -------------------------------------------------------------------------------- 1 | = Static 2 | 3 | Static files are bundled and will be served at runtime from the server. 4 | This includes different kinds of files. 5 | 6 | Icons:: Favicon, others 7 | Fonts:: WOFF2, CSS 8 | Redoc:: JavaScript, CSS 9 | Frontend:: JavaScript 10 | -------------------------------------------------------------------------------- /frontend/review/suppressed/NoPrematureLetComputation.json: -------------------------------------------------------------------------------- 1 | { 2 | "version": 1, 3 | "automatically created by": "elm-review suppress", 4 | "learn more": "elm-review suppress --help", 5 | "suppressions": [ 6 | { "count": 1, "filePath": "source/Element/Window.elm" } 7 | ] 8 | } 9 | -------------------------------------------------------------------------------- /frontend/source/Mensam/Clipboard.elm: -------------------------------------------------------------------------------- 1 | port module Mensam.Clipboard exposing (copyText) 2 | 3 | import Json.Encode as Encode 4 | 5 | 6 | port copyTextToClipboard : Encode.Value -> Cmd msg 7 | 8 | 9 | copyText : String -> Cmd msg 10 | copyText = 11 | Encode.string >> copyTextToClipboard 12 | -------------------------------------------------------------------------------- /server/source/library/Mensam/API/Route/Frontend.hs: -------------------------------------------------------------------------------- 1 | module Mensam.API.Route.Frontend where 2 | 3 | import Data.Kind 4 | import Data.Text qualified as T 5 | import Servant.API 6 | import Servant.HTML.Blaze 7 | import Text.Blaze.Html5 8 | 9 | type API :: Type 10 | type API = CaptureAll "segments" T.Text :> Get '[HTML] Html 11 | -------------------------------------------------------------------------------- /frontend/source/List/Extra.elm: -------------------------------------------------------------------------------- 1 | module List.Extra exposing (..) 2 | 3 | 4 | find : (a -> Bool) -> List a -> Maybe a 5 | find predicate list = 6 | case list of 7 | [] -> 8 | Nothing 9 | 10 | head :: tail -> 11 | if predicate head then 12 | Just head 13 | 14 | else 15 | find predicate tail 16 | -------------------------------------------------------------------------------- /final/nixos/test/nixos-mensam-docker-minimal.nix: -------------------------------------------------------------------------------- 1 | moduleMensam: { lib, pkgs, ... }: { 2 | imports = [ moduleMensam ]; 3 | virtualisation.diskSize = 8192; 4 | virtualisation.memorySize = 2048; 5 | virtualisation.oci-containers.containers.mensam.image = lib.mkForce "docker-archive://${pkgs.mensam.dockerImage}"; 6 | services.mensam = { 7 | enable = true; 8 | provider = "docker"; 9 | }; 10 | } 11 | -------------------------------------------------------------------------------- /server/.hlint.yaml: -------------------------------------------------------------------------------- 1 | - modules: 2 | - name: Control.Monad.Logger 3 | message: Use Control.Monad.Logger.CallStack instead 4 | - name: 5 | - Control.Password.Argon2 6 | - Control.Password.Crypton 7 | - Control.Password.Cryptonite 8 | - Control.Password.PBKDF2 9 | - Control.Password.Scrypt 10 | - Control.Password.Validate 11 | message: Use Control.Password.Bcrypt instead 12 | -------------------------------------------------------------------------------- /server/fourmolu.yaml: -------------------------------------------------------------------------------- 1 | indentation: 2 2 | column-limit: none 3 | function-arrows: trailing 4 | comma-style: leading 5 | import-export-style: diff-friendly 6 | indent-wheres: false 7 | record-brace-space: true 8 | newlines-between-decls: 1 9 | haddock-style: single-line 10 | haddock-style-module: null 11 | let-style: mixed 12 | in-style: right-align 13 | single-constraint-parens: never 14 | respectful: true 15 | fixities: [] 16 | unicode: never 17 | reexports: [] 18 | -------------------------------------------------------------------------------- /frontend/review/suppressed/NoUnused.CustomTypeConstructorArgs.json: -------------------------------------------------------------------------------- 1 | { 2 | "version": 1, 3 | "automatically created by": "elm-review suppress", 4 | "learn more": "elm-review suppress --help", 5 | "suppressions": [ 6 | { "count": 1, "filePath": "source/Mensam/Api/DeskCreate.elm" }, 7 | { "count": 1, "filePath": "source/Mensam/Api/ReservationCreate.elm" }, 8 | { "count": 1, "filePath": "source/Mensam/Api/RoleCreate.elm" }, 9 | { "count": 1, "filePath": "source/Mensam/Api/SpaceCreate.elm" } 10 | ] 11 | } 12 | -------------------------------------------------------------------------------- /server/source/library/Mensam/API/Route/Api/OpenApi.hs: -------------------------------------------------------------------------------- 1 | module Mensam.API.Route.Api.OpenApi where 2 | 3 | import Data.Kind 4 | import Data.OpenApi 5 | import GHC.Generics 6 | import Servant.API 7 | 8 | type Routes :: Type -> Type 9 | type role Routes _ 10 | newtype Routes route = Routes 11 | { routeJson :: 12 | route 13 | :- Summary "OpenAPI" 14 | :> Description 15 | "This OpenAPI specification is automatically generated from a servant API.\n" 16 | :> "openapi" 17 | :> Get '[JSON] OpenApi 18 | } 19 | deriving stock (Generic) 20 | -------------------------------------------------------------------------------- /server/source/library/Mensam/API/Route/OpenApi.hs: -------------------------------------------------------------------------------- 1 | module Mensam.API.Route.OpenApi where 2 | 3 | import Data.Kind 4 | import GHC.Generics 5 | import Servant.API 6 | import Servant.HTML.Blaze 7 | import Text.Blaze.Html 8 | 9 | type Routes :: Type -> Type 10 | type role Routes _ 11 | newtype Routes route = Routes 12 | { routeRender :: 13 | route 14 | :- Summary "View API documentation" 15 | :> Description 16 | "View the OpenAPI documentation in a human-readabable format.\n" 17 | :> Get '[HTML] Html 18 | } 19 | deriving stock (Generic) 20 | -------------------------------------------------------------------------------- /frontend/review/suppressed/NoUnused.Exports.json: -------------------------------------------------------------------------------- 1 | { 2 | "version": 1, 3 | "automatically created by": "elm-review suppress", 4 | "learn more": "elm-review suppress --help", 5 | "suppressions": [ 6 | { "count": 2, "filePath": "source/Mensam/Error.elm" }, 7 | { "count": 2, "filePath": "source/Mensam/User.elm" }, 8 | { "count": 1, "filePath": "source/Mensam/Reservation.elm" }, 9 | { "count": 1, "filePath": "source/Mensam/Space/Role.elm" }, 10 | { "count": 1, "filePath": "source/Mensam/Svg/Color.elm" }, 11 | { "count": 1, "filePath": "source/Mensam/Time.elm" } 12 | ] 13 | } 14 | -------------------------------------------------------------------------------- /server/source/library/Control/Monad/Logger/OrphanInstances.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | 4 | module Control.Monad.Logger.OrphanInstances () where 5 | 6 | import Control.Monad.Logger.CallStack 7 | import Control.Monad.Trans.Control.Identity 8 | import Control.Monad.Trans.Identity 9 | import Control.Monad.Trans.Reader 10 | 11 | deriving via 12 | ReaderT (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) 13 | instance 14 | MonadTransControlIdentity LoggingT 15 | 16 | deriving via 17 | IdentityT 18 | instance 19 | MonadTransControlIdentity NoLoggingT 20 | -------------------------------------------------------------------------------- /fallback/subflake.nix: -------------------------------------------------------------------------------- 1 | { self, nixpkgs }: rec { 2 | 3 | packages.x86_64-linux.default = 4 | with import nixpkgs { system = "x86_64-linux"; overlays = [ self.subflakes.setup.overlays.default ]; }; 5 | stdenv.mkDerivation { 6 | name = "fallback"; # TODO: Necessary to avoid segmentation fault. 7 | src = ./.; 8 | buildPhase = '' 9 | cp --recursive source build 10 | ''; 11 | installPhase = '' 12 | cp --recursive build $out 13 | ''; 14 | buildInputs = [ 15 | ]; 16 | }; 17 | 18 | checks.x86_64-linux.package = packages.x86_64-linux.default; 19 | 20 | } 21 | -------------------------------------------------------------------------------- /frontend/review/suppressed/NoUnused.CustomTypeConstructors.json: -------------------------------------------------------------------------------- 1 | { 2 | "version": 1, 3 | "automatically created by": "elm-review suppress", 4 | "learn more": "elm-review suppress --help", 5 | "suppressions": [ 6 | { "count": 8, "filePath": "source/Mensam/Element/Font.elm" }, 7 | { "count": 1, "filePath": "source/Mensam/Api/Login.elm" }, 8 | { "count": 1, "filePath": "source/Mensam/Element/Color.elm" }, 9 | { "count": 1, "filePath": "source/Mensam/NameOrIdentifier.elm" }, 10 | { "count": 1, "filePath": "source/Mensam/Screen/PrivacyPolicy.elm" }, 11 | { "count": 1, "filePath": "source/Mensam/Screen/TermsAndConditions.elm" } 12 | ] 13 | } 14 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Server.hs: -------------------------------------------------------------------------------- 1 | module Mensam.Server where 2 | 3 | import Mensam.Server.Application 4 | import Mensam.Server.Application.Configured.Class 5 | import Mensam.Server.Configuration 6 | import Mensam.Server.Configuration.SQLite 7 | import Mensam.Server.Database.Check 8 | import Mensam.Server.Options 9 | import Mensam.Server.Server 10 | 11 | import Control.Monad 12 | 13 | main :: IO () 14 | main = mainWithOptions defaultOptions 15 | 16 | mainWithOptions :: Options -> IO () 17 | mainWithOptions _options = runApplicationT $ do 18 | config <- configuration 19 | when (sqliteCheckDataIntegrityOnStartup (configSqlite config)) checkDatabase 20 | server 21 | -------------------------------------------------------------------------------- /server/source/library/System/Posix/Signals/Patterns.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms #-} 2 | 3 | module System.Posix.Signals.Patterns where 4 | 5 | import System.Posix.Signals 6 | 7 | -- Source: https://pubs.opengroup.org/onlinepubs/9699919799/utilities/kill.html 8 | -- Other signals are not defined by POSIX. 9 | 10 | pattern SIGHUP :: Signal 11 | pattern SIGHUP = 1 12 | 13 | pattern SIGINT :: Signal 14 | pattern SIGINT = 2 15 | 16 | pattern SIGQUIT :: Signal 17 | pattern SIGQUIT = 3 18 | 19 | pattern SIGABRT :: Signal 20 | pattern SIGABRT = 6 21 | 22 | pattern SIGALRM :: Signal 23 | pattern SIGALRM = 14 24 | 25 | pattern SIGTERM :: Signal 26 | pattern SIGTERM = 15 27 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Client/UI/Brick/Draw.hs: -------------------------------------------------------------------------------- 1 | module Mensam.Client.UI.Brick.Draw where 2 | 3 | import Brick 4 | import Data.Text qualified as T 5 | 6 | drawHelp :: Widget a 7 | drawHelp = 8 | vBox 9 | [ txt title 10 | , padTop Max $ padLeft Max $ txt footerMenu 11 | ] 12 | 13 | title :: T.Text 14 | title = 15 | " __ __ \n\ 16 | \ | \\/ | ___ _ _ ___ __ _ _ __ \n\ 17 | \ | |\\/| |/ -_)| ' \\ (_-// _` || ' \\ \n\ 18 | \ |_| |_|\\___||_||_|/__/\\__/_||_|_|_|\n" 19 | 20 | footerMenuHelp :: T.Text 21 | footerMenuHelp = " Menu (Escape) | Help (?) " 22 | 23 | footerMenu :: T.Text 24 | footerMenu = " Menu (Escape) " 25 | -------------------------------------------------------------------------------- /server/hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | cabal: 3 | - path: "source/library" 4 | component: "lib:mensam" 5 | 6 | - path: "source/executable/Main.hs" 7 | component: "mensam:exe:mensam" 8 | 9 | - path: "source/executable/test/Main.hs" 10 | component: "mensam:exe:mensam-test" 11 | 12 | - path: "source/executable/openapi/Main.hs" 13 | component: "mensam:exe:mensam-openapi" 14 | 15 | - path: "source/executable/server/Main.hs" 16 | component: "mensam:exe:mensam-server" 17 | 18 | - path: "source/executable/client/Main.hs" 19 | component: "mensam:exe:mensam-client" 20 | 21 | - path: "source/test" 22 | component: "mensam:test:mensam-testsuite" 23 | -------------------------------------------------------------------------------- /frontend/source/Mensam/Application.elm: -------------------------------------------------------------------------------- 1 | module Mensam.Application exposing (..) 2 | 3 | import Platform.Cmd 4 | 5 | 6 | updates : List (model -> ( model, Platform.Cmd.Cmd message )) -> model -> ( model, Platform.Cmd.Cmd message ) 7 | updates messages model = 8 | case messages of 9 | [] -> 10 | ( model, Platform.Cmd.none ) 11 | 12 | updateNow :: otherMessages -> 13 | let 14 | ( modelUpdated, cmdUpdated ) = 15 | updateNow model 16 | 17 | ( modelFinal, cmdFinal ) = 18 | updates otherMessages modelUpdated 19 | in 20 | ( modelFinal, Platform.Cmd.batch [ cmdUpdated, cmdFinal ] ) 21 | -------------------------------------------------------------------------------- /server/weeder.toml: -------------------------------------------------------------------------------- 1 | roots = [ 2 | "^Main.main$", 3 | "^Mensam.Main.main$", 4 | "^Mensam.Client.main$", 5 | # TODO: Work in progress: 6 | "^Mensam.Client.Application.Event.runAppEventT$", 7 | "^Mensam.Client.Application.MensamClient.*$", 8 | "^Mensam.Client.Debug.runF$", 9 | "^Mensam.Server.main$", 10 | "^Mensam.Server.Database.Extra.updateUnique$", 11 | "^Mensam.Server.Database.Space.spaceListDesks$", 12 | "^Mensam.Server.OpenApi.openapiJsonStdout$", 13 | "^Mensam.Server.User.userSessionGet$", 14 | "^Mensam.Server.User.userEmailPreferencesGet$", 15 | ] 16 | 17 | type-class-roots = true 18 | 19 | root-instances = [ 20 | { class = "\\.IsString$" }, 21 | { class = "\\.IsList$" }, 22 | ] 23 | 24 | unused-types = true 25 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Server/Configuration/Email.hs: -------------------------------------------------------------------------------- 1 | module Mensam.Server.Configuration.Email where 2 | 3 | import Mensam.API.Aeson 4 | 5 | import Control.DeepSeq 6 | import Data.Aeson qualified as A 7 | import Data.Kind 8 | import Data.Word 9 | import Deriving.Aeson qualified as A 10 | import GHC.Generics 11 | import Network.Mail.SMTP 12 | import Network.Socket 13 | 14 | type EmailConfig :: Type 15 | data EmailConfig = MkEmailConfig 16 | { emailHostname :: HostName 17 | , emailPort :: Word16 18 | , emailUsername :: UserName 19 | , emailPassword :: Password 20 | , emailTls :: Bool 21 | } 22 | deriving stock (Eq, Generic, Ord, Read, Show) 23 | deriving anyclass (NFData) 24 | deriving 25 | (A.FromJSON, A.ToJSON) 26 | via A.CustomJSON (JSONSettings "Mk" "email") EmailConfig 27 | -------------------------------------------------------------------------------- /server/source/library/Mensam/API/Route/Api.hs: -------------------------------------------------------------------------------- 1 | module Mensam.API.Route.Api where 2 | 3 | import Mensam.API.Route.Api.OpenApi qualified 4 | import Mensam.API.Route.Api.Reservation qualified 5 | import Mensam.API.Route.Api.Space qualified 6 | import Mensam.API.Route.Api.User qualified 7 | 8 | import Data.Kind 9 | import Servant 10 | import Servant.API.Generic 11 | 12 | type Routes :: Type -> Type 13 | type role Routes _ 14 | data Routes route = Routes 15 | { routeOpenApi :: route :- NamedRoutes Mensam.API.Route.Api.OpenApi.Routes 16 | , routeUser :: route :- NamedRoutes Mensam.API.Route.Api.User.Routes 17 | , routeSpace :: route :- NamedRoutes Mensam.API.Route.Api.Space.Routes 18 | , routeReservation :: route :- "reservation" :> NamedRoutes Mensam.API.Route.Api.Reservation.Routes 19 | } 20 | deriving stock (Generic) 21 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Server/Application/Secret/Class.hs: -------------------------------------------------------------------------------- 1 | module Mensam.Server.Application.Secret.Class where 2 | 3 | import Mensam.Server.Secrets 4 | 5 | import Control.Monad.Trans 6 | import Control.Monad.Trans.Compose 7 | import Control.Monad.Trans.Elevator 8 | import Data.Kind 9 | 10 | type MonadSecret :: (Type -> Type) -> Constraint 11 | class Monad m => MonadSecret m where 12 | secrets :: m Secrets 13 | 14 | instance 15 | ( Monad (t m) 16 | , MonadTrans t 17 | , MonadSecret m 18 | ) => 19 | MonadSecret (Elevator t m) 20 | where 21 | secrets = lift secrets 22 | 23 | deriving via 24 | Elevator t1 ((t2 :: (Type -> Type) -> Type -> Type) m) 25 | instance 26 | {-# OVERLAPPABLE #-} 27 | ( Monad (t1 (t2 m)) 28 | , MonadTrans t1 29 | , MonadSecret (t2 m) 30 | ) => 31 | MonadSecret (ComposeT t1 t2 m) 32 | -------------------------------------------------------------------------------- /server/source/library/Text/Email/Text.hs: -------------------------------------------------------------------------------- 1 | module Text.Email.Text where 2 | 3 | import Data.Attoparsec.ByteString qualified as Attoparsec.B 4 | import Data.Text qualified as T 5 | import Data.Text.Encoding qualified as T 6 | import Text.Email.Parser 7 | 8 | toText :: EmailAddress -> T.Text 9 | toText emailAddress = 10 | case T.decodeUtf8' $ toByteString emailAddress of 11 | Left err -> error $ "Failed to decode EmailAddress: " <> show err 12 | Right text -> text 13 | 14 | fromText :: T.Text -> Either String EmailAddress 15 | fromText text = Attoparsec.B.parseOnly (addrSpec <* Attoparsec.B.endOfInput) $ T.encodeUtf8 text 16 | 17 | fromTextUnsafe :: T.Text -> EmailAddress 18 | fromTextUnsafe text = 19 | case fromText text of 20 | Left err -> error $ "Failed to parse EmailAddress: " <> show err 21 | Right emailAddress -> emailAddress 22 | -------------------------------------------------------------------------------- /frontend/registry.dat: -------------------------------------------------------------------------------- 1 | avh4 elm-colorbellroy elm-email 2 | chelovek0vbbase64 danfishgold base64-byteselmbrowserelmbyteselmcoreelmfileelmhtmlelmhttpelmjsonelmparserelmregexelmsvgelmtimeelmurlelm virtual-dom elm-community 3 | list-extra 4 | folkertdev elm-flatejustgook elm-image justinmimbsdate justinmimbs 5 | time-extra justinmimbs timezone-data 6 |  7 | mdgriffithelm-ui 8 | mpizenbergelm-pointer-events pablohirafuji 9 | elm-qrcode rtfeldmanelm-iso8601-date-stringstruqu 10 | elm-base64zwilias elm-rosetree -------------------------------------------------------------------------------- /server/source/library/Mensam/Server/Server/Handler/Profiler/Class.hs: -------------------------------------------------------------------------------- 1 | module Mensam.Server.Server.Handler.Profiler.Class where 2 | 3 | import Control.Monad.Trans.Class 4 | import Control.Monad.Trans.Compose 5 | import Control.Monad.Trans.Elevator 6 | import Data.Kind 7 | 8 | type MonadProfiler :: (Type -> Type) -> Constraint 9 | class Monad m => MonadProfiler m where 10 | profilerDuration :: m () 11 | 12 | instance 13 | ( Monad (t m) 14 | , MonadTrans t 15 | , MonadProfiler m 16 | ) => 17 | MonadProfiler (Elevator t m) 18 | where 19 | profilerDuration = lift profilerDuration 20 | 21 | deriving via 22 | Elevator t1 ((t2 :: (Type -> Type) -> Type -> Type) m) 23 | instance 24 | {-# OVERLAPPABLE #-} 25 | ( Monad (t1 (t2 m)) 26 | , MonadTrans t1 27 | , MonadProfiler (t2 m) 28 | ) => 29 | MonadProfiler (ComposeT t1 t2 m) 30 | -------------------------------------------------------------------------------- /.devcontainer/devcontainer.json: -------------------------------------------------------------------------------- 1 | // For format details, see https://aka.ms/vscode-remote/devcontainer.json or the definition README at 2 | // https://github.com/microsoft/vscode-dev-containers/tree/master/containers/docker-existing-dockerfile 3 | { "name": "mensam-devcontainer" 4 | , "dockerFile": "Dockerfile" 5 | , "overrideCommand": false // Use the ENTRYPOINT and CMD from the Dockerfile 6 | , "remoteUser": "root" 7 | , "customizations" : 8 | { "vscode": 9 | { "extensions": 10 | [ "asciidoctor.asciidoctor-vscode" 11 | , "bbenoist.nix" 12 | , "elmTooling.elm-ls-vscode" 13 | , "haskell.haskell" 14 | , "mkhl.direnv" 15 | ] 16 | , "settings": 17 | { "elmLS.elmReviewDiagnostics": "warning" 18 | , "haskell.formattingProvider": "fourmolu" 19 | , "haskell.manageHLS": "PATH" 20 | } 21 | } 22 | } 23 | } 24 | -------------------------------------------------------------------------------- /server/source/library/Mensam/API/Route.hs: -------------------------------------------------------------------------------- 1 | module Mensam.API.Route where 2 | 3 | import Mensam.API.Route.Api qualified 4 | import Mensam.API.Route.Frontend qualified 5 | import Mensam.API.Route.Haddock qualified 6 | import Mensam.API.Route.OpenApi qualified 7 | import Mensam.API.Route.Static qualified 8 | 9 | import Data.Kind 10 | import Servant 11 | import Servant.API.Generic 12 | 13 | type Routes :: Type -> Type 14 | type role Routes _ 15 | data Routes route = Routes 16 | { routeApi :: route :- "api" :> NamedRoutes Mensam.API.Route.Api.Routes 17 | , routeOpenApi :: route :- "openapi" :> NamedRoutes Mensam.API.Route.OpenApi.Routes 18 | , routeStatic :: route :- "static" :> Mensam.API.Route.Static.API 19 | , routeHaddock :: route :- "haddock" :> Mensam.API.Route.Haddock.API 20 | , routeFrontend :: route :- Mensam.API.Route.Frontend.API 21 | } 22 | deriving stock (Generic) 23 | -------------------------------------------------------------------------------- /server/source/library/Text/Email/OrphanInstances.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | 3 | module Text.Email.OrphanInstances () where 4 | 5 | import Control.Lens 6 | import Data.Aeson qualified as A 7 | import Data.OpenApi 8 | import Data.Proxy 9 | import Data.Text qualified as T 10 | import Text.Email.Parser 11 | import Text.Email.Text 12 | 13 | instance A.FromJSON EmailAddress where 14 | parseJSON json = do 15 | text <- A.parseJSON @T.Text json 16 | case fromText text of 17 | Left err -> fail err 18 | Right emailAddress -> pure emailAddress 19 | 20 | instance A.ToJSON EmailAddress where 21 | toJSON = A.String . toText 22 | 23 | instance ToSchema EmailAddress where 24 | declareNamedSchema Proxy = 25 | pure $ 26 | NamedSchema (Just "EmailAddress") $ 27 | mempty 28 | & type_ ?~ OpenApiString 29 | & format ?~ "email" 30 | -------------------------------------------------------------------------------- /frontend/README.adoc: -------------------------------------------------------------------------------- 1 | = Frontend 2 | 3 | The web frontend is written in Elm. 4 | 5 | == Development 6 | 7 | === Formatting 8 | 9 | Use `elm-format` to format Elm. 10 | 11 | [source,bash] 12 | ---- 13 | # Format Elm. 14 | elm-format --yes source 15 | ---- 16 | 17 | === Linting 18 | 19 | Use `elm-review` to lint Elm. 20 | Unfortunately this doesn't work well with Nix, so this has to be called manually. 21 | 22 | [source,bash] 23 | ---- 24 | # Review Elm. 25 | elm-review 26 | ---- 27 | 28 | === Nix 29 | 30 | Elm dependencies are pinned in link:./elm-srcs.nix[elm-srcs.nix]. 31 | The files link:./registry.dat[registry.dat] and link:./versions.dat[versions.dat] are also required to build the frontend with Nix. 32 | 33 | [source,bash] 34 | ---- 35 | # Update `elm-srcs.nix`. 36 | elm2nix convert > elm-srcs-mensam.nix 37 | 38 | # Update `registry.dat` and `versions.dat`. 39 | elm2nix snapshot 40 | ---- 41 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Server/Application/Configured/Class.hs: -------------------------------------------------------------------------------- 1 | module Mensam.Server.Application.Configured.Class where 2 | 3 | import Mensam.Server.Configuration 4 | 5 | import Control.Monad.Trans 6 | import Control.Monad.Trans.Compose 7 | import Control.Monad.Trans.Elevator 8 | import Data.Kind 9 | 10 | type MonadConfigured :: (Type -> Type) -> Constraint 11 | class Monad m => MonadConfigured m where 12 | configuration :: m Configuration 13 | 14 | instance 15 | ( Monad (t m) 16 | , MonadTrans t 17 | , MonadConfigured m 18 | ) => 19 | MonadConfigured (Elevator t m) 20 | where 21 | configuration = lift configuration 22 | 23 | deriving via 24 | Elevator t1 ((t2 :: (Type -> Type) -> Type -> Type) m) 25 | instance 26 | {-# OVERLAPPABLE #-} 27 | ( Monad (t1 (t2 m)) 28 | , MonadTrans t1 29 | , MonadConfigured (t2 m) 30 | ) => 31 | MonadConfigured (ComposeT t1 t2 m) 32 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Client/Application/HttpClient/Class.hs: -------------------------------------------------------------------------------- 1 | module Mensam.Client.Application.HttpClient.Class where 2 | 3 | import Control.Monad.Trans 4 | import Control.Monad.Trans.Compose 5 | import Control.Monad.Trans.Elevator 6 | import Data.Kind 7 | import Network.HTTP.Client qualified as Network 8 | 9 | type MonadHttpClient :: (Type -> Type) -> Constraint 10 | class Monad m => MonadHttpClient m where 11 | httpManager :: m Network.Manager 12 | 13 | instance 14 | ( Monad (t m) 15 | , MonadTrans t 16 | , MonadHttpClient m 17 | ) => 18 | MonadHttpClient (Elevator t m) 19 | where 20 | httpManager = lift httpManager 21 | 22 | deriving via 23 | Elevator t1 ((t2 :: (Type -> Type) -> Type -> Type) m) 24 | instance 25 | {-# OVERLAPPABLE #-} 26 | ( Monad (t1 (t2 m)) 27 | , MonadTrans t1 28 | , MonadHttpClient (t2 m) 29 | ) => 30 | MonadHttpClient (ComposeT t1 t2 m) 31 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Server/Server/Route/Static.hs: -------------------------------------------------------------------------------- 1 | module Mensam.Server.Server.Route.Static where 2 | 3 | import Mensam.API.Route.Static 4 | import Mensam.Server.Application.Configured.Class 5 | import Mensam.Server.Configuration 6 | import Mensam.Server.Server.Err404 7 | import Mensam.Server.Server.FileServer 8 | 9 | import Control.Monad.IO.Unlift 10 | import Control.Monad.Logger.CallStack 11 | import Network.Wai.Trans 12 | import Servant 13 | import Servant.RawM.Server qualified as RawM 14 | import WaiAppStatic.Types 15 | 16 | handler :: 17 | (MonadConfigured m, MonadLogger m, MonadUnliftIO m) => 18 | ServerT API m 19 | handler = do 20 | directory <- configDirectoryStatic <$> configuration 21 | fallbackApplication <- runApplicationT application404 22 | logInfo "Serve static file download." 23 | settings <- fileServerSettings directory 24 | RawM.serveDirectoryWith settings {ss404Handler = Just fallbackApplication} 25 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Server/Configuration/SQLite.hs: -------------------------------------------------------------------------------- 1 | module Mensam.Server.Configuration.SQLite where 2 | 3 | import Mensam.API.Aeson 4 | 5 | import Control.DeepSeq 6 | import Data.Aeson qualified as A 7 | import Data.Kind 8 | import Deriving.Aeson qualified as A 9 | import GHC.Generics 10 | 11 | type SQLiteConfig :: Type 12 | data SQLiteConfig = MkSQLiteConfig 13 | { sqliteFilepath :: FilePath 14 | , sqliteConnectionPoolTimeoutSeconds :: Double 15 | -- ^ Number of seconds, that an unused resource is kept in the pool. 16 | , sqliteConnectionPoolMaxNumberOfConnections :: Int 17 | -- ^ Maximum number of resources open at once. 18 | , sqliteCheckDataIntegrityOnStartup :: Bool 19 | -- ^ Maximum number of resources open at once. 20 | } 21 | deriving stock (Eq, Generic, Ord, Read, Show) 22 | deriving anyclass (NFData) 23 | deriving 24 | (A.FromJSON, A.ToJSON) 25 | via A.CustomJSON (JSONSettings "Mk" "sqlite") SQLiteConfig 26 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Client/UI/Brick/Names.hs: -------------------------------------------------------------------------------- 1 | module Mensam.Client.UI.Brick.Names where 2 | 3 | import Mensam.API.Data.Space 4 | 5 | import Data.Kind 6 | import Data.Time.Zones.All qualified as T 7 | 8 | type ClientName :: Type 9 | data ClientName 10 | = ClientNameLoginUsername 11 | | ClientNameLoginPassword 12 | | ClientNameRegisterUsername 13 | | ClientNameRegisterPassword 14 | | ClientNameRegisterEmail 15 | | ClientNameRegisterEmailVisible 16 | | ClientNameSpacesList 17 | | ClientNameSpacesNewSpaceName 18 | | ClientNameSpacesNewSpaceTimezone T.TZLabel 19 | | ClientNameSpacesNewSpaceDiscoverability DiscoverabilitySpace 20 | | ClientNameDesksNewDeskName 21 | | ClientNameDesksReservationsViewport 22 | | ClientNameDesksNewReservationDesk 23 | | ClientNameDesksNewReservationTimeBegin 24 | | ClientNameDesksNewReservationTimeEnd 25 | | ClientNameMenuList 26 | | ClientNamePopupButton 27 | deriving stock (Eq, Ord, Show) 28 | -------------------------------------------------------------------------------- /frontend/source/Mensam/Http/Status.elm: -------------------------------------------------------------------------------- 1 | module Mensam.Http.Status exposing (..) 2 | 3 | import Http 4 | 5 | 6 | type Status 7 | = Loading 8 | | Done 9 | 10 | 11 | 12 | -- TODO: Does not work currently. 13 | -- After adding the ability to cancel requests on screen changes we had to use `tracker` field for that. 14 | -- Now `status` will never be called. 15 | 16 | 17 | status : Http.Progress -> Status 18 | status progress = 19 | case progress of 20 | Http.Sending { size, sent } -> 21 | if sent == size then 22 | Loading 23 | 24 | else 25 | Loading 26 | 27 | Http.Receiving { size, received } -> 28 | case size of 29 | Nothing -> 30 | Done 31 | 32 | Just justSize -> 33 | if justSize == received then 34 | Done 35 | 36 | else 37 | Loading 38 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Client/Application/Event/Class.hs: -------------------------------------------------------------------------------- 1 | module Mensam.Client.Application.Event.Class where 2 | 3 | import Mensam.Client.UI.Brick.Events 4 | 5 | import Brick.BChan 6 | import Control.Monad.Trans 7 | import Control.Monad.Trans.Compose 8 | import Control.Monad.Trans.Elevator 9 | import Data.Kind 10 | 11 | type MonadEvent :: (Type -> Type) -> Constraint 12 | class Monad m => MonadEvent m where 13 | sendEvent :: ClientEvent -> m () 14 | eventChannel :: m (BChan ClientEvent) 15 | 16 | instance 17 | ( Monad (t m) 18 | , MonadTrans t 19 | , MonadEvent m 20 | ) => 21 | MonadEvent (Elevator t m) 22 | where 23 | sendEvent = lift . sendEvent 24 | eventChannel = lift eventChannel 25 | 26 | deriving via 27 | Elevator t1 ((t2 :: (Type -> Type) -> Type -> Type) m) 28 | instance 29 | {-# OVERLAPPABLE #-} 30 | ( Monad (t1 (t2 m)) 31 | , MonadTrans t1 32 | , MonadEvent (t2 m) 33 | ) => 34 | MonadEvent (ComposeT t1 t2 m) 35 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Client/Application/Options/Class.hs: -------------------------------------------------------------------------------- 1 | module Mensam.Client.Application.Options.Class where 2 | 3 | import Control.Monad.Trans 4 | import Control.Monad.Trans.Compose 5 | import Control.Monad.Trans.Elevator 6 | import Data.Kind 7 | import Servant.Client qualified 8 | 9 | type MonadOptions :: (Type -> Type) -> Constraint 10 | class Monad m => MonadOptions m where 11 | options :: m Options 12 | 13 | instance 14 | ( Monad (t m) 15 | , MonadTrans t 16 | , MonadOptions m 17 | ) => 18 | MonadOptions (Elevator t m) 19 | where 20 | options = lift options 21 | 22 | deriving via 23 | Elevator t1 ((t2 :: (Type -> Type) -> Type -> Type) m) 24 | instance 25 | {-# OVERLAPPABLE #-} 26 | ( Monad (t1 (t2 m)) 27 | , MonadTrans t1 28 | , MonadOptions (t2 m) 29 | ) => 30 | MonadOptions (ComposeT t1 t2 m) 31 | 32 | type Options :: Type 33 | newtype Options = MkOptions 34 | { optionBaseUrl :: Servant.Client.BaseUrl 35 | } 36 | -------------------------------------------------------------------------------- /frontend/source/Mensam/NameOrIdentifier.elm: -------------------------------------------------------------------------------- 1 | module Mensam.NameOrIdentifier exposing (..) 2 | 3 | import Json.Encode as Encode 4 | 5 | 6 | type NameOrIdentifier name identifier 7 | = Name name 8 | | Identifier identifier 9 | 10 | 11 | encode : (name -> Encode.Value) -> (identifier -> Encode.Value) -> NameOrIdentifier name identifier -> Encode.Value 12 | encode encodeName encodeIdentifier nameOrIdentifier = 13 | case nameOrIdentifier of 14 | Name name -> 15 | Encode.object 16 | [ ( "tag" 17 | , Encode.string "name" 18 | ) 19 | , ( "value" 20 | , encodeName name 21 | ) 22 | ] 23 | 24 | Identifier identifier -> 25 | Encode.object 26 | [ ( "tag" 27 | , Encode.string "identifier" 28 | ) 29 | , ( "value" 30 | , encodeIdentifier identifier 31 | ) 32 | ] 33 | -------------------------------------------------------------------------------- /server/source/library/Servant/Auth/JWT/WithSession.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | 3 | module Servant.Auth.JWT.WithSession where 4 | 5 | import Control.Monad 6 | import Data.Kind 7 | import Servant.Auth.Server 8 | import Servant.Auth.Server.Internal.Class 9 | 10 | type JWTWithSession :: Type 11 | data JWTWithSession 12 | 13 | instance (WithSession usr, IsAuth JWT usr) => IsAuth JWTWithSession usr where 14 | type AuthArgs JWTWithSession = SessionCfg ': AuthArgs JWT 15 | runAuth _ proxyUsr sessionCfg jwtSettings = 16 | AuthCheck $ 17 | runAuthCheck (runAuth (undefined :: proxy JWT) proxyUsr jwtSettings) 18 | >=> \case 19 | BadPassword -> pure BadPassword 20 | NoSuchUser -> pure NoSuchUser 21 | Authenticated u -> validateSession sessionCfg u 22 | Indefinite -> pure Indefinite 23 | 24 | type WithSession :: Type -> Constraint 25 | class WithSession a where 26 | validateSession :: SessionCfg -> a -> IO (AuthResult a) 27 | 28 | type SessionCfg :: Type 29 | type family SessionCfg 30 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Client/UI/Brick/Events.hs: -------------------------------------------------------------------------------- 1 | module Mensam.Client.UI.Brick.Events where 2 | 3 | import Mensam.API.Data.Space 4 | import Mensam.API.Route.Api.Reservation qualified as Route.Reservation 5 | import Mensam.API.Route.Api.Space qualified as Route.Space 6 | import Mensam.API.Route.Api.User qualified as Route.User 7 | import Mensam.Client.OrphanInstances (Credentials) 8 | 9 | import Data.Kind 10 | 11 | type ClientEvent :: Type 12 | data ClientEvent 13 | = ClientEventExit 14 | | ClientEventSwitchToScreenLogin 15 | | ClientEventSwitchToScreenRegister 16 | | ClientEventSwitchToScreenSpaces 17 | | ClientEventSwitchToScreenDesks Space 18 | | ClientEventSwitchToScreenMenu 19 | | ClientEventSendRequestLogin Credentials 20 | | ClientEventSendRequestLogout 21 | | ClientEventSendRequestRegister Route.User.RequestRegister 22 | | ClientEventSendRequestCreateSpace Route.Space.RequestSpaceCreate 23 | | ClientEventSendRequestCreateDesk Space Route.Space.RequestDeskCreate 24 | | ClientEventSendRequestCreateReservation Space Route.Reservation.RequestReservationCreate 25 | deriving stock (Eq, Ord, Show) 26 | -------------------------------------------------------------------------------- /server/source/library/Mensam/API/Order.hs: -------------------------------------------------------------------------------- 1 | module Mensam.API.Order where 2 | 3 | import Mensam.API.Aeson 4 | 5 | import Data.Aeson qualified as A 6 | import Data.Kind 7 | import Deriving.Aeson qualified as A 8 | import GHC.Generics 9 | 10 | type Order :: Type 11 | data Order = Ascending | Descending 12 | deriving stock (Bounded, Enum, Eq, Generic, Ord, Read, Show) 13 | deriving 14 | (A.FromJSON, A.ToJSON) 15 | via A.CustomJSON (JSONSettings "" "") Order 16 | 17 | type OrderByCategory :: Type -> Type 18 | type role OrderByCategory _ 19 | data OrderByCategory a = MkOrderByCategory 20 | { orderByCategoryCategory :: a 21 | , orderByCategoryOrder :: Order 22 | } 23 | deriving stock (Eq, Generic, Ord, Read, Show) 24 | deriving 25 | (A.FromJSON, A.ToJSON) 26 | via A.CustomJSON (JSONSettings "Mk" "orderByCategory") (OrderByCategory a) 27 | 28 | type OrderByCategories :: Type -> Type 29 | type role OrderByCategories _ 30 | newtype OrderByCategories a = MkOrderByCategories {unOrderByCategories :: [OrderByCategory a]} 31 | deriving stock (Eq, Generic, Ord, Read, Show) 32 | deriving newtype (A.FromJSON, A.ToJSON) 33 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Server/Server/FileServer.hs: -------------------------------------------------------------------------------- 1 | module Mensam.Server.Server.FileServer where 2 | 3 | import Control.Monad.IO.Unlift 4 | import Control.Monad.Logger.CallStack 5 | import Data.Text qualified as T 6 | import WaiAppStatic.Storage.Filesystem 7 | import WaiAppStatic.Types 8 | 9 | fileServerSettings :: 10 | (MonadLogger m, MonadUnliftIO m) => 11 | FilePath -> 12 | m StaticSettings 13 | fileServerSettings path = 14 | withRunInIO $ \runInIO -> 15 | pure $ case defaultWebAppSettings path of 16 | defaultSettings@StaticSettings {ssLookupFile, ssGetMimeType} -> 17 | defaultSettings 18 | { ssLookupFile = \pieces -> do 19 | runInIO . logInfo $ "Looking up file: " <> T.pack (show pieces) 20 | ssLookupFile pieces 21 | , ssGetMimeType = \file -> do 22 | mimeType <- ssGetMimeType file 23 | runInIO . logInfo $ "Determined mime type: " <> T.pack (show mimeType) 24 | pure mimeType 25 | , ssAddTrailingSlash = True -- Disable directory overview without trailing slash, because some links are broken. 26 | } 27 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Server/Server/Route/Haddock.hs: -------------------------------------------------------------------------------- 1 | module Mensam.Server.Server.Route.Haddock where 2 | 3 | import Mensam.API.Route.Static 4 | import Mensam.Server.Application.Configured.Class 5 | import Mensam.Server.Configuration 6 | import Mensam.Server.Server.Err404 7 | import Mensam.Server.Server.FileServer 8 | 9 | import Control.Monad.IO.Unlift 10 | import Control.Monad.Logger.CallStack 11 | import Network.Wai.Application.Static 12 | import Network.Wai.Trans 13 | import Servant 14 | import Servant.RawM.Server qualified as RawM 15 | 16 | handler :: 17 | (MonadConfigured m, MonadLogger m, MonadUnliftIO m) => 18 | ServerT API m 19 | handler = do 20 | maybeDirectory <- configDirectoryHaddock <$> configuration 21 | fallbackApplication <- runApplicationT application404 22 | case maybeDirectory of 23 | Nothing -> do 24 | logWarn "No haddock files configured. Serving fallback application." 25 | pure fallbackApplication 26 | Just directory -> do 27 | logInfo "Serve haddock file download." 28 | settings <- fileServerSettings directory 29 | RawM.serveDirectoryWith settings {ss404Handler = Just fallbackApplication} 30 | -------------------------------------------------------------------------------- /server/source/library/Mensam/API/Update.hs: -------------------------------------------------------------------------------- 1 | module Mensam.API.Update where 2 | 3 | import Data.Aeson qualified as A 4 | import Data.Kind 5 | import GHC.Generics 6 | 7 | type Updatable :: Type -> Type 8 | type role Updatable _ 9 | data Updatable a 10 | = Preserve 11 | | Overwrite a 12 | deriving stock (Eq, Generic, Ord, Read, Show) 13 | 14 | instance A.FromJSON a => A.FromJSON (Updatable a) where 15 | parseJSON = A.withObject "Updatable" $ \v -> do 16 | isUpdate :: Bool <- v A..: "update" 17 | if isUpdate 18 | then do 19 | value :: a <- v A..: "value" 20 | pure $ Overwrite value 21 | else do 22 | value :: Maybe A.Value <- v A..:! "value" 23 | case value of 24 | Nothing -> pure Preserve 25 | Just _ -> fail "Expected no value to be present, because the 'update' field is false." 26 | 27 | instance A.ToJSON a => A.ToJSON (Updatable a) where 28 | toJSON = \case 29 | Preserve -> 30 | A.object 31 | [ ("update", A.Bool False) 32 | ] 33 | Overwrite value -> 34 | A.object 35 | [ ("update", A.Bool True) 36 | , ("value", A.toJSON value) 37 | ] 38 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Server/Server/Route/Api.hs: -------------------------------------------------------------------------------- 1 | module Mensam.Server.Server.Route.Api where 2 | 3 | import Mensam.API.Route.Api 4 | import Mensam.Server.Application.Configured.Class 5 | import Mensam.Server.Application.Email.Class 6 | import Mensam.Server.Application.Secret.Class 7 | import Mensam.Server.Application.SeldaPool.Class 8 | import Mensam.Server.Server.Route.Api.OpenApi qualified 9 | import Mensam.Server.Server.Route.Api.Reservation qualified 10 | import Mensam.Server.Server.Route.Api.Space qualified 11 | import Mensam.Server.Server.Route.Api.User qualified 12 | 13 | import Control.Monad.IO.Unlift 14 | import Control.Monad.Logger.CallStack 15 | import Servant.Server.Generic 16 | 17 | handler :: 18 | (MonadConfigured m, MonadEmail m, MonadLogger m, MonadSecret m, MonadSeldaPool m, MonadUnliftIO m) => 19 | Routes (AsServerT m) 20 | handler = 21 | Routes 22 | { routeOpenApi = Mensam.Server.Server.Route.Api.OpenApi.handler 23 | , routeUser = Mensam.Server.Server.Route.Api.User.handler 24 | , routeSpace = Mensam.Server.Server.Route.Api.Space.handler 25 | , routeReservation = Mensam.Server.Server.Route.Api.Reservation.handler 26 | } 27 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Server/Application/Environment/Class.hs: -------------------------------------------------------------------------------- 1 | module Mensam.Server.Application.Environment.Class where 2 | 3 | import Mensam.Server.Environment 4 | 5 | import Control.Monad.Trans 6 | import Control.Monad.Trans.Compose 7 | import Control.Monad.Trans.Elevator 8 | import Data.Kind 9 | import Data.Singletons 10 | import GHC.TypeLits 11 | 12 | type MonadEnvironment :: (Type -> Type) -> Constraint 13 | class Monad m => MonadEnvironment m where 14 | environmentVariable :: 15 | forall envVar. 16 | SingI envVar => 17 | ProxyEnvVarName (EnvVarName envVar) -> 18 | m (EnvVarValue envVar) 19 | 20 | instance 21 | ( Monad (t m) 22 | , MonadTrans t 23 | , MonadEnvironment m 24 | ) => 25 | MonadEnvironment (Elevator t m) 26 | where 27 | environmentVariable = lift . environmentVariable 28 | 29 | deriving via 30 | Elevator t1 ((t2 :: (Type -> Type) -> Type -> Type) m) 31 | instance 32 | {-# OVERLAPPABLE #-} 33 | ( Monad (t1 (t2 m)) 34 | , MonadTrans t1 35 | , MonadEnvironment (t2 m) 36 | ) => 37 | MonadEnvironment (ComposeT t1 t2 m) 38 | 39 | type ProxyEnvVarName :: Symbol -> Type 40 | type role ProxyEnvVarName _ 41 | data ProxyEnvVarName name = EnvVar 42 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Server/Server/Route.hs: -------------------------------------------------------------------------------- 1 | module Mensam.Server.Server.Route where 2 | 3 | import Mensam.API.Route 4 | import Mensam.Server.Application.Configured.Class 5 | import Mensam.Server.Application.Email.Class 6 | import Mensam.Server.Application.Secret.Class 7 | import Mensam.Server.Application.SeldaPool.Class 8 | import Mensam.Server.Server.Route.Api qualified 9 | import Mensam.Server.Server.Route.Frontend qualified 10 | import Mensam.Server.Server.Route.Haddock qualified 11 | import Mensam.Server.Server.Route.OpenApi qualified 12 | import Mensam.Server.Server.Route.Static qualified 13 | 14 | import Control.Monad.IO.Unlift 15 | import Control.Monad.Logger.CallStack 16 | import Servant.Server.Generic 17 | 18 | routes :: 19 | (MonadConfigured m, MonadEmail m, MonadLogger m, MonadSecret m, MonadSeldaPool m, MonadUnliftIO m) => 20 | Routes (AsServerT m) 21 | routes = 22 | Routes 23 | { routeApi = Mensam.Server.Server.Route.Api.handler 24 | , routeOpenApi = Mensam.Server.Server.Route.OpenApi.handler 25 | , routeStatic = Mensam.Server.Server.Route.Static.handler 26 | , routeHaddock = Mensam.Server.Server.Route.Haddock.handler 27 | , routeFrontend = Mensam.Server.Server.Route.Frontend.handler 28 | } 29 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Server/Application/Email/Class.hs: -------------------------------------------------------------------------------- 1 | module Mensam.Server.Application.Email.Class where 2 | 3 | import Control.Monad.Trans.Class 4 | import Control.Monad.Trans.Compose 5 | import Control.Monad.Trans.Elevator 6 | import Data.Kind 7 | import Data.Text qualified as T 8 | import GHC.Generics 9 | import Text.Email.Parser 10 | 11 | type MonadEmail :: (Type -> Type) -> Constraint 12 | class Monad m => MonadEmail m where 13 | sendEmail :: Email -> m SendEmailResult 14 | 15 | instance 16 | ( Monad (t m) 17 | , MonadTrans t 18 | , MonadEmail m 19 | ) => 20 | MonadEmail (Elevator t m) 21 | where 22 | sendEmail = lift . sendEmail 23 | 24 | deriving via 25 | Elevator t1 ((t2 :: (Type -> Type) -> Type -> Type) m) 26 | instance 27 | {-# OVERLAPPABLE #-} 28 | ( Monad (t1 (t2 m)) 29 | , MonadTrans t1 30 | , MonadEmail (t2 m) 31 | ) => 32 | MonadEmail (ComposeT t1 t2 m) 33 | 34 | type Email :: Type 35 | data Email = MkEmail 36 | { emailRecipient :: EmailAddress 37 | , emailTitle :: T.Text 38 | , emailBodyHtml :: T.Text 39 | } 40 | deriving stock (Eq, Generic, Ord, Read, Show) 41 | 42 | type SendEmailResult :: Type 43 | data SendEmailResult 44 | = EmailSent 45 | | EmailFailedToSend 46 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Server/Options.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ApplicativeDo #-} 2 | 3 | module Mensam.Server.Options where 4 | 5 | import Mensam.Server.Environment 6 | 7 | import Data.Foldable 8 | import Data.Kind 9 | import Data.String 10 | import Options.Applicative 11 | import Options.Applicative.Extra 12 | import Options.Applicative.Help.Pretty 13 | 14 | type Options :: Type 15 | newtype Options = MkOptions 16 | { optionUnit :: () 17 | } 18 | 19 | defaultOptions :: Options 20 | defaultOptions = 21 | MkOptions 22 | { optionUnit = () 23 | } 24 | 25 | parserInfoOptions :: ParserInfo Options 26 | parserInfoOptions = 27 | info parserOptions $ 28 | fold 29 | [ header "Mensam Server" 30 | , progDesc "host a webserver" 31 | , footerDoc $ 32 | Just $ 33 | vcat 34 | [ "Environment variables:" 35 | , indent 2 $ vcat $ fromString <$> envVarHelp 36 | ] 37 | ] 38 | 39 | parserOptions :: Parser Options 40 | parserOptions = do 41 | addHelper <- 42 | helperWith $ 43 | fold 44 | [ short 'h' 45 | , long "help" 46 | , help "display this help message" 47 | ] 48 | pure $ addHelper $ MkOptions {optionUnit = ()} 49 | -------------------------------------------------------------------------------- /frontend/source/Mensam/Color.elm: -------------------------------------------------------------------------------- 1 | module Mensam.Color exposing (..) 2 | 3 | 4 | type alias Color = 5 | { r : Int, g : Int, b : Int } 6 | 7 | 8 | dark : AnsiIso6429 9 | dark = 10 | { black = { r = 40, g = 42, b = 46 } 11 | , red = { r = 165, g = 66, b = 66 } 12 | , green = { r = 140, g = 148, b = 64 } 13 | , yellow = { r = 222, g = 147, b = 95 } 14 | , blue = { r = 95, g = 129, b = 157 } 15 | , magenta = { r = 133, g = 103, b = 143 } 16 | , cyan = { r = 94, g = 141, b = 135 } 17 | , white = { r = 112, g = 120, b = 128 } 18 | } 19 | 20 | 21 | bright : AnsiIso6429 22 | bright = 23 | { black = { r = 55, g = 59, b = 65 } 24 | , red = { r = 204, g = 102, b = 102 } 25 | , green = { r = 181, g = 189, b = 104 } 26 | , yellow = { r = 240, g = 198, b = 116 } 27 | , blue = { r = 129, g = 162, b = 190 } 28 | , magenta = { r = 178, g = 148, b = 187 } 29 | , cyan = { r = 138, g = 190, b = 183 } 30 | , white = { r = 197, g = 200, b = 198 } 31 | } 32 | 33 | 34 | type alias AnsiIso6429 = 35 | { black : Color 36 | , red : Color 37 | , green : Color 38 | , yellow : Color 39 | , blue : Color 40 | , magenta : Color 41 | , cyan : Color 42 | , white : Color 43 | } 44 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Client/UI/Brick/State.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Mensam.Client.UI.Brick.State where 4 | 5 | import Mensam.API.Route.Api.User 6 | import Mensam.Client.UI.Desks 7 | import Mensam.Client.UI.Login 8 | import Mensam.Client.UI.Menu 9 | import Mensam.Client.UI.Register 10 | import Mensam.Client.UI.Spaces 11 | 12 | import Data.Kind 13 | import Data.Text qualified as T 14 | import Data.Time qualified as T 15 | import Lens.Micro.Platform 16 | 17 | type ClientScreenState :: Type 18 | data ClientScreenState 19 | = ClientScreenStateLogin {_clientScreenStateLogin :: ScreenLoginState} 20 | | ClientScreenStateRegister {_clientScreenStateRegister :: ScreenRegisterState} 21 | | ClientScreenStateSpaces {_clientScreenStateSpaces :: ScreenSpacesState} 22 | | ClientScreenStateDesks {_clientScreenStateDesks :: ScreenDesksState} 23 | | ClientScreenStateMenu {_clientScreenStateMenu :: ScreenMenuState} 24 | makeLenses ''ClientScreenState 25 | 26 | type ClientState :: Type 27 | data ClientState = MkClientState 28 | { _clientStateScreenState :: ClientScreenState 29 | , _clientStatePopup :: Maybe T.Text 30 | , _clientStateJwt :: Maybe Jwt 31 | , _clientStateTimezone :: T.TimeZone 32 | } 33 | makeLenses ''ClientState 34 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Server/Application/Configured/Acquisition.hs: -------------------------------------------------------------------------------- 1 | module Mensam.Server.Application.Configured.Acquisition where 2 | 3 | import Mensam.Server.Application.Environment.Class 4 | import Mensam.Server.Configuration 5 | 6 | import Control.Monad.IO.Class 7 | import Control.Monad.Logger.CallStack 8 | import Data.Aeson qualified as A 9 | import Data.Text qualified as T 10 | import System.Posix.Files 11 | 12 | acquireConfig :: 13 | (MonadIO m, MonadEnvironment m, MonadLogger m) => 14 | m (Maybe Configuration) 15 | acquireConfig = do 16 | logInfo "Checking configuration file." 17 | configFile <- environmentVariable $ EnvVar @"MENSAM_CONFIG_FILE" 18 | exists <- liftIO $ fileExist configFile 19 | if exists 20 | then do 21 | logInfo "Reading configuration file." 22 | eitherContent <- liftIO $ A.eitherDecodeFileStrict configFile 23 | case eitherContent of 24 | Left err -> do 25 | logError $ "Failed to read/parse configuration file: " <> T.pack (show err) 26 | pure Nothing 27 | Right config -> do 28 | logInfo $ "Acquired configuration: " <> T.pack (show config) 29 | pure $ Just config 30 | else do 31 | logError "Can't find configuration file." 32 | pure Nothing 33 | -------------------------------------------------------------------------------- /.devcontainer/Dockerfile: -------------------------------------------------------------------------------- 1 | FROM mcr.microsoft.com/devcontainers/base:alpine 2 | 3 | # Install nix 4 | RUN curl --output nix-installer.sh --proto '=https' --tlsv1.2 -L https://nixos.org/nix/install 5 | RUN chmod +x nix-installer.sh 6 | RUN ./nix-installer.sh --daemon --yes 7 | RUN echo 'accept-flake-config = true' >> /etc/nix/nix.conf 8 | RUN echo 'experimental-features = nix-command flakes' >> /etc/nix/nix.conf 9 | RUN echo 'substituters = https://cache.nixos.org/ https://jumper149-mensam.cachix.org' >> /etc/nix/nix.conf 10 | RUN echo 'trusted-public-keys = cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= jumper149-mensam.cachix.org-1:9502wAOm00GdLxZM8uTE4goaBGCpHb+d1jUt3dhR8ZM=' >> /etc/nix/nix.conf 11 | 12 | # Install direnv 13 | RUN apk add direnv 14 | RUN mkdir -p /root/.config/direnv/ 15 | RUN echo $'[whitelist]\n\ 16 | prefix = [ "/" ]\n\ 17 | ' > /root/.config/direnv/direnv.toml 18 | RUN git clone https://github.com/nix-community/nix-direnv.git /usr/share/nix-direnv-source 19 | RUN echo 'source /usr/share/nix-direnv-source/direnvrc' > /root/.config/direnv/direnvrc 20 | 21 | # Choose bash as the default shell 22 | RUN chsh --shell /bin/bash root 23 | 24 | # Run the Nix daemon in the background 25 | ENTRYPOINT ["/nix/var/nix/profiles/default/bin/nix-daemon"] 26 | CMD ["--daemon"] 27 | -------------------------------------------------------------------------------- /server/source/library/Servant/API/ImageJpeg.hs: -------------------------------------------------------------------------------- 1 | module Servant.API.ImageJpeg where 2 | 3 | import Codec.Picture.Jpg 4 | import Control.Lens 5 | import Data.ByteString.Lazy qualified as BL 6 | import Data.Kind 7 | import Data.OpenApi 8 | import Data.Proxy 9 | import GHC.Generics 10 | import Network.HTTP.Media qualified 11 | import Servant.API 12 | 13 | type ImageJpegBytes :: Type 14 | newtype ImageJpegBytes = MkImageJpegBytes {unImageJpegBytes :: BL.ByteString} 15 | deriving stock (Eq, Generic, Ord, Read, Show) 16 | 17 | instance ToParamSchema ImageJpegBytes where 18 | toParamSchema Proxy = 19 | mempty 20 | & type_ ?~ OpenApiString 21 | & format ?~ "binary" 22 | instance ToSchema ImageJpegBytes where 23 | declareNamedSchema = pure . NamedSchema (Just "ImageJpegBytes") . paramSchemaToSchema 24 | 25 | type ImageJpeg :: Type 26 | data ImageJpeg 27 | 28 | instance Accept ImageJpeg where 29 | contentType Proxy = "image" Network.HTTP.Media.// "jpeg" 30 | 31 | instance MimeRender ImageJpeg ImageJpegBytes where 32 | mimeRender Proxy = unImageJpegBytes 33 | 34 | instance MimeUnrender ImageJpeg ImageJpegBytes where 35 | mimeUnrender Proxy bytes = 36 | case decodeJpeg $ BL.toStrict bytes of 37 | Left err -> Left err 38 | Right _ -> Right $ MkImageJpegBytes bytes 39 | -------------------------------------------------------------------------------- /server/source/library/Mensam/API/Aeson/StaticText/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {-# OPTIONS_GHC -Wno-orphans #-} 3 | 4 | module Mensam.API.Aeson.StaticText.Internal where 5 | 6 | import Mensam.API.Aeson.StaticText.Internal.Union qualified as Union 7 | 8 | import Control.Applicative 9 | import Data.Aeson qualified as A 10 | import Data.SOP qualified as SOP 11 | import Text.Read qualified 12 | 13 | instance Read (SOP.NS f '[]) where 14 | readPrec = fail "Cannot read empty sum" 15 | deriving stock instance (Read (f x), Read (SOP.NS f xs)) => Read (SOP.NS f (x : xs)) 16 | 17 | instance A.ToJSON (SOP.NS f '[]) where 18 | toJSON = \case {} 19 | instance (A.ToJSON (f x), A.ToJSON (SOP.NS f xs), Union.Unique (x : xs)) => A.ToJSON (SOP.NS f (x : xs)) where 20 | toJSON = \case 21 | SOP.Z ix -> A.toJSON ix 22 | SOP.S ns -> A.toJSON ns 23 | 24 | instance A.FromJSON (SOP.NS f '[]) where 25 | parseJSON _ = fail "Cannot parse empty sum" 26 | instance (A.FromJSON (f x), A.FromJSON (SOP.NS f xs), Union.Unique (x : xs)) => A.FromJSON (SOP.NS f (x : xs)) where 27 | parseJSON value = (SOP.Z <$> A.parseJSON @(f x) value) <|> (SOP.S <$> A.parseJSON @(SOP.NS f xs) value) 28 | 29 | deriving newtype instance A.ToJSON a => A.ToJSON (SOP.I a) 30 | deriving newtype instance A.FromJSON a => A.FromJSON (SOP.I a) 31 | -------------------------------------------------------------------------------- /frontend/source/Mensam/Auth/Basic.elm: -------------------------------------------------------------------------------- 1 | module Mensam.Auth.Basic exposing (..) 2 | 3 | import Base64 4 | import Http 5 | import Json.Decode as Decode 6 | 7 | 8 | type Credentials 9 | = MkCredentials 10 | { username : String 11 | , password : String 12 | } 13 | 14 | 15 | authorizationHeader : Credentials -> Http.Header 16 | authorizationHeader (MkCredentials credentials) = 17 | Http.header 18 | "Authorization" 19 | ("Basic " ++ Base64.encode (credentials.username ++ ":" ++ credentials.password)) 20 | 21 | 22 | type Error 23 | = ErrorUsername 24 | | ErrorPassword 25 | | ErrorIndefinite 26 | 27 | 28 | http401BodyDecoder : Decode.Decoder Error 29 | http401BodyDecoder = 30 | Decode.string 31 | |> Decode.andThen 32 | (\string -> 33 | case string of 34 | "username" -> 35 | Decode.succeed ErrorUsername 36 | 37 | "password" -> 38 | Decode.succeed ErrorPassword 39 | 40 | "indefinite" -> 41 | Decode.succeed ErrorIndefinite 42 | 43 | _ -> 44 | Decode.fail <| "Trying to decode basic authentication error, but this option is not supported: " ++ string 45 | ) 46 | -------------------------------------------------------------------------------- /fallback/source/fallback.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | Mensam unavailable 6 | 44 | 45 | 46 | 47 |
48 |
Mensam
49 |
is currently unavailable
50 |
51 | 52 | 53 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Server/Application/SeldaPool/Servant.hs: -------------------------------------------------------------------------------- 1 | module Mensam.Server.Application.SeldaPool.Servant where 2 | 3 | import Mensam.Server.Application.SeldaPool.Class 4 | 5 | import Control.Exception 6 | import Control.Monad.Logger.CallStack 7 | import Data.Text qualified as T 8 | import Servant 9 | 10 | handleSeldaException :: 11 | ( Exception e 12 | , HasStatus r 13 | , Applicative m 14 | , IsMember r responses 15 | ) => 16 | Proxy e -> 17 | r -> 18 | SeldaResult a -> 19 | (SeldaResult a -> m (Union responses)) -> 20 | m (Union responses) 21 | handleSeldaException (Proxy :: Proxy e) response seldaResult handleResult = 22 | case seldaResult of 23 | SeldaSuccess _ -> handleResult seldaResult 24 | SeldaFailure err -> 25 | case fromException @e err of 26 | Just _ -> do 27 | respond response 28 | Nothing -> 29 | handleResult seldaResult 30 | 31 | handleSeldaSomeException :: 32 | ( HasStatus r 33 | , MonadLogger m 34 | , IsMember r responses 35 | ) => 36 | r -> 37 | SeldaResult a -> 38 | (a -> m (Union responses)) -> 39 | m (Union responses) 40 | handleSeldaSomeException response seldaResult handleResult = 41 | case seldaResult of 42 | SeldaSuccess x -> handleResult x 43 | SeldaFailure err -> do 44 | logWarn $ "Handled unexpected Selda failure: " <> T.pack (show err) 45 | respond response 46 | -------------------------------------------------------------------------------- /frontend/source/Mensam/Auth/Bearer.elm: -------------------------------------------------------------------------------- 1 | module Mensam.Auth.Bearer exposing (..) 2 | 3 | import Http 4 | import Json.Decode as Decode 5 | import Json.Encode as Encode 6 | import Mensam.Error 7 | 8 | 9 | type Jwt 10 | = MkJwt String 11 | 12 | 13 | decoder : Decode.Decoder Jwt 14 | decoder = 15 | Decode.map MkJwt Decode.string 16 | 17 | 18 | encode : Jwt -> Encode.Value 19 | encode (MkJwt string) = 20 | Encode.string string 21 | 22 | 23 | authorizationHeader : Jwt -> Http.Header 24 | authorizationHeader (MkJwt string) = 25 | Http.header "Authorization" ("Bearer " ++ string) 26 | 27 | 28 | type Error 29 | = ErrorIndefinite 30 | 31 | 32 | error : Error -> Mensam.Error.Error 33 | error err = 34 | Mensam.Error.message "Bearer authentication failed" <| 35 | Mensam.Error.message "Try signing in again" <| 36 | case err of 37 | ErrorIndefinite -> 38 | Mensam.Error.undefined 39 | 40 | 41 | http401BodyDecoder : Decode.Decoder Error 42 | http401BodyDecoder = 43 | Decode.string 44 | |> Decode.andThen 45 | (\string -> 46 | case string of 47 | "indefinite" -> 48 | Decode.succeed ErrorIndefinite 49 | 50 | _ -> 51 | Decode.fail <| "Trying to decode authentication error, but this option is not supported: " ++ string 52 | ) 53 | -------------------------------------------------------------------------------- /frontend/review/elm.json: -------------------------------------------------------------------------------- 1 | { 2 | "type": "application", 3 | "source-directories": [ 4 | "src" 5 | ], 6 | "elm-version": "0.19.1", 7 | "dependencies": { 8 | "direct": { 9 | "elm/core": "1.0.5", 10 | "jfmengels/elm-review": "2.15.3", 11 | "jfmengels/elm-review-common": "1.3.3", 12 | "jfmengels/elm-review-unused": "1.2.4", 13 | "mthadley/elm-review-unit": "2.0.2", 14 | "sparksp/elm-review-imports": "1.0.2", 15 | "sparksp/elm-review-ports": "1.3.1", 16 | "stil4m/elm-syntax": "7.3.9", 17 | "truqu/elm-review-nobooleancase": "1.0.1", 18 | "webbhuset/elm-review-forbid-specific-imports": "1.0.0" 19 | }, 20 | "indirect": { 21 | "elm/bytes": "1.0.8", 22 | "elm/html": "1.0.0", 23 | "elm/json": "1.1.3", 24 | "elm/parser": "1.1.0", 25 | "elm/project-metadata-utils": "1.0.2", 26 | "elm/random": "1.0.0", 27 | "elm/regex": "1.0.0", 28 | "elm/time": "1.0.0", 29 | "elm/url": "1.0.0", 30 | "elm/virtual-dom": "1.0.4", 31 | "elm-explorations/test": "2.2.0", 32 | "rtfeldman/elm-hex": "1.0.0", 33 | "stil4m/structured-writer": "1.0.3" 34 | } 35 | }, 36 | "test-dependencies": { 37 | "direct": {}, 38 | "indirect": {} 39 | } 40 | } 41 | -------------------------------------------------------------------------------- /frontend/source/Mensam/Flags.elm: -------------------------------------------------------------------------------- 1 | module Mensam.Flags exposing 2 | ( Flags(..) 3 | , FlagsRaw 4 | , parse 5 | ) 6 | 7 | import Json.Decode as Decode 8 | import Json.Encode as Encode 9 | import Mensam.Error 10 | import Mensam.Storage 11 | import Mensam.Time 12 | import Mensam.Url 13 | import Time 14 | 15 | 16 | type Flags 17 | = MkFlags 18 | { storage : Maybe Mensam.Storage.Storage 19 | , time : 20 | { now : Time.Posix 21 | , zone : Mensam.Time.Timezone 22 | } 23 | , baseUrl : Mensam.Url.BaseUrl 24 | } 25 | 26 | 27 | type alias FlagsRaw = 28 | Encode.Value 29 | 30 | 31 | parse : FlagsRaw -> Result Mensam.Error.Error Flags 32 | parse flagsRaw = 33 | Result.mapError 34 | (Mensam.Error.message "Failed to parse flags" << Mensam.Error.json) 35 | <| 36 | Decode.decodeValue decoder flagsRaw 37 | 38 | 39 | decoder : Decode.Decoder Flags 40 | decoder = 41 | Decode.map3 (\storage time baseUrl -> MkFlags { storage = storage, time = time, baseUrl = baseUrl }) 42 | (Decode.field "storage" Mensam.Storage.decoder) 43 | (Decode.field "time" <| 44 | Decode.map2 (\now timezone -> { now = now, zone = timezone }) 45 | (Decode.field "now" (Decode.map Time.millisToPosix Decode.int)) 46 | (Decode.field "zone" Mensam.Time.timezoneDecoder) 47 | ) 48 | (Decode.field "base-url" Mensam.Url.decoder) 49 | -------------------------------------------------------------------------------- /frontend/source/Mensam/Auth.elm: -------------------------------------------------------------------------------- 1 | module Mensam.Auth exposing (..) 2 | 3 | import Mensam.Auth.Bearer 4 | import Mensam.Storage 5 | import Mensam.User 6 | import Time 7 | 8 | 9 | type Model 10 | = SignedOut 11 | | SignedIn Authentication 12 | 13 | 14 | init : Maybe Mensam.Storage.Storage -> Model 15 | init maybeStorage = 16 | case maybeStorage of 17 | Nothing -> 18 | SignedOut 19 | 20 | Just (Mensam.Storage.MkStorage storage) -> 21 | SignedIn <| 22 | MkAuthentication 23 | { jwt = storage.jwt 24 | , expiration = storage.expiration 25 | , user = 26 | { id = storage.id 27 | , info = Nothing 28 | } 29 | } 30 | 31 | 32 | type Authentication 33 | = MkAuthentication 34 | { jwt : Mensam.Auth.Bearer.Jwt 35 | , expiration : Maybe Time.Posix 36 | , user : 37 | { id : Mensam.User.Identifier 38 | , info : 39 | Maybe 40 | { name : Mensam.User.Name 41 | } 42 | } 43 | } 44 | 45 | 46 | isExpired : Authentication -> Time.Posix -> Bool 47 | isExpired (MkAuthentication authentication) now = 48 | case authentication.expiration of 49 | Nothing -> 50 | False 51 | 52 | Just expiration -> 53 | Time.posixToMillis now > Time.posixToMillis expiration 54 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Server/Application/Environment.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | 3 | module Mensam.Server.Application.Environment where 4 | 5 | import Mensam.Server.Application.Environment.Class 6 | import Mensam.Server.Environment 7 | 8 | import Control.Monad.Trans 9 | import Control.Monad.Trans.Compose 10 | import Control.Monad.Trans.Control 11 | import Control.Monad.Trans.Control.Identity 12 | import Control.Monad.Trans.Reader 13 | import Data.Kind 14 | import Data.Singletons 15 | 16 | type EnvironmentT :: (Type -> Type) -> Type -> Type 17 | type role EnvironmentT _ _ 18 | newtype EnvironmentT m a = EnvironmentT {unEnvironmentT :: ReaderT Environment m a} 19 | deriving newtype (Applicative, Functor, Monad) 20 | deriving newtype (MonadTrans, MonadTransControl, MonadTransControlIdentity) 21 | 22 | instance Monad m => MonadEnvironment (EnvironmentT m) where 23 | environmentVariable :: 24 | forall envVar. 25 | SingI envVar => 26 | ProxyEnvVarName (EnvVarName envVar) -> 27 | EnvironmentT m (EnvVarValue envVar) 28 | environmentVariable _ = do 29 | environment <- EnvironmentT ask 30 | let accessEnvVar = getEnvironment environment 31 | pure $ accessEnvVar $ sing @envVar 32 | 33 | deriving via 34 | EnvironmentT ((t2 :: (Type -> Type) -> Type -> Type) m) 35 | instance 36 | Monad (t2 m) => MonadEnvironment (ComposeT EnvironmentT t2 m) 37 | 38 | runEnvironmentT :: Environment -> EnvironmentT m a -> m a 39 | runEnvironmentT env tma = runReaderT (unEnvironmentT tma) env 40 | -------------------------------------------------------------------------------- /.github/workflows/release.yml: -------------------------------------------------------------------------------- 1 | jobs: 2 | push-docker-image: 3 | name: "Build and push Docker Image to Docker Hub Registry" 4 | runs-on: ubuntu-latest 5 | steps: 6 | - name: "Set up GitHub Actions" 7 | uses: actions/checkout@v4.1.7 8 | - name: "Set up Nix" 9 | uses: cachix/install-nix-action@v27 10 | - name: "Set up Cachix" 11 | uses: cachix/cachix-action@v15 12 | with: 13 | authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}' 14 | name: jumper149-mensam 15 | - name: "Log in to Docker Hub" 16 | uses: docker/login-action@v3.3.0 17 | with: 18 | username: ${{ secrets.DOCKERHUB_USERNAME }} 19 | password: ${{ secrets.DOCKERHUB_TOKEN }} 20 | - name: "Build Docker Image" 21 | run: nix build ".#dockerImages.default" --print-build-logs 22 | - name: "Load Docker Image" 23 | run: docker load --input result 24 | - name: "Set Docker Image Tag (git commit hash)" 25 | run: docker tag mensam:${GITHUB_SHA} jumper149/mensam:${GITHUB_SHA} 26 | - name: "Push Docker Image to Docker Hub (git commit hash)" 27 | run: docker push jumper149/mensam:${GITHUB_SHA} 28 | - name: "Set Docker Image Tag (version tag)" 29 | run: docker tag mensam:${GITHUB_SHA} jumper149/mensam:${GITHUB_REF#refs/tags/} 30 | - name: "Push Docker Image to Docker Hub (version tag)" 31 | run: docker push jumper149/mensam:${GITHUB_REF#refs/tags/} 32 | name: "Release" 33 | on: 34 | push: 35 | tags: 36 | - 'v[0-9]+.[0-9]+.[0-9]+.[0-9]+' 37 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Client/Application/Event.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | 3 | module Mensam.Client.Application.Event where 4 | 5 | import Mensam.Client.Application.Event.Class 6 | import Mensam.Client.UI.Brick.Events 7 | 8 | import Brick.BChan 9 | import Control.Monad.Logger.CallStack 10 | import Control.Monad.Trans 11 | import Control.Monad.Trans.Compose 12 | import Control.Monad.Trans.Control 13 | import Control.Monad.Trans.Control.Identity 14 | import Control.Monad.Trans.Reader 15 | import Data.Kind 16 | 17 | type EventT :: (Type -> Type) -> Type -> Type 18 | type role EventT _ _ 19 | newtype EventT m a = MkEventT {unEventT :: ReaderT (BChan ClientEvent) m a} 20 | deriving newtype (Applicative, Functor, Monad) 21 | deriving newtype (MonadTrans, MonadTransControl, MonadTransControlIdentity) 22 | 23 | instance MonadIO m => MonadEvent (EventT m) where 24 | sendEvent event = MkEventT $ do 25 | chan <- ask 26 | liftIO $ writeBChan chan event 27 | eventChannel = MkEventT ask 28 | 29 | deriving via 30 | EventT ((t2 :: (Type -> Type) -> Type -> Type) m) 31 | instance 32 | MonadIO (t2 m) => MonadEvent (ComposeT EventT t2 m) 33 | 34 | runEventT :: EventT m a -> BChan ClientEvent -> m a 35 | runEventT = runReaderT . unEventT 36 | 37 | runAppEventT :: 38 | (MonadIO m, MonadLogger m) => 39 | EventT m a -> 40 | m a 41 | runAppEventT tma = do 42 | logInfo "Creating new event channel." 43 | chan <- liftIO $ newBChan 10 44 | logInfo "Created new event channel." 45 | runEventT tma chan 46 | -------------------------------------------------------------------------------- /frontend/source/Mensam/Reservation.elm: -------------------------------------------------------------------------------- 1 | module Mensam.Reservation exposing (..) 2 | 3 | import Json.Decode as Decode 4 | import Json.Encode as Encode 5 | 6 | 7 | type Identifier 8 | = MkIdentifier Int 9 | 10 | 11 | identifierEncode : Identifier -> Encode.Value 12 | identifierEncode (MkIdentifier identifier) = 13 | Encode.int identifier 14 | 15 | 16 | identifierDecoder : Decode.Decoder Identifier 17 | identifierDecoder = 18 | Decode.map MkIdentifier 19 | Decode.int 20 | 21 | 22 | type Status 23 | = MkStatusPlanned 24 | | MkStatusCancelled 25 | 26 | 27 | statusToString : Status -> String 28 | statusToString status = 29 | case status of 30 | MkStatusPlanned -> 31 | "planned" 32 | 33 | MkStatusCancelled -> 34 | "cancelled" 35 | 36 | 37 | statusEncode : Status -> Encode.Value 38 | statusEncode status = 39 | case status of 40 | MkStatusPlanned -> 41 | Encode.string "planned" 42 | 43 | MkStatusCancelled -> 44 | Encode.string "cancelled" 45 | 46 | 47 | statusDecoder : Decode.Decoder Status 48 | statusDecoder = 49 | Decode.andThen 50 | (\string -> 51 | case string of 52 | "planned" -> 53 | Decode.succeed MkStatusPlanned 54 | 55 | "cancelled" -> 56 | Decode.succeed MkStatusCancelled 57 | 58 | _ -> 59 | Decode.fail <| "Trying to decode reservation status, but this option is not supported: " ++ string 60 | ) 61 | Decode.string 62 | -------------------------------------------------------------------------------- /server/source/library/Data/Time/Zones/All/OrphanInstances.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | 3 | module Data.Time.Zones.All.OrphanInstances () where 4 | 5 | import Control.Lens 6 | import Data.Aeson qualified as A 7 | import Data.Aeson.Types qualified as A 8 | import Data.OpenApi 9 | import Data.Proxy 10 | import Data.Text qualified as T 11 | import Data.Text.Encoding qualified as T 12 | import Data.Time.Zones.All 13 | import Database.Selda qualified as Selda 14 | 15 | instance A.FromJSON TZLabel where 16 | parseJSON json = do 17 | text <- A.prependFailure "parsing time zone database identifier failed, " $ A.parseJSON @T.Text json 18 | case fromTZName $ T.encodeUtf8 text of 19 | Nothing -> fail "parsing time zone database identifier failed" 20 | Just timezoneLabel -> pure timezoneLabel 21 | 22 | instance A.ToJSON TZLabel where 23 | toJSON = A.String . T.decodeUtf8 . toTZName 24 | 25 | instance ToParamSchema TZLabel where 26 | toParamSchema Proxy = 27 | mempty 28 | & type_ ?~ OpenApiString 29 | & description ?~ "IANA time zone database identifier" 30 | 31 | instance ToSchema TZLabel where 32 | declareNamedSchema proxy = pure $ NamedSchema (Just "TZLabel") $ toParamSchema proxy 33 | 34 | instance Selda.SqlEnum TZLabel where 35 | toText = T.decodeUtf8 . toTZName 36 | fromText text = 37 | case fromTZName $ T.encodeUtf8 text of 38 | Nothing -> error $ "Failed to read time zone database identifier from an SQL value: " ++ show text 39 | Just timezoneLabel -> timezoneLabel 40 | 41 | deriving anyclass instance Selda.SqlType TZLabel 42 | -------------------------------------------------------------------------------- /server/source/library/Mensam/API/Aeson.hs: -------------------------------------------------------------------------------- 1 | module Mensam.API.Aeson where 2 | 3 | import Data.Aeson qualified as A 4 | import Data.Kind 5 | import Deriving.Aeson qualified as A 6 | import GHC.Generics 7 | import GHC.TypeLits 8 | 9 | type JSONSettings :: Symbol -> Symbol -> [Type] 10 | type JSONSettings constructorPrefix fieldPrefix = 11 | '[ A.ConstructorTagModifier 12 | '[ A.StripPrefix constructorPrefix 13 | , A.CamelToKebab 14 | ] 15 | , A.SumTaggedObject "tag" "value" 16 | , A.FieldLabelModifier 17 | '[ A.StripPrefix fieldPrefix 18 | , A.CamelToKebab 19 | ] 20 | , A.RejectUnknownFields 21 | ] 22 | 23 | type NameOrIdentifier :: Type -> Type -> Type 24 | type role NameOrIdentifier _ _ 25 | data NameOrIdentifier name identifier 26 | = Name name 27 | | Identifier identifier 28 | deriving stock (Eq, Generic, Ord, Read, Show) 29 | deriving (A.FromJSON, A.ToJSON) via A.CustomJSON (JSONSettings "" "") (NameOrIdentifier name identifier) 30 | 31 | type ErrorParseBodyJson :: Type 32 | newtype ErrorParseBodyJson = MkErrorParseBodyJson 33 | { errorParseBodyJsonError :: String 34 | } 35 | deriving stock (Eq, Generic, Ord, Read, Show) 36 | deriving (A.FromJSON, A.ToJSON) via A.CustomJSON (JSONSettings "Mk" "errorParseBodyJson") ErrorParseBodyJson 37 | 38 | type ErrorParseBodyJpeg :: Type 39 | newtype ErrorParseBodyJpeg = MkErrorParseBodyJpeg 40 | { errorParseBodyJpegError :: String 41 | } 42 | deriving stock (Eq, Generic, Ord, Read, Show) 43 | deriving (A.FromJSON, A.ToJSON) via A.CustomJSON (JSONSettings "Mk" "errorParseBodyJpeg") ErrorParseBodyJpeg 44 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Client/Application/HttpClient.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | 3 | module Mensam.Client.Application.HttpClient where 4 | 5 | import Mensam.Client.Application.HttpClient.Class 6 | 7 | import Control.Monad.Logger.CallStack 8 | import Control.Monad.Trans 9 | import Control.Monad.Trans.Compose 10 | import Control.Monad.Trans.Control 11 | import Control.Monad.Trans.Control.Identity 12 | import Control.Monad.Trans.Reader 13 | import Data.Kind 14 | import Network.HTTP.Client qualified as Network 15 | import Network.HTTP.Client.TLS qualified as Network 16 | 17 | type HttpClientT :: (Type -> Type) -> Type -> Type 18 | type role HttpClientT _ _ 19 | newtype HttpClientT m a = MkHttpClientT {unHttpClientT :: ReaderT Network.Manager m a} 20 | deriving newtype (Applicative, Functor, Monad) 21 | deriving newtype (MonadTrans, MonadTransControl, MonadTransControlIdentity) 22 | 23 | instance Monad m => MonadHttpClient (HttpClientT m) where 24 | httpManager = MkHttpClientT ask 25 | 26 | deriving via 27 | HttpClientT ((t2 :: (Type -> Type) -> Type -> Type) m) 28 | instance 29 | Monad (t2 m) => MonadHttpClient (ComposeT HttpClientT t2 m) 30 | 31 | runHttpClientT :: HttpClientT m a -> Network.Manager -> m a 32 | runHttpClientT = runReaderT . unHttpClientT 33 | 34 | runAppHttpClientT :: 35 | (MonadIO m, MonadLogger m) => 36 | HttpClientT m a -> 37 | m a 38 | runAppHttpClientT tma = do 39 | logInfo "Creating new HTTP manager." 40 | manager <- liftIO $ Network.newManager Network.tlsManagerSettings 41 | logInfo "Created new HTTP manager." 42 | runHttpClientT tma manager 43 | -------------------------------------------------------------------------------- /frontend/elm.json: -------------------------------------------------------------------------------- 1 | { 2 | "type": "application", 3 | "source-directories": [ 4 | "source" 5 | ], 6 | "elm-version": "0.19.1", 7 | "dependencies": { 8 | "direct": { 9 | "bellroy/elm-email": "1.0.1", 10 | "chelovek0v/bbase64": "1.0.1", 11 | "elm/browser": "1.0.2", 12 | "elm/bytes": "1.0.8", 13 | "elm/core": "1.0.5", 14 | "elm/file": "1.0.5", 15 | "elm/html": "1.0.0", 16 | "elm/http": "2.0.0", 17 | "elm/json": "1.1.3", 18 | "elm/svg": "1.0.1", 19 | "elm/time": "1.0.0", 20 | "elm/url": "1.0.0", 21 | "justgook/elm-image": "5.0.0", 22 | "justinmimbs/time-extra": "1.2.0", 23 | "justinmimbs/timezone-data": "10.1.1", 24 | "mdgriffith/elm-ui": "1.1.8", 25 | "mpizenberg/elm-pointer-events": "5.0.0", 26 | "pablohirafuji/elm-qrcode": "4.0.2", 27 | "rtfeldman/elm-iso8601-date-strings": "1.1.4", 28 | "truqu/elm-base64": "2.0.4", 29 | "zwilias/elm-rosetree": "1.5.0" 30 | }, 31 | "indirect": { 32 | "avh4/elm-color": "1.0.0", 33 | "danfishgold/base64-bytes": "1.1.0", 34 | "elm/parser": "1.1.0", 35 | "elm/regex": "1.0.0", 36 | "elm/virtual-dom": "1.0.4", 37 | "elm-community/list-extra": "8.7.0", 38 | "folkertdev/elm-flate": "2.0.5", 39 | "justinmimbs/date": "4.1.0" 40 | } 41 | }, 42 | "test-dependencies": { 43 | "direct": {}, 44 | "indirect": {} 45 | } 46 | } 47 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Server/Application/Configured.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | 3 | module Mensam.Server.Application.Configured where 4 | 5 | import Mensam.Server.Application.Configured.Acquisition 6 | import Mensam.Server.Application.Configured.Class 7 | import Mensam.Server.Application.Environment.Class 8 | import Mensam.Server.Configuration 9 | 10 | import Control.DeepSeq 11 | import Control.Monad.Logger.CallStack 12 | import Control.Monad.Trans 13 | import Control.Monad.Trans.Compose 14 | import Control.Monad.Trans.Control 15 | import Control.Monad.Trans.Control.Identity 16 | import Control.Monad.Trans.Reader 17 | import Data.Kind 18 | 19 | type ConfiguredT :: (Type -> Type) -> Type -> Type 20 | type role ConfiguredT _ _ 21 | newtype ConfiguredT m a = ConfiguredT {unConfiguredT :: ReaderT Configuration m a} 22 | deriving newtype (Applicative, Functor, Monad) 23 | deriving newtype (MonadTrans, MonadTransControl, MonadTransControlIdentity) 24 | 25 | instance Monad m => MonadConfigured (ConfiguredT m) where 26 | configuration = ConfiguredT ask 27 | 28 | deriving via 29 | ConfiguredT ((t2 :: (Type -> Type) -> Type -> Type) m) 30 | instance 31 | Monad (t2 m) => MonadConfigured (ComposeT ConfiguredT t2 m) 32 | 33 | runConfiguredT :: ConfiguredT m a -> Configuration -> m a 34 | runConfiguredT = runReaderT . unConfiguredT 35 | 36 | runAppConfiguredT :: 37 | (MonadEnvironment m, MonadIO m, MonadLogger m) => 38 | ConfiguredT m a -> 39 | m a 40 | runAppConfiguredT tma = do 41 | maybeConfig <- acquireConfig 42 | case maybeConfig of 43 | Nothing -> error "No configuration." 44 | Just config -> runConfiguredT tma $ force config 45 | -------------------------------------------------------------------------------- /server/source/library/Mensam/API/Pretty.hs: -------------------------------------------------------------------------------- 1 | module Mensam.API.Pretty where 2 | 3 | import Data.Kind 4 | import Data.Text qualified as Text 5 | import Data.Text.Encoding qualified as Text.Encoding 6 | import Data.Time.Format.ISO8601 qualified as Time 7 | import Data.Time.LocalTime qualified as Time 8 | import Data.Time.Zones.All qualified as Time 9 | import Text.Blaze.Html5 qualified as Html5 10 | 11 | type ToPrettyText :: Type -> Constraint 12 | class ToPrettyText a where 13 | toPrettyText :: a -> Text.Text 14 | 15 | type ToPrettyHtml5 :: Type -> Constraint 16 | class ToPrettyHtml5 a where 17 | toPrettyHtml5 :: a -> Html5.Html 18 | 19 | type PrettyTextViaShow :: Type -> Type 20 | type role PrettyTextViaShow _ 21 | newtype PrettyTextViaShow a = MkPrettyTextViaShow {unPrettyTextViaShow :: a} 22 | 23 | instance Show a => ToPrettyText (PrettyTextViaShow a) where 24 | toPrettyText = Text.pack . show . unPrettyTextViaShow 25 | 26 | type PrettyHtml5ViaPrettyText :: Type -> Type 27 | type role PrettyHtml5ViaPrettyText _ 28 | newtype PrettyHtml5ViaPrettyText a = MkPrettyHtml5ViaPrettyText {unPrettyHtml5ViaPrettyText :: a} 29 | 30 | instance ToPrettyText a => ToPrettyHtml5 (PrettyHtml5ViaPrettyText a) where 31 | toPrettyHtml5 = Html5.toHtml . toPrettyText . unPrettyHtml5ViaPrettyText 32 | 33 | instance ToPrettyText Time.TZLabel where 34 | toPrettyText = Text.Encoding.decodeUtf8 . Time.toTZName 35 | 36 | deriving via PrettyHtml5ViaPrettyText Time.TZLabel instance ToPrettyHtml5 Time.TZLabel 37 | 38 | instance ToPrettyText Time.LocalTime where 39 | toPrettyText = Text.pack . Time.iso8601Show 40 | 41 | deriving via PrettyHtml5ViaPrettyText Time.LocalTime instance ToPrettyHtml5 Time.LocalTime 42 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Server/Server/Handler/Profiler.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | 3 | module Mensam.Server.Server.Handler.Profiler where 4 | 5 | import Mensam.Server.Server.Handler.Profiler.Class 6 | 7 | import Control.Monad.IO.Class 8 | import Control.Monad.Logger.CallStack 9 | import Control.Monad.Trans.Class 10 | import Control.Monad.Trans.Compose 11 | import Control.Monad.Trans.Control 12 | import Control.Monad.Trans.Control.Identity 13 | import Control.Monad.Trans.Reader 14 | import Data.Kind 15 | import Data.Text qualified as T 16 | import Data.Time.Clock.POSIX qualified as Clock 17 | 18 | type ProfilerT :: (Type -> Type) -> Type -> Type 19 | type role ProfilerT _ _ 20 | newtype ProfilerT m a = ProfilerT {unProfilerT :: ReaderT Clock.POSIXTime m a} 21 | deriving newtype (Applicative, Functor, Monad) 22 | deriving newtype (MonadTrans, MonadTransControl, MonadTransControlIdentity) 23 | 24 | instance (MonadIO m, MonadLogger m) => MonadProfiler (ProfilerT m) where 25 | profilerDuration = do 26 | referenceTime <- ProfilerT ask 27 | currentTime <- lift $ liftIO Clock.getPOSIXTime 28 | let duration = currentTime - referenceTime 29 | lift $ logOther logLevel $ T.pack $ show duration 30 | 31 | deriving via 32 | ProfilerT ((t2 :: (Type -> Type) -> Type -> Type) m) 33 | instance 34 | (MonadIO (t2 m), MonadLogger (t2 m)) => MonadProfiler (ComposeT ProfilerT t2 m) 35 | 36 | runProfilerT :: (MonadIO m, MonadLogger m) => ProfilerT m a -> m a 37 | runProfilerT tma = do 38 | referenceTime <- liftIO Clock.getPOSIXTime 39 | runReaderT (unProfilerT (tma <* profilerDuration)) referenceTime 40 | 41 | logLevel :: LogLevel 42 | logLevel = LevelOther "Profiler" 43 | -------------------------------------------------------------------------------- /static/source/favicon.xpm: -------------------------------------------------------------------------------- 1 | /* XPM */ 2 | static char *XPM_icon[] = { 3 | "32 32 17 1 16 16", 4 | " c None", 5 | "s c #282a2e", 6 | "S c #373b41", 7 | "r c #a54242", 8 | "R c #cc6666", 9 | "g c #8c9440", 10 | "G c #b5bd68", 11 | "y c #de935f", 12 | "Y c #f0c674", 13 | "b c #5f819d", 14 | "B c #81a2be", 15 | "m c #85678f", 16 | "M c #b294bb", 17 | "c c #5e8d87", 18 | "C c #8abeb7", 19 | "w c #707880", 20 | "W c #c5c8c6", 21 | " ", 22 | " ", 23 | " ", 24 | " ", 25 | " ", 26 | " YYYYYY YYYYYY yyyyyy ", 27 | " YYYYYY YYYYYY yyyyyy ", 28 | " YY YY YY YY yy yy yy ", 29 | " YY YY YY YY yy yy yy ", 30 | " YYYYYY YYYYYY yyyyyy ", 31 | " YYYYYY YYYYYY yyyyyy ", 32 | " ", 33 | " ", 34 | " yyyyyy ", 35 | " yyyyyy ", 36 | " YY YY yy yy yy ", 37 | " YY YY yy yy yy ", 38 | " yyyyyy ", 39 | " yyyyyy ", 40 | " ", 41 | " ", 42 | " YYYYYY yyyyyy ", 43 | " YYYYYY yyyyyy ", 44 | " YY YY YY yy yy yy ", 45 | " YY YY YY yy yy yy ", 46 | " YYYYYY yyyyyy ", 47 | " YYYYYY yyyyyy ", 48 | " ", 49 | " ", 50 | " ", 51 | " ", 52 | " ", 53 | }; 54 | -------------------------------------------------------------------------------- /frontend/source/Mensam/Storage.elm: -------------------------------------------------------------------------------- 1 | port module Mensam.Storage exposing 2 | ( Storage(..) 3 | , StorageRaw 4 | , decoder 5 | , set 6 | , unset 7 | ) 8 | 9 | import Iso8601 10 | import Json.Decode as Decode 11 | import Json.Encode as Encode 12 | import Mensam.Auth.Bearer 13 | import Mensam.User 14 | import Time 15 | 16 | 17 | type Storage 18 | = MkStorage 19 | { jwt : Mensam.Auth.Bearer.Jwt 20 | , expiration : Maybe Time.Posix 21 | , id : Mensam.User.Identifier 22 | } 23 | 24 | 25 | port setStorageJson : Encode.Value -> Cmd msg 26 | 27 | 28 | set : Storage -> Cmd msg 29 | set = 30 | encode >> setStorageJson 31 | 32 | 33 | unset : Cmd msg 34 | unset = 35 | setStorageJson Encode.null 36 | 37 | 38 | type alias StorageRaw = 39 | Encode.Value 40 | 41 | 42 | decoder : Decode.Decoder (Maybe Storage) 43 | decoder = 44 | Decode.nullable <| 45 | Decode.map3 (\jwt expiration id -> MkStorage { jwt = jwt, expiration = expiration, id = id }) 46 | (Decode.field "jwt" Mensam.Auth.Bearer.decoder) 47 | (Decode.field "expiration" <| Decode.nullable Iso8601.decoder) 48 | (Decode.field "id" <| Mensam.User.identifierDecoder) 49 | 50 | 51 | encode : Storage -> StorageRaw 52 | encode (MkStorage storage) = 53 | Encode.object 54 | [ ( "jwt", Mensam.Auth.Bearer.encode storage.jwt ) 55 | , ( "expiration" 56 | , case storage.expiration of 57 | Nothing -> 58 | Encode.null 59 | 60 | Just expiration -> 61 | Iso8601.encode expiration 62 | ) 63 | , ( "id", Mensam.User.identifierEncode storage.id ) 64 | ] 65 | -------------------------------------------------------------------------------- /static/source/default-profile-picture.xpm: -------------------------------------------------------------------------------- 1 | /* XPM */ 2 | static char *XPM_icon[] = { 3 | "32 32 17 1 16 16", 4 | " c None", 5 | "s c #282a2e", 6 | "S c #373b41", 7 | "r c #a54242", 8 | "R c #cc6666", 9 | "g c #8c9440", 10 | "G c #b5bd68", 11 | "y c #de935f", 12 | "Y c #f0c674", 13 | "b c #5f819d", 14 | "B c #81a2be", 15 | "m c #85678f", 16 | "M c #b294bb", 17 | "c c #5e8d87", 18 | "C c #8abeb7", 19 | "w c #707880", 20 | "W c #c5c8c6", 21 | " ", 22 | " ", 23 | " ", 24 | " ", 25 | " ", 26 | " ", 27 | " YYYYYYYY ", 28 | " YYYYYYYY ", 29 | " YYYYYYYY ", 30 | " YYYYYYYY ", 31 | " YYYYYYYY ", 32 | " YYYYYYYY ", 33 | " YYYYYYYY ", 34 | " YYYYYYYY ", 35 | " YYYYYYYY ", 36 | " ", 37 | " ", 38 | " ", 39 | " ", 40 | " yyyyyyyyyyyyyyyyyyyyyyyyyyyy ", 41 | " yyyyyyyyyyyyyyyyyyyyyyyyyyyy ", 42 | " yyyyyyyyyyyyyyyyyyyyyyyyyyyy ", 43 | " yyyyyyyyyyyyyyyyyyyyyyyyyyyy ", 44 | " yyyyyyyyyyyyyyyyyyyyyyyyyyyy ", 45 | " yyyyyyyyyyyyyyyyyyyyyyyyyyyy ", 46 | " yyyyyyyyyyyyyyyyyyyyyyyyyyyy ", 47 | " yyyy yyyyyyyyyyyyyyyyyy yyyy ", 48 | " yyyy yyyyyyyyyyyyyyyyyy yyyy ", 49 | " yyyy yyyyyyyyyyyyyyyyyy yyyy ", 50 | " yyyy yyyyyyyyyyyyyyyyyy yyyy ", 51 | " yyyy yyyyyyyyyyyyyyyyyy yyyy ", 52 | " yyyy yyyyyyyyyyyyyyyyyy yyyy ", 53 | }; 54 | -------------------------------------------------------------------------------- /static/source/default-space-picture.xpm: -------------------------------------------------------------------------------- 1 | /* XPM */ 2 | static char *XPM_icon[] = { 3 | "32 32 17 1 16 16", 4 | " c None", 5 | "s c #282a2e", 6 | "S c #373b41", 7 | "r c #a54242", 8 | "R c #cc6666", 9 | "g c #8c9440", 10 | "G c #b5bd68", 11 | "y c #de935f", 12 | "Y c #f0c674", 13 | "b c #5f819d", 14 | "B c #81a2be", 15 | "m c #85678f", 16 | "M c #b294bb", 17 | "c c #5e8d87", 18 | "C c #8abeb7", 19 | "w c #707880", 20 | "W c #c5c8c6", 21 | " ", 22 | " ", 23 | " ", 24 | " ", 25 | " ", 26 | " CCCCCC CCCCCC cccccc ", 27 | " CCCCCC CCCCCC cccccc ", 28 | " CC CC CC CC cc cc cc ", 29 | " CC CC CC CC cc cc cc ", 30 | " CCCCCC CCCCCC cccccc ", 31 | " CCCCCC CCCCCC cccccc ", 32 | " ", 33 | " ", 34 | " cccccc ", 35 | " cccccc ", 36 | " CC CC cc cc cc ", 37 | " CC CC cc cc cc ", 38 | " cccccc ", 39 | " cccccc ", 40 | " ", 41 | " ", 42 | " CCCCCC cccccc ", 43 | " CCCCCC cccccc ", 44 | " CC CC CC cc cc cc ", 45 | " CC CC CC cc cc cc ", 46 | " CCCCCC cccccc ", 47 | " CCCCCC cccccc ", 48 | " ", 49 | " ", 50 | " ", 51 | " ", 52 | " ", 53 | }; 54 | -------------------------------------------------------------------------------- /static/Makefile: -------------------------------------------------------------------------------- 1 | SOURCE = source 2 | BUILD = build 3 | ICONS = $(wildcard $(SOURCE)/icons/*) 4 | FAVICON_RESOLUTIONS = 32x32 192x192 512x512 5 | 6 | BUILT_FAVICONS = $(patsubst %, $(BUILD)/favicon-%.png, $(FAVICON_RESOLUTIONS)) 7 | BUILT_ICONS = $(patsubst $(SOURCE)%, $(BUILD)%, $(ICONS)) 8 | BUILT_FILES = 9 | 10 | .PHONY: all 11 | all: $(BUILD)/favicon.ico $(BUILD)/favicon.png $(BUILT_FAVICONS) $(BUILD)/fonts.css $(BUILD)/redoc.css $(BUILD)/default-profile-picture.jpeg $(BUILD)/default-space-picture.jpeg $(BUILT_ICONS) $(BUILT_FILES) 12 | 13 | $(BUILD)/favicon.ico: $(BUILD)/favicon.png $(BUILD) 14 | cp "$<" "$@" 15 | 16 | $(BUILD)/favicon.png: $(BUILD)/favicon-32x32.png $(BUILD) 17 | cp "$<" "$@" 18 | 19 | $(BUILT_FAVICONS): $(BUILD)/favicon-%.png: $(SOURCE)/favicon.xpm $(BUILD) 20 | convert "$<" -scale "$*" "$@" 21 | 22 | $(BUILD)/fonts.css: $(SOURCE)/fonts.css $(BUILD) 23 | cp "$<" "$@" 24 | 25 | $(BUILD)/redoc.css: $(SOURCE)/redoc.css $(BUILD) 26 | cp "$<" "$@" 27 | 28 | $(BUILD)/default-profile-picture.jpeg: $(SOURCE)/default-profile-picture.xpm $(BUILD) 29 | convert "$<" -adaptive-resize "640x640" "tmp.xpm" 30 | convert "tmp.xpm" "$@" 31 | rm "tmp.xpm" 32 | 33 | $(BUILD)/default-space-picture.jpeg: $(SOURCE)/default-space-picture.xpm $(BUILD) 34 | convert "$<" -adaptive-resize "640x640" "tmp.xpm" 35 | convert "tmp.xpm" "$@" 36 | rm "tmp.xpm" 37 | 38 | $(BUILT_ICONS): $(BUILD)/icons/%: $(SOURCE)/icons/% $(BUILD)/icons 39 | convert "$<" -resize "128x128" "$@" 40 | 41 | $(BUILT_FILES): $(BUILD)/%: $(SOURCE)/% $(BUILD) 42 | cp "$<" "$@" 43 | 44 | $(BUILD)/icons: 45 | mkdir --parents "$@" 46 | 47 | $(BUILD): 48 | mkdir --parents "$@" 49 | 50 | .PHONY: clean 51 | clean: 52 | rm --force --recursive $(BUILD) 53 | -------------------------------------------------------------------------------- /.github/workflows/default.yml: -------------------------------------------------------------------------------- 1 | jobs: 2 | check-matrix: 3 | name: "Matrix to Check Flake" 4 | runs-on: ubuntu-latest 5 | outputs: 6 | matrix: ${{ steps.set-matrix.outputs.matrix }} 7 | steps: 8 | - name: "Set up GitHub Actions" 9 | uses: actions/checkout@v4.1.7 10 | - name: "Set up Nix" 11 | uses: cachix/install-nix-action@v27 12 | - name: "Set up Cachix" 13 | uses: cachix/cachix-action@v15 14 | with: 15 | authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}' 16 | name: jumper149-mensam 17 | - id: set-matrix 18 | name: "Generate Nix Matrix" 19 | run: | 20 | set -Eeu 21 | matrix="$(nix eval --json '.#githubActions.matrix')" 22 | echo "matrix=$matrix" >> "$GITHUB_OUTPUT" 23 | check: 24 | name: "Check Flake" 25 | needs: check-matrix 26 | runs-on: ubuntu-latest 27 | steps: 28 | - name: "Set up GitHub Actions" 29 | uses: actions/checkout@v4.1.7 30 | - name: "Set up Nix" 31 | uses: cachix/install-nix-action@v27 32 | with: 33 | extra_nix_config: sandbox = relaxed 34 | - name: "Set up Cachix" 35 | uses: cachix/cachix-action@v15 36 | with: 37 | authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}' 38 | name: jumper149-mensam 39 | - name: "Check" 40 | run: nix build ".#${{ matrix.attr }}" --print-build-logs 41 | if: ${{ matrix.sandbox }} 42 | - name: "Check (without sandbox)" 43 | run: nix build ".#${{ matrix.attr }}" --print-build-logs --option sandbox false 44 | if: ${{ ! matrix.sandbox }} 45 | strategy: 46 | fail-fast: false 47 | matrix: ${{fromJSON(needs.check-matrix.outputs.matrix)}} 48 | name: "Default" 49 | on: 50 | push: 51 | -------------------------------------------------------------------------------- /frontend/source/Mensam/Svg/Color.elm: -------------------------------------------------------------------------------- 1 | module Mensam.Svg.Color exposing (..) 2 | 3 | import Mensam.Color 4 | 5 | 6 | type alias Color = 7 | String 8 | 9 | 10 | dark : AnsiIso6429 11 | dark = 12 | { black = toSvgColor Mensam.Color.dark.black 13 | , red = toSvgColor Mensam.Color.dark.red 14 | , green = toSvgColor Mensam.Color.dark.green 15 | , yellow = toSvgColor Mensam.Color.dark.yellow 16 | , blue = toSvgColor Mensam.Color.dark.blue 17 | , magenta = toSvgColor Mensam.Color.dark.magenta 18 | , cyan = toSvgColor Mensam.Color.dark.cyan 19 | , white = toSvgColor Mensam.Color.dark.white 20 | } 21 | 22 | 23 | bright : AnsiIso6429 24 | bright = 25 | { black = toSvgColor Mensam.Color.bright.black 26 | , red = toSvgColor Mensam.Color.bright.red 27 | , green = toSvgColor Mensam.Color.bright.green 28 | , yellow = toSvgColor Mensam.Color.bright.yellow 29 | , blue = toSvgColor Mensam.Color.bright.blue 30 | , magenta = toSvgColor Mensam.Color.bright.magenta 31 | , cyan = toSvgColor Mensam.Color.bright.cyan 32 | , white = toSvgColor Mensam.Color.bright.white 33 | } 34 | 35 | 36 | type alias AnsiIso6429 = 37 | { black : Color 38 | , red : Color 39 | , green : Color 40 | , yellow : Color 41 | , blue : Color 42 | , magenta : Color 43 | , cyan : Color 44 | , white : Color 45 | } 46 | 47 | 48 | transparent : Color 49 | transparent = 50 | "none" 51 | 52 | 53 | toSvgColor : Mensam.Color.Color -> Color 54 | toSvgColor color = 55 | String.concat 56 | [ "rgb(" 57 | , String.fromInt color.r 58 | , "," 59 | , String.fromInt color.g 60 | , "," 61 | , String.fromInt color.b 62 | , ")" 63 | ] 64 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Server/Configuration/BaseUrl.hs: -------------------------------------------------------------------------------- 1 | module Mensam.Server.Configuration.BaseUrl where 2 | 3 | import Mensam.API.Aeson 4 | 5 | import Control.DeepSeq 6 | import Data.Aeson qualified as A 7 | import Data.Kind 8 | import Data.Text qualified as T 9 | import Data.Word 10 | import Deriving.Aeson qualified as A 11 | import GHC.Generics 12 | 13 | displayBaseUrl :: BaseUrl -> T.Text 14 | displayBaseUrl baseUrl@BaseUrl {baseUrlScheme, baseUrlAuthority} = 15 | let absolutePath = displayBaseUrlPath baseUrl <> "/" 16 | in baseUrlScheme <> ":" <> maybe "" displayBaseUrlAuthority baseUrlAuthority <> absolutePath 17 | 18 | displayBaseUrlPath :: BaseUrl -> T.Text 19 | displayBaseUrlPath BaseUrl {baseUrlPath} = T.concat $ map ("/" <>) baseUrlPath 20 | 21 | type BaseUrl :: Type 22 | data BaseUrl = BaseUrl 23 | { baseUrlScheme :: T.Text 24 | , baseUrlAuthority :: Maybe BaseUrlAuthority 25 | , baseUrlPath :: [T.Text] 26 | } 27 | deriving stock (Eq, Generic, Ord, Read, Show) 28 | deriving anyclass (NFData) 29 | deriving 30 | (A.FromJSON, A.ToJSON) 31 | via A.CustomJSON (JSONSettings "" "baseUrl") BaseUrl 32 | 33 | displayBaseUrlAuthority :: BaseUrlAuthority -> T.Text 34 | displayBaseUrlAuthority BaseUrlAuthority {baseUrlAuthorityHost, baseUrlAuthorityPort} = 35 | "//" <> baseUrlAuthorityHost <> maybe "" ((":" <>) . T.pack . show) baseUrlAuthorityPort 36 | 37 | type BaseUrlAuthority :: Type 38 | data BaseUrlAuthority = BaseUrlAuthority 39 | { baseUrlAuthorityHost :: T.Text 40 | , baseUrlAuthorityPort :: Maybe Word16 41 | } 42 | deriving stock (Eq, Generic, Ord, Read, Show) 43 | deriving anyclass (NFData) 44 | deriving 45 | (A.FromJSON, A.ToJSON) 46 | via A.CustomJSON (JSONSettings "BaseUrl" "baseUrlAuthority") BaseUrlAuthority 47 | -------------------------------------------------------------------------------- /server/README.adoc: -------------------------------------------------------------------------------- 1 | = Server 2 | 3 | The server executable is written in Haskell using wai and servant for the HTTP interface. 4 | OpenAPI documentation is generated automatically. 5 | This application uses mtl-style effects. 6 | An SQLite database is used for persistent storage. 7 | 8 | == Configuration 9 | 10 | Environment variables and a configuration file change the runtime behaviour. 11 | 12 | === Environment 13 | 14 | Environment variables are checked early during the initialization. 15 | The options are set link:./source/library/Mensam/Server/Environment.hs[here]. 16 | 17 | === Configuration file 18 | 19 | The configuration file is written in JSON and is specified in link:./source/library/Mensam/Server/Configuration.hs[here]. 20 | 21 | == Database 22 | 23 | The filepath for the SQLite database can be configured. 24 | The database will be automatically initialized during the first startup. 25 | Database migrations will be automatically applied when you run a new version of the server application. 26 | 27 | WARNING: Downgrades are not supported. 28 | 29 | == Development 30 | 31 | [source,bash] 32 | ---- 33 | # Generate static files and configuration. 34 | nix build ..#subflakes.final.packages.x86_64-linux.config 35 | 36 | # Use cabal to develop the application. 37 | MENSAM_CONFIG_FILE=result cabal run mensam-server 38 | ---- 39 | 40 | === Formatting 41 | 42 | Use `fourmolu` to format Haskell. 43 | 44 | [source,bash] 45 | ---- 46 | # Format Haskell. 47 | fourmolu --mode inplace ./source 48 | ---- 49 | 50 | === `graphmod` 51 | 52 | The module dependency graph can be visualised using `graphmod`. 53 | 54 | [source,bash] 55 | ---- 56 | # Run graphmod. 57 | nix build ..#subflakes.server.checks.x86_64-linux.graphmod 58 | 59 | # View graph with xdot or your PDF viewer. 60 | xdot result/graphmod.dot 61 | zathura result/graphmod.pdf 62 | ---- 63 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Client/Application/MensamClient.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | 3 | module Mensam.Client.Application.MensamClient where 4 | 5 | import Mensam.Client.Application.HttpClient.Class 6 | import Mensam.Client.Application.MensamClient.Class 7 | import Mensam.Client.Application.Options.Class 8 | 9 | import Control.Monad.Logger.CallStack 10 | import Control.Monad.Trans 11 | import Control.Monad.Trans.Compose 12 | import Control.Monad.Trans.Control 13 | import Control.Monad.Trans.Control.Identity 14 | import Control.Monad.Trans.Reader 15 | import Data.Kind 16 | import Servant.Client 17 | 18 | type MensamClientT :: (Type -> Type) -> Type -> Type 19 | type role MensamClientT _ _ 20 | newtype MensamClientT m a = MkMensamClientT {unMensamClientT :: ReaderT ClientEnv m a} 21 | deriving newtype (Applicative, Functor, Monad) 22 | deriving newtype (MonadTrans, MonadTransControl, MonadTransControlIdentity) 23 | 24 | instance MonadIO m => MonadMensamClient (MensamClientT m) where 25 | mensamCall call = MkMensamClientT $ do 26 | clientEnv <- ask 27 | liftIO $ runClientM call clientEnv 28 | 29 | deriving via 30 | MensamClientT ((t2 :: (Type -> Type) -> Type -> Type) m) 31 | instance 32 | MonadIO (t2 m) => MonadMensamClient (ComposeT MensamClientT t2 m) 33 | 34 | runMensamClientT :: MensamClientT m a -> ClientEnv -> m a 35 | runMensamClientT = runReaderT . unMensamClientT 36 | 37 | runAppMensamClientT :: 38 | (MonadIO m, MonadHttpClient m, MonadLogger m, MonadOptions m) => 39 | MensamClientT m a -> 40 | m a 41 | runAppMensamClientT tma = do 42 | logInfo "Creating HTTP client environment." 43 | manager <- httpManager 44 | baseUrl <- optionBaseUrl <$> options 45 | let clientEnv = mkClientEnv manager baseUrl 46 | logInfo "Created HTTP client environment." 47 | runMensamClientT tma clientEnv 48 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Server/Configuration.hs: -------------------------------------------------------------------------------- 1 | module Mensam.Server.Configuration where 2 | 3 | import Mensam.API.Aeson 4 | import Mensam.Server.Configuration.BaseUrl 5 | import Mensam.Server.Configuration.Email 6 | import Mensam.Server.Configuration.SQLite 7 | 8 | import Control.DeepSeq 9 | import Data.Aeson qualified as A 10 | import Data.Kind 11 | import Data.List.NonEmpty qualified as NE 12 | import Data.Text qualified as T 13 | import Data.Word 14 | import Deriving.Aeson qualified as A 15 | import GHC.Generics 16 | 17 | type Configuration :: Type 18 | data Configuration = Configuration 19 | { configRevision :: Maybe T.Text 20 | , configSqlite :: SQLiteConfig 21 | , configEmailConfig :: Maybe EmailConfig 22 | , configDirectoryStatic :: FilePath 23 | , configPort :: Word16 24 | , configBaseUrl :: BaseUrl 25 | , configFonts :: [FontConfig] 26 | , configAuth :: AuthConfig 27 | , configDirectoryHaddock :: Maybe FilePath 28 | , configSourceUrl :: Maybe T.Text 29 | } 30 | deriving stock (Eq, Generic, Ord, Read, Show) 31 | deriving anyclass (NFData) 32 | deriving 33 | (A.FromJSON, A.ToJSON) 34 | via A.CustomJSON (JSONSettings "" "config") Configuration 35 | 36 | type AuthConfig :: Type 37 | newtype AuthConfig = AuthConfig 38 | { authTimeoutSeconds :: Maybe Integer 39 | } 40 | deriving stock (Eq, Generic, Ord, Read, Show) 41 | deriving anyclass (NFData) 42 | deriving 43 | (A.FromJSON, A.ToJSON) 44 | via A.CustomJSON (JSONSettings "" "auth") AuthConfig 45 | 46 | type FontConfig :: Type 47 | data FontConfig = FontConfig 48 | { fontPathPieces :: NE.NonEmpty T.Text 49 | , fontPreload :: Bool 50 | } 51 | deriving stock (Eq, Generic, Ord, Read, Show) 52 | deriving anyclass (NFData) 53 | deriving 54 | (A.FromJSON, A.ToJSON) 55 | via A.CustomJSON (JSONSettings "" "font") FontConfig 56 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Server/Jpeg.hs: -------------------------------------------------------------------------------- 1 | module Mensam.Server.Jpeg where 2 | 3 | import Codec.Picture 4 | import Codec.Picture.Extra 5 | import Codec.Picture.Types 6 | import Control.Monad.Trans.State 7 | import Data.ByteString.Lazy qualified as BL 8 | import Data.Kind 9 | import GHC.Generics 10 | import Servant.API.ImageJpeg 11 | 12 | type ByteStringJpeg :: Type 13 | newtype ByteStringJpeg = MkByteStringJpegUnsafe {unByteStringJpeg :: BL.ByteString} 14 | deriving stock (Eq, Generic, Ord, Read, Show) 15 | 16 | jpegConvertProfilePicture :: ImageJpegBytes -> Either String ByteStringJpeg 17 | jpegConvertProfilePicture bytesIn = do 18 | dynamicImage <- decodeJpeg $ BL.toStrict $ unImageJpegBytes bytesIn 19 | let imageIn = convertRGB8 dynamicImage 20 | imageOut <- execStateT resizeProfilePicture imageIn 21 | let bytesOut = encodeJpeg $ convertImage imageOut 22 | pure $ MkByteStringJpegUnsafe bytesOut 23 | where 24 | resizeProfilePicture :: StateT (Image PixelRGB8) (Either String) () 25 | resizeProfilePicture = do 26 | let targetSize :: Int = 640 27 | originalWidth <- gets imageWidth 28 | originalHeight <- gets imageHeight 29 | case compare originalWidth originalHeight of 30 | EQ -> pure () 31 | LT -> do 32 | let croppedHeight = originalWidth 33 | let croppedHeightCutOff = (originalHeight - croppedHeight) `div` 2 34 | modify $ crop 0 croppedHeightCutOff originalWidth croppedHeight 35 | GT -> do 36 | let croppedWidth = originalHeight 37 | let croppedWidthCutOff = (originalWidth - croppedWidth) `div` 2 38 | modify $ crop croppedWidthCutOff 0 croppedWidth originalHeight 39 | modify $ scaleBilinear targetSize targetSize 40 | 41 | jpegConvertSpacePicture :: ImageJpegBytes -> Either String ByteStringJpeg 42 | jpegConvertSpacePicture = jpegConvertProfilePicture 43 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Client/UI/Brick/AttrMap.hs: -------------------------------------------------------------------------------- 1 | module Mensam.Client.UI.Brick.AttrMap where 2 | 3 | import Brick 4 | import Brick.Forms 5 | import Brick.Widgets.List 6 | import Graphics.Vty 7 | 8 | attrDefault :: Attr 9 | attrDefault = 10 | Attr 11 | { attrStyle = Default 12 | , attrForeColor = SetTo brightWhite 13 | , attrBackColor = SetTo black 14 | , attrURL = Default 15 | } 16 | 17 | attrsDefault :: AttrMap 18 | attrsDefault = 19 | attrMap 20 | attrDefault 21 | [ (formAttr, attrDefault) 22 | , (focusedFormInputAttr, attrDefault {attrBackColor = SetTo brightBlack}) 23 | , (invalidFormInputAttr, attrDefault {attrForeColor = SetTo brightRed}) 24 | , (listAttr, attrDefault) 25 | , (listSelectedAttr, attrDefault `withStyle` standout) 26 | ] 27 | 28 | attrBackground :: Attr 29 | attrBackground = 30 | attrDefault 31 | { attrForeColor = SetTo white 32 | , attrBackColor = SetTo black 33 | } 34 | 35 | attrsBackground :: AttrMap 36 | attrsBackground = 37 | attrMap 38 | attrBackground 39 | [ (formAttr, attrBackground) 40 | , (focusedFormInputAttr, attrBackground {attrBackColor = SetTo brightBlack}) 41 | , (invalidFormInputAttr, attrBackground {attrForeColor = SetTo brightRed}) 42 | , (listAttr, attrBackground) 43 | , (listSelectedAttr, attrBackground `withStyle` standout) 44 | ] 45 | 46 | attrForeground :: Attr 47 | attrForeground = 48 | attrDefault 49 | { attrForeColor = SetTo brightBlack 50 | , attrBackColor = SetTo brightWhite 51 | } 52 | 53 | attrsForeground :: AttrMap 54 | attrsForeground = 55 | attrMap 56 | attrForeground 57 | [ (formAttr, attrForeground) 58 | , (focusedFormInputAttr, attrForeground {attrBackColor = SetTo brightBlack}) 59 | , (invalidFormInputAttr, attrForeground {attrForeColor = SetTo brightRed}) 60 | , (listAttr, attrForeground) 61 | , (listSelectedAttr, attrForeground `withStyle` standout) 62 | ] 63 | -------------------------------------------------------------------------------- /server/source/library/Mensam/API/Data/User/Username.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiWayIf #-} 2 | 3 | module Mensam.API.Data.User.Username where 4 | 5 | import Mensam.API.Pretty 6 | 7 | import Control.Applicative 8 | import Data.Aeson qualified as A 9 | import Data.Attoparsec.Combinator qualified as P 10 | import Data.Attoparsec.Text qualified as P 11 | import Data.Kind 12 | import Data.Text qualified as T 13 | import GHC.Generics 14 | import Servant.API 15 | 16 | type Username :: Type 17 | newtype Username = MkUsernameUnsafe {unUsername :: T.Text} 18 | deriving stock (Eq, Generic, Ord) 19 | 20 | deriving newtype instance Show Username 21 | instance Read Username where 22 | readsPrec p string = do 23 | (usernameText, rest) <- readsPrec @T.Text p string 24 | case mkUsername usernameText of 25 | Left err -> fail err 26 | Right username -> pure (username, rest) 27 | 28 | deriving newtype instance A.ToJSON Username 29 | instance A.FromJSON Username where 30 | parseJSON value = do 31 | text <- A.parseJSON @T.Text value 32 | case mkUsername text of 33 | Left err -> fail err 34 | Right username -> pure username 35 | 36 | mkUsername :: T.Text -> Either String Username 37 | mkUsername = P.parseOnly $ do 38 | let alphanumeric = (P.digit <|> P.letter) P. "unexpected non-alphanumeric character" 39 | chars <- P.manyTill alphanumeric P.endOfInput 40 | if 41 | | length chars > 32 -> fail "too long" 42 | | length chars < 4 -> fail "too short" 43 | | otherwise -> pure $ MkUsernameUnsafe $ T.pack chars 44 | 45 | deriving newtype instance ToHttpApiData Username 46 | instance FromHttpApiData Username where 47 | parseUrlPiece input = do 48 | text <- parseUrlPiece @T.Text input 49 | case mkUsername text of 50 | Left err -> Left $ T.pack err 51 | Right parsed -> Right parsed 52 | 53 | deriving via PrettyTextViaShow T.Text instance ToPrettyText Username 54 | deriving via PrettyHtml5ViaPrettyText Username instance ToPrettyHtml5 Username 55 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Server/Server/Handler.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | 3 | module Mensam.Server.Server.Handler where 4 | 5 | import Mensam.Server.Application.Configured.Class 6 | import Mensam.Server.Application.Email.Class 7 | import Mensam.Server.Application.LoggerCustom.Class 8 | import Mensam.Server.Application.Secret.Class 9 | import Mensam.Server.Application.SeldaPool.Class 10 | import Mensam.Server.Server.Handler.Profiler 11 | import Mensam.Server.Server.Handler.RequestHash 12 | 13 | import Control.Monad.Base 14 | import Control.Monad.Catch 15 | import Control.Monad.IO.Unlift 16 | import Control.Monad.Logger.CallStack 17 | import Control.Monad.Trans.Class 18 | import Control.Monad.Trans.Compose.Stack 19 | import Control.Monad.Trans.Control 20 | import Control.Monad.Trans.Control.Identity 21 | import Data.Kind 22 | 23 | type Transformers :: Stack 24 | type Transformers = 25 | NilT 26 | :.|> RequestHashT 27 | :.|> ProfilerT 28 | 29 | type HandlerT :: (Type -> Type) -> Type -> Type 30 | type role HandlerT _ _ 31 | newtype HandlerT m a = HandlerT {unHandlerT :: StackT Transformers m a} 32 | deriving newtype (Applicative, Functor, Monad) 33 | deriving newtype (MonadTrans, MonadTransControl, MonadTransControlIdentity) 34 | deriving newtype (MonadBase b, MonadBaseControl b, MonadBaseControlIdentity b) 35 | deriving newtype (MonadIO, MonadUnliftIO) 36 | deriving newtype (MonadThrow, MonadCatch, MonadMask) 37 | deriving newtype (MonadLogger, MonadLoggerCustom) 38 | deriving newtype (MonadConfigured) 39 | deriving newtype (MonadSecret) 40 | deriving newtype (MonadSeldaPool) 41 | deriving newtype (MonadEmail) 42 | 43 | runHandlerT :: (MonadIO m, MonadLoggerCustom m) => Hash -> HandlerT m a -> m a 44 | runHandlerT randomHash handler = do 45 | logInfo "Starting HTTP request handler." 46 | 47 | let runTransformers = 48 | RunNilT 49 | :..> runRequestHashT randomHash 50 | :..> runProfilerT 51 | 52 | runStackT runTransformers $ unHandlerT handler 53 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Client/Application/Options.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ApplicativeDo #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | 4 | module Mensam.Client.Application.Options where 5 | 6 | import Mensam.Client.Application.Options.Class 7 | 8 | import Control.Monad.Trans 9 | import Control.Monad.Trans.Compose 10 | import Control.Monad.Trans.Control 11 | import Control.Monad.Trans.Control.Identity 12 | import Control.Monad.Trans.Reader 13 | import Data.Foldable 14 | import Data.Kind 15 | import Options.Applicative 16 | import Servant.Client 17 | 18 | type OptionsT :: (Type -> Type) -> Type -> Type 19 | type role OptionsT _ _ 20 | newtype OptionsT m a = MkOptionsT {unOptionsT :: ReaderT Options m a} 21 | deriving newtype (Applicative, Functor, Monad) 22 | deriving newtype (MonadTrans, MonadTransControl, MonadTransControlIdentity) 23 | 24 | instance Monad m => MonadOptions (OptionsT m) where 25 | options = MkOptionsT ask 26 | 27 | deriving via 28 | OptionsT ((t2 :: (Type -> Type) -> Type -> Type) m) 29 | instance 30 | Monad (t2 m) => MonadOptions (ComposeT OptionsT t2 m) 31 | 32 | runOptionsT :: OptionsT m a -> Options -> m a 33 | runOptionsT = runReaderT . unOptionsT 34 | 35 | runAppOptionsT :: 36 | MonadIO m => 37 | OptionsT m a -> 38 | m a 39 | runAppOptionsT tma = do 40 | parsedOptions <- liftIO $ execParser parserInfoOptions 41 | runOptionsT tma parsedOptions 42 | 43 | parserInfoOptions :: ParserInfo Options 44 | parserInfoOptions = info parserOptions fullDesc 45 | 46 | parserOptions :: Parser Options 47 | parserOptions = do 48 | optionBaseUrl <- 49 | option readBaseUrl $ 50 | fold 51 | [ long "base-url" 52 | , help "Base URL to connect to a Mensam server instance" 53 | ] 54 | pure 55 | MkOptions 56 | { optionBaseUrl 57 | } 58 | 59 | readBaseUrl :: ReadM BaseUrl 60 | readBaseUrl = eitherReader $ \string -> 61 | case parseBaseUrl string of 62 | Left err -> Left $ "Failed to parse base URL: " ++ show err 63 | Right baseUrl -> Right baseUrl 64 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Client/Application.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | 3 | module Mensam.Client.Application where 4 | 5 | import Mensam.Client.Application.Event 6 | import Mensam.Client.Application.Event.Class 7 | import Mensam.Client.Application.HttpClient 8 | import Mensam.Client.Application.MensamClient 9 | import Mensam.Client.Application.MensamClient.Class 10 | import Mensam.Client.Application.Options 11 | import Mensam.Client.Application.Options.Class 12 | import Mensam.Client.UI.Brick.Events (ClientEvent) 13 | 14 | import Brick.BChan (BChan) 15 | import Control.Monad.IO.Class 16 | import Control.Monad.Logger.CallStack 17 | import Control.Monad.Logger.OrphanInstances () 18 | import Control.Monad.Trans.Class 19 | import Control.Monad.Trans.Compose.Stack 20 | import Control.Monad.Trans.Control 21 | import Control.Monad.Trans.Control.Identity 22 | import Data.Kind 23 | 24 | type Transformers :: Stack 25 | type Transformers = 26 | NilT 27 | :.|> OptionsT 28 | :.|> NoLoggingT 29 | :.|> HttpClientT 30 | :.|> MensamClientT 31 | :.|> EventT 32 | 33 | type ApplicationT :: (Type -> Type) -> Type -> Type 34 | type role ApplicationT _ _ 35 | newtype ApplicationT m a = ApplicationT {unApplicationT :: StackT Transformers m a} 36 | deriving newtype (Applicative, Functor, Monad) 37 | deriving newtype (MonadTrans, MonadTransControl, MonadTransControlIdentity) 38 | deriving newtype (MonadOptions) 39 | deriving newtype (MonadLogger) 40 | deriving newtype (MonadMensamClient) 41 | deriving newtype (MonadEvent) 42 | 43 | runApplicationT :: 44 | MonadIO m => 45 | BChan ClientEvent -> 46 | ApplicationT m a -> 47 | m a 48 | runApplicationT chan app = do 49 | let 50 | runTransformers :: MonadIO m => RunStackT Transformers m a 51 | runTransformers = 52 | RunNilT 53 | :..> runAppOptionsT 54 | :..> runNoLoggingT 55 | :..> runAppHttpClientT 56 | :..> runAppMensamClientT 57 | :..> (`runEventT` chan) 58 | 59 | runStackT runTransformers $ unApplicationT app 60 | -------------------------------------------------------------------------------- /frontend/review/src/ReviewConfig.elm: -------------------------------------------------------------------------------- 1 | module ReviewConfig exposing (config) 2 | 3 | import ForbidSpecificModuleImports 4 | import ForbidSpecificImports 5 | import NoBooleanCase 6 | import NoConfusingPrefixOperator 7 | import NoDeprecated 8 | import NoDuplicatePorts 9 | import NoExposingEverything 10 | import NoImportingEverything 11 | import NoInconsistentAliases 12 | import NoMissingTypeAnnotation 13 | import NoMissingTypeAnnotationInLetIn 14 | import NoMissingTypeExpose 15 | import NoModuleOnExposedNames 16 | import NoPrematureLetComputation 17 | import NoUnmatchedUnit 18 | import NoUnsafePorts 19 | import NoUnused.CustomTypeConstructorArgs 20 | import NoUnused.CustomTypeConstructors 21 | import NoUnused.Dependencies 22 | import NoUnused.Exports 23 | import NoUnused.Parameters 24 | import NoUnused.Patterns 25 | import NoUnused.Variables 26 | import NoUnusedPorts 27 | import Review.Rule exposing (Rule) 28 | 29 | 30 | config : List Rule 31 | config = 32 | [ ForbidSpecificImports.rule [] 33 | , ForbidSpecificModuleImports.rule 34 | [ ( "Mensam" 35 | , [ "Element.Events" 36 | ] 37 | ) 38 | ] 39 | , NoBooleanCase.rule 40 | , NoConfusingPrefixOperator.rule 41 | , NoDeprecated.rule NoDeprecated.defaults 42 | , NoDuplicatePorts.rule 43 | , NoImportingEverything.rule [] 44 | , NoInconsistentAliases.rule <| 45 | NoInconsistentAliases.noMissingAliases <| 46 | NoInconsistentAliases.config 47 | [ ( "Json.Decode", "Decode" ) 48 | , ( "Json.Encode", "Encode" ) 49 | ] 50 | , NoMissingTypeAnnotation.rule 51 | , NoMissingTypeExpose.rule 52 | , NoModuleOnExposedNames.rule 53 | , NoPrematureLetComputation.rule 54 | , NoUnmatchedUnit.rule 55 | , NoUnsafePorts.rule NoUnsafePorts.any 56 | , NoUnused.CustomTypeConstructors.rule [] 57 | , NoUnused.CustomTypeConstructorArgs.rule 58 | , NoUnused.Dependencies.rule 59 | , NoUnused.Exports.rule 60 | , NoUnused.Parameters.rule 61 | , NoUnused.Patterns.rule 62 | , NoUnused.Variables.rule 63 | , NoUnusedPorts.rule 64 | ] 65 | -------------------------------------------------------------------------------- /frontend/source/Mensam/Element/Color.elm: -------------------------------------------------------------------------------- 1 | module Mensam.Element.Color exposing (..) 2 | 3 | import Element 4 | import Mensam.Color 5 | 6 | 7 | type alias Color = 8 | Transparency -> Element.Color 9 | 10 | 11 | dark : AnsiIso6429 12 | dark = 13 | { black = toElementColor Mensam.Color.dark.black 14 | , red = toElementColor Mensam.Color.dark.red 15 | , green = toElementColor Mensam.Color.dark.green 16 | , yellow = toElementColor Mensam.Color.dark.yellow 17 | , blue = toElementColor Mensam.Color.dark.blue 18 | , magenta = toElementColor Mensam.Color.dark.magenta 19 | , cyan = toElementColor Mensam.Color.dark.cyan 20 | , white = toElementColor Mensam.Color.dark.white 21 | } 22 | 23 | 24 | bright : AnsiIso6429 25 | bright = 26 | { black = toElementColor Mensam.Color.bright.black 27 | , red = toElementColor Mensam.Color.bright.red 28 | , green = toElementColor Mensam.Color.bright.green 29 | , yellow = toElementColor Mensam.Color.bright.yellow 30 | , blue = toElementColor Mensam.Color.bright.blue 31 | , magenta = toElementColor Mensam.Color.bright.magenta 32 | , cyan = toElementColor Mensam.Color.bright.cyan 33 | , white = toElementColor Mensam.Color.bright.white 34 | } 35 | 36 | 37 | transparent : Element.Color 38 | transparent = 39 | Element.rgba255 0 0 0 0 40 | 41 | 42 | type Transparency 43 | = Opaque100 44 | | Opaque50 45 | | Opaque25 46 | | Opaque10 47 | | Opaque05 48 | 49 | 50 | type alias AnsiIso6429 = 51 | { black : Color 52 | , red : Color 53 | , green : Color 54 | , yellow : Color 55 | , blue : Color 56 | , magenta : Color 57 | , cyan : Color 58 | , white : Color 59 | } 60 | 61 | 62 | toElementColor : Mensam.Color.Color -> Transparency -> Element.Color 63 | toElementColor color transparency = 64 | Element.rgba255 color.r color.g color.b <| 65 | case transparency of 66 | Opaque100 -> 67 | 1 68 | 69 | Opaque50 -> 70 | 0.5 71 | 72 | Opaque25 -> 73 | 0.25 74 | 75 | Opaque10 -> 76 | 0.1 77 | 78 | Opaque05 -> 79 | 0.05 80 | -------------------------------------------------------------------------------- /server/source/library/Mensam/API/Data/Space/Permission.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# OPTIONS_GHC -Wno-orphans #-} 3 | 4 | module Mensam.API.Data.Space.Permission where 5 | 6 | import Mensam.API.Aeson 7 | 8 | import Data.Aeson qualified as A 9 | import Data.Kind 10 | import Data.Singletons.TH 11 | import Data.Text qualified as T 12 | import Data.Typeable 13 | import Deriving.Aeson qualified as A 14 | import GHC.Generics 15 | 16 | type Permission :: Type 17 | data Permission 18 | = MkPermissionViewSpace 19 | | MkPermissionEditDesk 20 | | MkPermissionEditUser 21 | | MkPermissionEditRole 22 | | MkPermissionEditSpace 23 | | MkPermissionCreateReservation 24 | | MkPermissionCancelReservation 25 | deriving stock (Bounded, Enum, Eq, Generic, Ord, Read, Show) 26 | deriving 27 | (A.FromJSON, A.ToJSON) 28 | via A.CustomJSON (JSONSettings "MkPermission" "") Permission 29 | 30 | type ErrorInsufficientPermission :: Permission -> Type 31 | type role ErrorInsufficientPermission _ 32 | data ErrorInsufficientPermission p = MkErrorInsufficientPermission 33 | deriving stock (Eq, Generic, Ord, Read, Show) 34 | 35 | instance Typeable p => A.FromJSON (ErrorInsufficientPermission p) where 36 | parseJSON = 37 | A.withText errorName $ \text -> 38 | case T.stripPrefix "Insufficient permission: " text of 39 | Nothing -> fail $ "Parsing " ++ errorName ++ "failed, expected prefix \"Insufficient permission: \"" 40 | Just suffix -> 41 | if T.unpack suffix == permissionName 42 | then pure MkErrorInsufficientPermission 43 | else fail $ "Parsing " ++ errorName ++ "failed, expected suffix \"" ++ permissionName ++ "\"" 44 | where 45 | errorName = tyConName (typeRepTyCon (typeRep $ Proxy @(ErrorInsufficientPermission p))) 46 | permissionName = tyConName (typeRepTyCon (typeRep $ Proxy @p)) 47 | 48 | instance Typeable p => A.ToJSON (ErrorInsufficientPermission p) where 49 | toJSON MkErrorInsufficientPermission = 50 | A.String $ T.pack $ "Insufficient permission: " ++ permissionName 51 | where 52 | permissionName = tyConName (typeRepTyCon (typeRep $ Proxy @p)) 53 | 54 | genSingletons [''Permission] 55 | type role SPermission _ 56 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Server/Application/Secret.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | 3 | module Mensam.Server.Application.Secret where 4 | 5 | import Mensam.Server.Application.Configured.Class 6 | import Mensam.Server.Application.Secret.Class 7 | import Mensam.Server.Application.SeldaPool.Class 8 | import Mensam.Server.Secrets 9 | 10 | import Control.Monad.Logger.CallStack 11 | import Control.Monad.Trans 12 | import Control.Monad.Trans.Compose 13 | import Control.Monad.Trans.Control 14 | import Control.Monad.Trans.Control.Identity 15 | import Control.Monad.Trans.Reader 16 | import Data.Kind 17 | import Data.Text qualified as T 18 | 19 | type SecretT :: (Type -> Type) -> Type -> Type 20 | type role SecretT _ _ 21 | newtype SecretT m a = SecretT {unSecretT :: ReaderT Secrets m a} 22 | deriving newtype (Applicative, Functor, Monad) 23 | deriving newtype (MonadTrans, MonadTransControl, MonadTransControlIdentity) 24 | 25 | instance Monad m => MonadSecret (SecretT m) where 26 | secrets = SecretT ask 27 | 28 | deriving via 29 | SecretT ((t2 :: (Type -> Type) -> Type -> Type) m) 30 | instance 31 | Monad (t2 m) => MonadSecret (ComposeT SecretT t2 m) 32 | 33 | runSecretT :: SecretT m a -> Secrets -> m a 34 | runSecretT = runReaderT . unSecretT 35 | 36 | runAppSecretT :: 37 | (MonadConfigured m, MonadLogger m, MonadSeldaPool m) => 38 | SecretT m a -> 39 | m a 40 | runAppSecretT tma = do 41 | logInfo "Acquiring secrets." 42 | 43 | secretsJwk <- do 44 | logInfo "Acquiring JWK." 45 | seldaResult <- runSeldaTransactionT $ do 46 | maybeOldJwk <- jwkGetLatest 47 | case maybeOldJwk of 48 | Just jwk -> do 49 | lift $ logInfo "Using existing JWK." 50 | pure jwk 51 | Nothing -> do 52 | lift $ logInfo "Currently there is no JWK set. Setting new JWK." 53 | jwk <- jwkSetLatest 54 | lift $ logInfo "Using newly set JWK." 55 | pure jwk 56 | case seldaResult of 57 | SeldaFailure err -> do 58 | logError $ "Failed to acquire JWK: " <> T.pack (show err) 59 | error "No JWK." 60 | SeldaSuccess jwk -> do 61 | logInfo "Acquired JWK successfully." 62 | pure jwk 63 | 64 | runSecretT tma $ MkSecrets {secretsJwk} 65 | -------------------------------------------------------------------------------- /frontend/source/Mensam/Space.elm: -------------------------------------------------------------------------------- 1 | module Mensam.Space exposing (..) 2 | 3 | import Json.Decode as Decode 4 | import Json.Encode as Encode 5 | 6 | 7 | type Identifier 8 | = MkIdentifier Int 9 | 10 | 11 | identifierToString : Identifier -> String 12 | identifierToString (MkIdentifier identifier) = 13 | String.fromInt identifier 14 | 15 | 16 | identifierEncode : Identifier -> Encode.Value 17 | identifierEncode (MkIdentifier identifier) = 18 | Encode.int identifier 19 | 20 | 21 | identifierDecoder : Decode.Decoder Identifier 22 | identifierDecoder = 23 | Decode.map MkIdentifier 24 | Decode.int 25 | 26 | 27 | type Name 28 | = MkName String 29 | 30 | 31 | nameToString : Name -> String 32 | nameToString (MkName name) = 33 | name 34 | 35 | 36 | nameEncode : Name -> Encode.Value 37 | nameEncode = 38 | Encode.string << nameToString 39 | 40 | 41 | nameDecoder : Decode.Decoder Name 42 | nameDecoder = 43 | Decode.map MkName Decode.string 44 | 45 | 46 | type Discoverability 47 | = MkDiscoverabilityPublic 48 | | MkDiscoverabilityPrivate 49 | 50 | 51 | discoverabilityToString : Discoverability -> String 52 | discoverabilityToString discoverability = 53 | case discoverability of 54 | MkDiscoverabilityPublic -> 55 | "public" 56 | 57 | MkDiscoverabilityPrivate -> 58 | "private" 59 | 60 | 61 | discoverabilityEncode : Discoverability -> Encode.Value 62 | discoverabilityEncode discoverability = 63 | Encode.string <| 64 | case discoverability of 65 | MkDiscoverabilityPublic -> 66 | "public" 67 | 68 | MkDiscoverabilityPrivate -> 69 | "private" 70 | 71 | 72 | discoverabilityDecoder : Decode.Decoder Discoverability 73 | discoverabilityDecoder = 74 | Decode.andThen 75 | (\string -> 76 | case string of 77 | "public" -> 78 | Decode.succeed MkDiscoverabilityPublic 79 | 80 | "private" -> 81 | Decode.succeed MkDiscoverabilityPrivate 82 | 83 | _ -> 84 | Decode.fail <| "Trying to decode discoverability, but this option is not supported: " ++ string 85 | ) 86 | Decode.string 87 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Server/Application/SeldaPool/Class.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | 3 | module Mensam.Server.Application.SeldaPool.Class where 4 | 5 | import Control.Monad.Catch 6 | import Control.Monad.IO.Class 7 | import Control.Monad.Trans.Class 8 | import Control.Monad.Trans.Compose 9 | import Control.Monad.Trans.Control.Identity 10 | import Control.Monad.Trans.Elevator 11 | import Control.Monad.Trans.Reader 12 | import Data.Kind 13 | import Database.Selda.Backend 14 | import Database.Selda.Backend.Internal 15 | import Database.Selda.SQLite 16 | 17 | type MonadSeldaPool :: (Type -> Type) -> Constraint 18 | class (Monad m, MonadMask (SeldaTransactionT m), MonadSelda (SeldaTransactionT m)) => MonadSeldaPool m where 19 | runSeldaTransactionT :: SeldaTransactionT m a -> m (SeldaResult a) 20 | 21 | instance 22 | ( Monad (t m) 23 | , MonadTransControlIdentity t 24 | , MonadSeldaPool m 25 | , MonadIO m 26 | , MonadMask m 27 | ) => 28 | MonadSeldaPool (Elevator t m) 29 | where 30 | runSeldaTransactionT transaction = 31 | liftWithIdentity $ \runT -> 32 | runSeldaTransactionT $ 33 | mapSeldaTransactionT runT transaction 34 | 35 | deriving via 36 | Elevator t1 ((t2 :: (Type -> Type) -> Type -> Type) m) 37 | instance 38 | {-# OVERLAPPABLE #-} 39 | ( Monad (t1 (t2 m)) 40 | , MonadTransControlIdentity t1 41 | , MonadSeldaPool (t2 m) 42 | , MonadIO (t2 m) 43 | , MonadMask (t2 m) 44 | , MonadIO m 45 | , MonadTrans (ComposeT t1 t2) 46 | ) => 47 | MonadSeldaPool (ComposeT t1 t2 m) 48 | 49 | type SeldaTransactionT :: (Type -> Type) -> Type -> Type 50 | type role SeldaTransactionT _ _ 51 | newtype SeldaTransactionT m a = MkSeldaTransactionT {unSeldaTransactionT :: SeldaT SQLite m a} 52 | deriving newtype (Functor, Applicative, Monad) 53 | deriving newtype (MonadTrans) 54 | deriving newtype (MonadIO) 55 | deriving newtype (MonadThrow, MonadCatch, MonadMask) 56 | deriving newtype (MonadSelda) 57 | 58 | mapSeldaTransactionT :: (m a -> n b) -> SeldaTransactionT m a -> SeldaTransactionT n b 59 | mapSeldaTransactionT f = MkSeldaTransactionT . S . mapReaderT f . unS . unSeldaTransactionT 60 | 61 | type SeldaResult :: Type -> Type 62 | type role SeldaResult _ 63 | data SeldaResult a 64 | = SeldaSuccess a 65 | | SeldaFailure SomeException 66 | -------------------------------------------------------------------------------- /frontend/source/Mensam/Element.elm: -------------------------------------------------------------------------------- 1 | module Mensam.Element exposing (..) 2 | 3 | import Browser 4 | import Element 5 | import Element.Background 6 | import Element.Font 7 | import Html.Attributes 8 | import Mensam.Element.Color 9 | import Mensam.Element.Font 10 | 11 | 12 | document : Element.Element msg -> Browser.Document msg 13 | document element = 14 | { title = "Mensam" 15 | , body = 16 | [ Element.layoutWith 17 | { options = 18 | [ Element.focusStyle 19 | { borderColor = Nothing 20 | , backgroundColor = Nothing 21 | , shadow = Nothing 22 | } 23 | ] 24 | } 25 | [ Element.Background.gradient 26 | { angle = 0 27 | , steps = 28 | [ Mensam.Element.Color.dark.yellow Mensam.Element.Color.Opaque100 29 | , Mensam.Element.Color.bright.yellow Mensam.Element.Color.Opaque100 30 | ] 31 | } 32 | , Element.Font.color <| Mensam.Element.Color.bright.white Mensam.Element.Color.Opaque100 33 | , Element.Font.alignLeft 34 | , Element.Font.family [ Mensam.Element.Font.sansSerif ] 35 | , Element.Font.regular 36 | , Element.Font.size 16 37 | ] 38 | <| 39 | Element.el 40 | [ Element.htmlAttribute <| Html.Attributes.style "min-width" "393px" 41 | , Element.htmlAttribute <| Html.Attributes.style "max-width" "851px" 42 | , Element.htmlAttribute <| Html.Attributes.style "margin-left" "auto" 43 | , Element.htmlAttribute <| Html.Attributes.style "margin-right" "auto" 44 | , Element.width Element.fill 45 | , Element.height <| Element.minimum 750 Element.fill 46 | , Element.Background.color <| Mensam.Element.Color.dark.black Mensam.Element.Color.Opaque100 47 | ] 48 | element 49 | ] 50 | } 51 | 52 | 53 | screen : (msgScreen -> msg) -> Element.Element msgScreen -> Element.Element msg 54 | screen embedMessage element = 55 | Element.map embedMessage <| 56 | Element.el 57 | [ Element.width Element.fill 58 | , Element.height Element.fill 59 | ] 60 | element 61 | -------------------------------------------------------------------------------- /server/source/library/Mensam/API/Data/User/Password.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiWayIf #-} 2 | 3 | module Mensam.API.Data.User.Password where 4 | 5 | import Control.Applicative 6 | import Data.Aeson qualified as A 7 | import Data.Attoparsec.Combinator qualified as P 8 | import Data.Attoparsec.Text qualified as P 9 | import Data.Kind 10 | import Data.Text qualified as T 11 | import GHC.Generics 12 | import Servant.API 13 | 14 | type Password :: Type 15 | newtype Password = MkPasswordUnsafe {unPassword :: T.Text} 16 | deriving stock (Eq, Generic, Ord) 17 | 18 | deriving newtype instance Show Password 19 | instance Read Password where 20 | readsPrec p string = do 21 | (passwordText, rest) <- readsPrec @T.Text p string 22 | case mkPassword passwordText of 23 | Left err -> fail err 24 | Right password -> pure (password, rest) 25 | 26 | deriving newtype instance A.ToJSON Password 27 | instance A.FromJSON Password where 28 | parseJSON value = do 29 | text <- A.parseJSON @T.Text value 30 | case mkPassword text of 31 | Left err -> fail err 32 | Right password -> pure password 33 | 34 | mkPassword :: T.Text -> Either String Password 35 | mkPassword = P.parseOnly $ do 36 | let 37 | symbol = P.choice $ P.char <$> passwordValidSymbols 38 | alphanumeric = (P.digit <|> P.letter <|> symbol) P. "unexpected non-alphanumeric and non-symbol character" 39 | chars <- P.manyTill alphanumeric P.endOfInput 40 | if 41 | | length chars > 32 -> fail "too long" 42 | | length chars < 4 -> fail "too short" 43 | | otherwise -> pure $ MkPasswordUnsafe $ T.pack chars 44 | 45 | deriving newtype instance ToHttpApiData Password 46 | instance FromHttpApiData Password where 47 | parseUrlPiece input = do 48 | text <- parseUrlPiece @T.Text input 49 | case mkPassword text of 50 | Left err -> Left $ T.pack err 51 | Right parsed -> Right parsed 52 | 53 | passwordValidSymbols :: [Char] 54 | passwordValidSymbols = 55 | [ ' ' 56 | , '~' 57 | , '`' 58 | , '!' 59 | , '?' 60 | , '@' 61 | , '#' 62 | , '$' 63 | , '%' 64 | , '^' 65 | , '&' 66 | , '*' 67 | , '_' 68 | , '-' 69 | , '+' 70 | , '=' 71 | , '<' 72 | , '>' 73 | , '(' 74 | , ')' 75 | , '{' 76 | , '}' 77 | , '[' 78 | , ']' 79 | , '|' 80 | , '\'' 81 | , '"' 82 | , ',' 83 | , '.' 84 | , ':' 85 | , ';' 86 | , '/' 87 | , '\\' 88 | ] 89 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Server/Environment.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE TypeFamilyDependencies #-} 3 | 4 | module Mensam.Server.Environment where 5 | 6 | import Control.Monad.Logger.CallStack 7 | import Data.Kind 8 | import Data.Singletons.TH 9 | import GHC.Generics 10 | import GHC.TypeLits 11 | import Text.Read 12 | 13 | type EnvVar :: Type 14 | data EnvVar 15 | = EnvVarConfigFile 16 | | EnvVarLogColor 17 | | EnvVarLogFile 18 | | EnvVarLogLevel 19 | deriving stock (Bounded, Enum, Eq, Generic, Ord, Read, Show) 20 | 21 | genSingletons [''EnvVar] 22 | type role SEnvVar _ 23 | 24 | type EnvVarName :: EnvVar -> Symbol 25 | type family EnvVarName envVar = name | name -> envVar where 26 | EnvVarName EnvVarConfigFile = "MENSAM_CONFIG_FILE" 27 | EnvVarName EnvVarLogColor = "MENSAM_LOG_COLOR" 28 | EnvVarName EnvVarLogFile = "MENSAM_LOG_FILE" 29 | EnvVarName EnvVarLogLevel = "MENSAM_LOG_LEVEL" 30 | 31 | type EnvVarValue :: EnvVar -> Type 32 | type family EnvVarValue envVar = value where 33 | EnvVarValue EnvVarConfigFile = FilePath 34 | EnvVarValue EnvVarLogFile = Maybe FilePath 35 | EnvVarValue EnvVarLogLevel = LogLevel 36 | EnvVarValue EnvVarLogColor = Bool 37 | 38 | envVarParse :: SEnvVar envVar -> String -> Maybe (EnvVarValue envVar) 39 | envVarParse = \case 40 | SEnvVarConfigFile -> Just 41 | SEnvVarLogColor -> readMaybe 42 | SEnvVarLogFile -> Just . Just 43 | SEnvVarLogLevel -> readMaybe 44 | 45 | envVarDefault :: SEnvVar envVar -> EnvVarValue envVar 46 | envVarDefault = \case 47 | SEnvVarConfigFile -> "./mensam.json" 48 | SEnvVarLogColor -> True 49 | SEnvVarLogFile -> Nothing 50 | SEnvVarLogLevel -> LevelDebug 51 | 52 | envVarHelp :: [String] 53 | envVarHelp = singleEnvVarHelp <$> [minBound .. maxBound] 54 | where 55 | singleEnvVarHelp :: EnvVar -> String 56 | singleEnvVarHelp = \case 57 | EnvVarConfigFile -> "MENSAM_CONFIG_FILE=[FILEPATH] (filepath to a JSON configuration file)" 58 | EnvVarLogColor -> "MENSAM_LOG_COLOR=[True|False] (toggle the color of the log)" 59 | EnvVarLogFile -> "MENSAM_LOG_FILE=[FILEPATH] (filepath where the log will get dumped)" 60 | EnvVarLogLevel -> "MENSAM_LOG_LEVEL=[LevelDebug|LevelInfo|LevelWarn|LevelError] (set log verbosity)" 61 | 62 | type Environment :: Type 63 | newtype Environment = MkEnvironment {getEnvironment :: forall envVar. SEnvVar envVar -> EnvVarValue envVar} 64 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Server/Secrets.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLabels #-} 2 | 3 | module Mensam.Server.Secrets where 4 | 5 | import Mensam.Server.Application.SeldaPool.Class 6 | import Mensam.Server.Database.Schema 7 | 8 | import Control.Monad.IO.Class 9 | import Control.Monad.Logger.CallStack 10 | import Control.Monad.Trans.Class 11 | import Crypto.JOSE.JWK qualified as JOSE 12 | import Data.Kind 13 | import Data.Text qualified as T 14 | import Data.Time qualified as T 15 | import Database.Selda qualified as Selda 16 | import Servant.Auth.Server 17 | 18 | type Secrets :: Type 19 | newtype Secrets = MkSecrets 20 | { secretsJwk :: JOSE.JWK 21 | } 22 | 23 | jwkGetLatest :: 24 | ( MonadSeldaPool m 25 | , MonadLogger m 26 | ) => 27 | SeldaTransactionT m (Maybe JOSE.JWK) 28 | jwkGetLatest = do 29 | lift $ logDebug "Getting latest JWK." 30 | dbJwks <- Selda.query $ do 31 | dbJwk <- Selda.select tableJwk 32 | Selda.order (dbJwk Selda.! #dbJwk_id) Selda.Desc 33 | pure dbJwk 34 | case dbJwks of 35 | [] -> do 36 | lift $ logInfo "No JWK currently in database." 37 | pure Nothing 38 | dbJwk : _ -> do 39 | lift $ logDebug "Successfully got JWKs from database. Parsing the latest JWK." 40 | let jwk = fromSecret $ dbJwk_jwk dbJwk 41 | lift $ logDebug "Successfully parsed JWK." 42 | lift $ logInfo "Returning JWK." 43 | pure $ Just jwk 44 | 45 | jwkSetLatest :: 46 | ( MonadSeldaPool m 47 | , MonadLogger m 48 | ) => 49 | SeldaTransactionT m JOSE.JWK 50 | jwkSetLatest = do 51 | lift $ logDebug "Setting latest JWK." 52 | maybeJwk <- jwkGetLatest 53 | case maybeJwk of 54 | Just jwk -> do 55 | lift $ logWarn "JWK already exists. Skipping." 56 | lift $ logInfo "Returning an old JWK." 57 | pure jwk 58 | Nothing -> do 59 | lift $ logDebug "Generating a new JWK." 60 | secret <- liftIO generateSecret 61 | let jwk = fromSecret secret 62 | currentTime <- liftIO T.getCurrentTime 63 | let dbJwk = 64 | MkDbJwk 65 | { dbJwk_id = Selda.def 66 | , dbJwk_jwk = secret 67 | , dbJwk_created = currentTime 68 | } 69 | identifier <- Selda.insertWithPK tableJwk [dbJwk] 70 | lift $ logInfo $ "Inserted new JWK: " <> T.pack (show identifier) 71 | lift $ logInfo "Returning newly generated JWK." 72 | pure jwk 73 | -------------------------------------------------------------------------------- /frontend/source/Mensam/Api/PictureDownload.elm: -------------------------------------------------------------------------------- 1 | module Mensam.Api.PictureDownload exposing (..) 2 | 3 | import Base64.Encode 4 | import Bytes 5 | import Http 6 | import Mensam.Auth.Bearer 7 | import Mensam.Http.Tracker 8 | import Mensam.Url 9 | import Mensam.User 10 | import Url.Builder 11 | 12 | 13 | type alias Request = 14 | { jwt : Mensam.Auth.Bearer.Jwt 15 | , user : Mensam.User.Identifier 16 | } 17 | 18 | 19 | type Response 20 | = Success { url : String } 21 | 22 | 23 | request : Maybe Mensam.Http.Tracker.Tracker -> Mensam.Url.BaseUrl -> Request -> (Result Http.Error Response -> a) -> Cmd a 24 | request tracker baseUrl body handleResult = 25 | Http.request 26 | { method = "GET" 27 | , headers = 28 | [ Mensam.Auth.Bearer.authorizationHeader body.jwt 29 | ] 30 | , url = 31 | Mensam.Url.absolute baseUrl 32 | [ "api" 33 | , "picture" 34 | ] 35 | [ Url.Builder.string "user" (Mensam.User.identifierToString body.user) ] 36 | , body = Http.emptyBody 37 | , expect = Http.expectBytesResponse handleResult responseResult 38 | , timeout = Nothing 39 | , tracker = Maybe.map Mensam.Http.Tracker.toHttp tracker 40 | } 41 | 42 | 43 | responseResult : Http.Response Bytes.Bytes -> Result Http.Error Response 44 | responseResult httpResponse = 45 | case httpResponse of 46 | Http.BadUrl_ err -> 47 | Err <| Http.BadUrl err 48 | 49 | Http.Timeout_ -> 50 | Err <| Http.Timeout 51 | 52 | Http.NetworkError_ -> 53 | Err <| Http.NetworkError 54 | 55 | Http.BadStatus_ metadata _ -> 56 | case metadata.statusCode of 57 | status -> 58 | Err <| Http.BadStatus status 59 | 60 | Http.GoodStatus_ metadata body -> 61 | case metadata.statusCode of 62 | 200 -> 63 | Ok <| Success <| decodeBody200 body 64 | 65 | status -> 66 | Err <| Http.BadStatus status 67 | 68 | 69 | decodeBody200 : Bytes.Bytes -> { url : String } 70 | decodeBody200 bytes = 71 | let 72 | base64Jpeg = 73 | Base64.Encode.encode <| Base64.Encode.bytes bytes 74 | 75 | base64Url = 76 | "data:image/png;base64, " ++ base64Jpeg 77 | in 78 | { url = base64Url } 79 | -------------------------------------------------------------------------------- /frontend/source/Mensam/Api/SpacePictureDownload.elm: -------------------------------------------------------------------------------- 1 | module Mensam.Api.SpacePictureDownload exposing (..) 2 | 3 | import Base64.Encode 4 | import Bytes 5 | import Http 6 | import Mensam.Auth.Bearer 7 | import Mensam.Http.Tracker 8 | import Mensam.Space 9 | import Mensam.Url 10 | import Url.Builder 11 | 12 | 13 | type alias Request = 14 | { jwt : Mensam.Auth.Bearer.Jwt 15 | , space : Mensam.Space.Identifier 16 | } 17 | 18 | 19 | type Response 20 | = Success { url : String } 21 | 22 | 23 | request : Maybe Mensam.Http.Tracker.Tracker -> Mensam.Url.BaseUrl -> Request -> (Result Http.Error Response -> a) -> Cmd a 24 | request tracker baseUrl body handleResult = 25 | Http.request 26 | { method = "GET" 27 | , headers = 28 | [ Mensam.Auth.Bearer.authorizationHeader body.jwt 29 | ] 30 | , url = 31 | Mensam.Url.absolute baseUrl 32 | [ "api" 33 | , "space" 34 | , "picture" 35 | ] 36 | [ Url.Builder.string "space" (Mensam.Space.identifierToString body.space) ] 37 | , body = Http.emptyBody 38 | , expect = Http.expectBytesResponse handleResult responseResult 39 | , timeout = Nothing 40 | , tracker = Maybe.map Mensam.Http.Tracker.toHttp tracker 41 | } 42 | 43 | 44 | responseResult : Http.Response Bytes.Bytes -> Result Http.Error Response 45 | responseResult httpResponse = 46 | case httpResponse of 47 | Http.BadUrl_ err -> 48 | Err <| Http.BadUrl err 49 | 50 | Http.Timeout_ -> 51 | Err <| Http.Timeout 52 | 53 | Http.NetworkError_ -> 54 | Err <| Http.NetworkError 55 | 56 | Http.BadStatus_ metadata _ -> 57 | case metadata.statusCode of 58 | status -> 59 | Err <| Http.BadStatus status 60 | 61 | Http.GoodStatus_ metadata body -> 62 | case metadata.statusCode of 63 | 200 -> 64 | Ok <| Success <| decodeBody200 body 65 | 66 | status -> 67 | Err <| Http.BadStatus status 68 | 69 | 70 | decodeBody200 : Bytes.Bytes -> { url : String } 71 | decodeBody200 bytes = 72 | let 73 | base64Jpeg = 74 | Base64.Encode.encode <| Base64.Encode.bytes bytes 75 | 76 | base64Url = 77 | "data:image/png;base64, " ++ base64Jpeg 78 | in 79 | { url = base64Url } 80 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Server/Server/Route/Api/OpenApi.hs: -------------------------------------------------------------------------------- 1 | module Mensam.Server.Server.Route.Api.OpenApi where 2 | 3 | import Mensam.API.Route.Api qualified as Route.Api 4 | import Mensam.API.Route.Api.OpenApi 5 | import Mensam.Server.Application.Configured.Class 6 | import Mensam.Server.Configuration 7 | import Mensam.Server.OpenApi qualified 8 | 9 | import Control.Lens 10 | import Data.List qualified as L 11 | import Data.OpenApi 12 | import Data.Text qualified as T 13 | import Servant.Links 14 | import Servant.Server.Generic 15 | 16 | handler :: 17 | MonadConfigured m => 18 | Routes (AsServerT m) 19 | handler = 20 | Routes 21 | { routeJson = specification 22 | } 23 | 24 | specification :: MonadConfigured m => m OpenApi 25 | specification = do 26 | config <- configuration 27 | let 28 | addVersion :: OpenApi -> OpenApi 29 | addVersion = 30 | case configRevision config of 31 | Just revision -> info . version .~ revision 32 | Nothing -> id 33 | addServer :: OpenApi -> OpenApi 34 | addServer = servers .~ [relativeServer] 35 | where 36 | relativeServer = 37 | Server 38 | { _serverUrl = T.pack relativePath 39 | , _serverDescription = Nothing 40 | , _serverVariables = mempty 41 | } 42 | linkCurrent = routeJson . Route.Api.routeOpenApi $ allFieldLinks 43 | relativePath = relativePathGoBack linkCurrent 44 | addDescription :: OpenApi -> OpenApi 45 | addDescription = 46 | info . description 47 | ?~ T.concat 48 | [ "This is the API for Mensam Desk-Booking.\n\ 49 | \\n\ 50 | \- [User Interface](..)\n" 51 | , case configSourceUrl config of 52 | Nothing -> "" 53 | Just sourceUrl -> "- [GitHub](" <> sourceUrl <> ")\n" 54 | , "- [OpenAPI]()\n\ 55 | \- [Haddock (server source)](./haddock/index.html)\n\ 56 | \\n" 57 | ] 58 | pure $ 59 | Mensam.Server.OpenApi.openapi 60 | & info . title .~ "Mensam API" 61 | & addVersion 62 | & info . license ?~ "GNU Affero General Public License v3.0" 63 | & addDescription 64 | & addServer 65 | 66 | -- | Assuming that the origin link doesn't have a trailing slash. 67 | relativePathGoBack :: Servant.Links.Link -> String 68 | relativePathGoBack origin = 69 | case linkSegments origin of 70 | [] -> "" 71 | [_] -> "" 72 | _ : baseSegments -> L.intercalate "/" (".." <$ baseSegments) 73 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ApplicativeDo #-} 2 | 3 | module Mensam.Main where 4 | 5 | import Mensam.Client qualified 6 | import Mensam.Server qualified 7 | import Mensam.Server.Options qualified 8 | 9 | import Data.Foldable 10 | import Data.Kind 11 | import Options.Applicative 12 | import Options.Applicative.Extra 13 | import Options.Applicative.Types 14 | 15 | main :: IO () 16 | main = do 17 | options <- customExecParser parserPrefs parserInfoOptions 18 | case optionExecute options of 19 | MkExecutableServer serverOptions -> 20 | Mensam.Server.mainWithOptions serverOptions 21 | MkExecutableClient () -> 22 | Mensam.Client.main 23 | 24 | parserPrefs :: ParserPrefs 25 | parserPrefs = 26 | ParserPrefs 27 | { prefMultiSuffix = "" 28 | , prefDisambiguate = False 29 | , prefShowHelpOnError = True 30 | , prefShowHelpOnEmpty = True 31 | , prefBacktrack = NoBacktrack 32 | , prefColumns = 80 33 | , prefHelpLongEquals = True 34 | , prefHelpShowGlobal = True 35 | , prefTabulateFill = 10 36 | } 37 | 38 | type Options :: Type 39 | newtype Options = MkOptions 40 | { optionExecute :: Executable 41 | } 42 | 43 | type Executable :: Type 44 | data Executable 45 | = MkExecutableServer Mensam.Server.Options.Options 46 | | MkExecutableClient () 47 | 48 | parserInfoOptions :: ParserInfo Options 49 | parserInfoOptions = 50 | info parserOptions $ 51 | fold 52 | [ header "Mensam" 53 | ] 54 | 55 | parserOptions :: Parser Options 56 | parserOptions = 57 | parserAddHelper <*> parserAddVersion <*> do 58 | execute <- 59 | subparser $ 60 | fold 61 | [ command "server" (MkExecutableServer <$> Mensam.Server.Options.parserInfoOptions) 62 | , command "client" (MkExecutableClient <$> parserClientOptions) 63 | ] 64 | pure $ 65 | MkOptions 66 | { optionExecute = execute 67 | } 68 | 69 | parserClientOptions :: ParserInfo () 70 | parserClientOptions = 71 | info 72 | (parserAddHelper <*> pure ()) 73 | ( fold 74 | [ progDesc "connect to a webserver" 75 | ] 76 | ) 77 | 78 | parserAddVersion :: Parser (a -> a) 79 | parserAddVersion = 80 | abortOption (InfoMsg "TODO: Add Version.") $ 81 | fold 82 | [ short 'v' 83 | , long "version" 84 | , help "display version" 85 | ] 86 | 87 | parserAddHelper :: Parser (a -> a) 88 | parserAddHelper = 89 | helperWith $ 90 | fold 91 | [ short 'h' 92 | , long "help" 93 | , help "display this help message" 94 | ] 95 | -------------------------------------------------------------------------------- /server/source/library/Deriving/Aeson/OrphanInstances.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | 4 | module Deriving.Aeson.OrphanInstances () where 5 | 6 | import Data.Aeson qualified as A 7 | import Data.Kind 8 | import Data.OpenApi 9 | import Data.OpenApi.Internal.ParamSchema 10 | import Data.OpenApi.Internal.Schema 11 | import Data.Proxy 12 | import Data.Typeable 13 | import Deriving.Aeson qualified as A 14 | import GHC.Generics 15 | import GHC.TypeLits 16 | 17 | instance (ToSchemaOptions t, Generic a, GToSchema (Rep a), Typeable a, Typeable (A.CustomJSON t a)) => ToSchema (A.CustomJSON t a) where 18 | declareNamedSchema Proxy = genericDeclareNamedSchema (schemaOptions $ Proxy @t) $ Proxy @a 19 | instance (ToSchemaOptions t, Generic a, GToParamSchema (Rep a)) => ToParamSchema (A.CustomJSON t a) where 20 | toParamSchema Proxy = genericToParamSchema (schemaOptions $ Proxy @t) $ Proxy @a 21 | 22 | type ToSchemaOptions :: [Type] -> Constraint 23 | class ToSchemaOptions xs where 24 | schemaOptions :: Proxy xs -> SchemaOptions 25 | 26 | instance ToSchemaOptions '[] where 27 | schemaOptions Proxy = defaultSchemaOptions 28 | 29 | instance ToSchemaOptions xs => ToSchemaOptions (A.UnwrapUnaryRecords ': xs) where 30 | schemaOptions Proxy = (schemaOptions $ Proxy @xs) {unwrapUnaryRecords = True} 31 | 32 | -- instance ToSchemaOptions xs => ToSchemaOptions (A.OmitNothingFields ': xs) where 33 | -- schemaOptions Proxy = (schemaOptions $ Proxy @xs) { omitNothingFields = True } 34 | 35 | instance ToSchemaOptions xs => ToSchemaOptions (A.RejectUnknownFields ': xs) where 36 | schemaOptions Proxy = schemaOptions $ Proxy @xs 37 | 38 | instance (A.StringModifier f, ToSchemaOptions xs) => ToSchemaOptions (A.FieldLabelModifier f ': xs) where 39 | schemaOptions Proxy = 40 | let next = schemaOptions $ Proxy @xs 41 | in next {fieldLabelModifier = fieldLabelModifier next . A.getStringModifier @f} 42 | 43 | instance (A.StringModifier f, ToSchemaOptions xs) => ToSchemaOptions (A.ConstructorTagModifier f ': xs) where 44 | schemaOptions Proxy = 45 | let next = schemaOptions $ Proxy @xs 46 | in next {constructorTagModifier = constructorTagModifier next . A.getStringModifier @f} 47 | 48 | instance (KnownSymbol t, KnownSymbol c, ToSchemaOptions xs) => ToSchemaOptions (A.SumTaggedObject t c ': xs) where 49 | schemaOptions Proxy = 50 | (schemaOptions $ Proxy @xs) 51 | { sumEncoding = 52 | A.TaggedObject 53 | { A.tagFieldName = symbolVal $ Proxy @t 54 | , A.contentsFieldName = symbolVal $ Proxy @c 55 | } 56 | } 57 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Client/UI/Login.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Mensam.Client.UI.Login where 4 | 5 | import Mensam.API.Data.User.Username 6 | import Mensam.Client.Application 7 | import Mensam.Client.Application.Event.Class 8 | import Mensam.Client.OrphanInstances 9 | import Mensam.Client.UI.Brick.Draw 10 | import Mensam.Client.UI.Brick.Events 11 | import Mensam.Client.UI.Brick.Names 12 | 13 | import Brick 14 | import Brick.Forms 15 | import Brick.Widgets.Border 16 | import Brick.Widgets.Center 17 | import Control.Monad.Trans.Class 18 | import Data.Kind 19 | import Data.Text qualified as T 20 | import Graphics.Vty.Input.Events 21 | import Lens.Micro.Platform 22 | 23 | type LoginInfo :: Type 24 | data LoginInfo = MkLoginInfo 25 | { _loginInfoUsername :: T.Text 26 | , _loginInfoPassword :: T.Text 27 | } 28 | makeLenses ''LoginInfo 29 | 30 | loginFormInitial :: Form LoginInfo e ClientName 31 | loginFormInitial = 32 | newForm 33 | [ (str "Username: " <+>) 34 | @@= editField 35 | loginInfoUsername 36 | ClientNameLoginUsername 37 | (Just 1) 38 | id 39 | ( \case 40 | [line] -> either (const Nothing) (Just . unUsername) $ mkUsername line 41 | _ -> Nothing 42 | ) 43 | (txt . T.intercalate "\n") 44 | id 45 | , (str "Password: " <+>) @@= editPasswordField loginInfoPassword ClientNameLoginPassword 46 | ] 47 | MkLoginInfo 48 | { _loginInfoUsername = "" 49 | , _loginInfoPassword = "" 50 | } 51 | 52 | type ScreenLoginState :: Type 53 | newtype ScreenLoginState = MkScreenLoginState 54 | { _screenStateLoginForm :: Form LoginInfo ClientEvent ClientName 55 | } 56 | makeLenses ''ScreenLoginState 57 | 58 | loginDraw :: ScreenLoginState -> [Widget ClientName] 59 | loginDraw = \case 60 | MkScreenLoginState {_screenStateLoginForm = form} -> 61 | [ centerLayer $ borderWithLabel (txt "Login") $ cropRightTo 60 $ renderForm form 62 | , drawHelp 63 | ] 64 | 65 | loginHandleEvent :: BrickEvent ClientName ClientEvent -> ApplicationT (EventM ClientName ScreenLoginState) () 66 | loginHandleEvent = \case 67 | VtyEvent (EvKey KEnter []) -> do 68 | s <- lift get 69 | case formState $ _screenStateLoginForm s of 70 | loginInfo -> do 71 | sendEvent $ 72 | ClientEventSendRequestLogin $ 73 | MkCredentials 74 | { credentialsUsername = loginInfo ^. loginInfoUsername 75 | , credentialsPassword = loginInfo ^. loginInfoPassword 76 | } 77 | event -> lift $ zoom screenStateLoginForm $ handleFormEvent event 78 | -------------------------------------------------------------------------------- /static/subflake.nix: -------------------------------------------------------------------------------- 1 | { self, nixpkgs }: rec { 2 | 3 | packages.x86_64-linux.default = 4 | with import nixpkgs { system = "x86_64-linux"; overlays = [ self.subflakes.setup.overlays.default ]; }; 5 | stdenv.mkDerivation { 6 | name = "static"; # TODO: Necessary to avoid segmentation fault. 7 | src = ./.; 8 | buildPhase = '' 9 | make all 10 | 11 | cp -r ${packages.x86_64-linux.fonts}/fonts build 12 | 13 | cp ${pkgs.redocly-cli}/lib/node_modules/@redocly/cli/node_modules/redoc/bundles/redoc.standalone.js build 14 | 15 | sed -i 's|https://cdn.redoc.ly/redoc/logo-mini.svg|static/favicon.png|g' build/redoc.standalone.js 16 | 17 | cp --target-directory=build --recursive ${self.subflakes.fallback.packages.x86_64-linux.default.outPath}/* 18 | cp --target-directory=build --recursive ${self.subflakes.frontend.packages.x86_64-linux.default.outPath}/* 19 | ''; 20 | installPhase = '' 21 | cp --recursive build $out 22 | ''; 23 | buildInputs = [ 24 | ]; 25 | nativeBuildInputs = [ 26 | imagemagick 27 | ]; 28 | }; 29 | 30 | # Mensam: Fira 31 | # Redoc: Montserrat, Roboto 32 | packages.x86_64-linux.fonts = 33 | with import nixpkgs { system = "x86_64-linux"; overlays = [ self.subflakes.setup.overlays.default ]; }; 34 | stdenv.mkDerivation { 35 | name = "fonts"; # TODO: Necessary to avoid segmentation fault. 36 | dontUnpack = true; 37 | buildPhase = '' 38 | mkdir -p build 39 | cp -r ${pkgs.fira.outPath}/share/fonts/opentype build 40 | mv build/opentype build/fonts 41 | chmod --recursive +w build/fonts 42 | cp ${pkgs.roboto.outPath}/share/fonts/truetype/* build/fonts 43 | for f in build/fonts/* 44 | do 45 | woff2_compress $f 46 | done 47 | cp ${pkgs.montserrat.outPath}/share/fonts/woff2/* build/fonts 48 | ''; 49 | installPhase = '' 50 | cp --recursive build $out 51 | ''; 52 | buildInputs = [ 53 | ]; 54 | nativeBuildInputs = [ 55 | woff2 56 | ]; 57 | }; 58 | 59 | devShells.x86_64-linux.default = 60 | with import nixpkgs { system = "x86_64-linux"; overlays = [ self.subflakes.setup.overlays.default ]; }; 61 | pkgs.mkShell { 62 | inputsFrom = [ 63 | packages.x86_64-linux.default 64 | packages.x86_64-linux.fonts 65 | ]; 66 | }; 67 | 68 | checks.x86_64-linux.package = packages.x86_64-linux.default; 69 | 70 | checks.x86_64-linux.fonts = packages.x86_64-linux.fonts; 71 | 72 | checks.x86_64-linux.devShell = devShells.x86_64-linux.default; 73 | 74 | } 75 | -------------------------------------------------------------------------------- /frontend/source/Mensam/Api/Logout.elm: -------------------------------------------------------------------------------- 1 | module Mensam.Api.Logout exposing (..) 2 | 3 | import Http 4 | import Json.Decode as Decode 5 | import Mensam.Auth.Bearer 6 | import Mensam.Http.Tracker 7 | import Mensam.Url 8 | 9 | 10 | type alias Request = 11 | { jwt : Mensam.Auth.Bearer.Jwt 12 | } 13 | 14 | 15 | type Response 16 | = Success 17 | | ErrorAuth Mensam.Auth.Bearer.Error 18 | 19 | 20 | request : Maybe Mensam.Http.Tracker.Tracker -> Mensam.Url.BaseUrl -> Request -> (Result Http.Error Response -> a) -> Cmd a 21 | request tracker baseUrl body handleResult = 22 | Http.request 23 | { method = "POST" 24 | , headers = 25 | [ Mensam.Auth.Bearer.authorizationHeader body.jwt 26 | ] 27 | , url = 28 | Mensam.Url.absolute baseUrl 29 | [ "api" 30 | , "logout" 31 | ] 32 | [] 33 | , body = Http.emptyBody 34 | , expect = Http.expectStringResponse handleResult responseResult 35 | , timeout = Nothing 36 | , tracker = Maybe.map Mensam.Http.Tracker.toHttp tracker 37 | } 38 | 39 | 40 | responseResult : Http.Response String -> Result Http.Error Response 41 | responseResult httpResponse = 42 | case httpResponse of 43 | Http.BadUrl_ err -> 44 | Err <| Http.BadUrl err 45 | 46 | Http.Timeout_ -> 47 | Err <| Http.Timeout 48 | 49 | Http.NetworkError_ -> 50 | Err <| Http.NetworkError 51 | 52 | Http.BadStatus_ metadata body -> 53 | case metadata.statusCode of 54 | 401 -> 55 | case Decode.decodeString Mensam.Auth.Bearer.http401BodyDecoder body of 56 | Ok value -> 57 | Ok <| ErrorAuth value 58 | 59 | Err err -> 60 | Err <| Http.BadBody <| Decode.errorToString err 61 | 62 | status -> 63 | Err <| Http.BadStatus status 64 | 65 | Http.GoodStatus_ metadata body -> 66 | case metadata.statusCode of 67 | 200 -> 68 | case Decode.decodeString decodeBody200 body of 69 | Ok () -> 70 | Ok <| Success 71 | 72 | Err err -> 73 | Err <| Http.BadBody <| Decode.errorToString err 74 | 75 | status -> 76 | Err <| Http.BadStatus status 77 | 78 | 79 | decodeBody200 : Decode.Decoder () 80 | decodeBody200 = 81 | Decode.map (\_ -> ()) 82 | (Decode.field "unit" <| Decode.list <| Decode.succeed ()) 83 | -------------------------------------------------------------------------------- /server/source/library/Mensam/API/Aeson/StaticText.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | 3 | module Mensam.API.Aeson.StaticText where 4 | 5 | import Mensam.API.Aeson.StaticText.Internal () 6 | import Mensam.API.Aeson.StaticText.Internal.Union qualified as Union 7 | 8 | import Data.Aeson qualified as A 9 | import Data.Kind 10 | import Data.Proxy 11 | import Data.SOP qualified as SOP 12 | import Data.Text qualified as T 13 | import GHC.Generics 14 | import GHC.TypeLits 15 | 16 | type StaticText :: Symbol -> Type 17 | type role StaticText nominal 18 | data StaticText text = MkStaticText 19 | deriving stock (Eq, Generic, Ord, Read, Show) 20 | 21 | instance KnownSymbol text => A.FromJSON (StaticText text) where 22 | parseJSON = A.withText ("(StaticText " ++ show str ++ ")") $ \jsonTxt -> 23 | if jsonTxt == txt 24 | then pure MkStaticText 25 | else fail $ "Unexpected static text. Expected :" <> show str 26 | where 27 | str = symbolVal (Proxy @text) 28 | txt = T.pack str 29 | 30 | instance KnownSymbol text => A.ToJSON (StaticText text) where 31 | toJSON MkStaticText = A.String $ T.pack $ symbolVal (Proxy @text) 32 | 33 | type StaticTexts :: [Symbol] -> Type 34 | type role StaticTexts nominal 35 | newtype StaticTexts texts = MkStaticTexts {unStaticTexts :: Union.Union (Union.Map StaticText texts)} 36 | 37 | deriving stock instance SOP.All (SOP.Compose Eq SOP.I) (Union.Map StaticText texts) => Eq (StaticTexts texts) 38 | deriving stock instance SOP.All (SOP.Compose Show SOP.I) (Union.Map StaticText texts) => Show (StaticTexts texts) 39 | deriving stock instance (SOP.All (SOP.Compose Eq SOP.I) (Union.Map StaticText texts), SOP.All (SOP.Compose Ord SOP.I) (Union.Map StaticText texts)) => Ord (StaticTexts texts) 40 | deriving stock instance Read (StaticTexts '[]) 41 | deriving stock instance (Read (StaticText text), Read (SOP.NS SOP.I (Union.Map StaticText texts))) => Read (StaticTexts (text : texts)) 42 | 43 | deriving newtype instance A.ToJSON (StaticTexts '[]) 44 | deriving newtype instance (A.ToJSON (StaticText text), A.ToJSON (SOP.NS SOP.I (Union.Map StaticText texts)), Union.Unique (Union.Map StaticText (text : texts))) => A.ToJSON (StaticTexts (text : texts)) 45 | 46 | deriving newtype instance A.FromJSON (StaticTexts '[]) 47 | deriving newtype instance (A.FromJSON (StaticText text), A.FromJSON (SOP.NS SOP.I (Union.Map StaticText texts)), Union.Unique (Union.Map StaticText (text : texts))) => A.FromJSON (StaticTexts (text : texts)) 48 | 49 | specificStaticText :: forall texts text. Union.IsMember (StaticText text) (Union.Map StaticText texts) => StaticText text -> StaticTexts texts 50 | specificStaticText staticText = MkStaticTexts $ Union.inject $ SOP.I staticText 51 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Client/UI/Menu.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Mensam.Client.UI.Menu where 4 | 5 | import Mensam.Client.Application 6 | import Mensam.Client.Application.Event.Class 7 | import Mensam.Client.UI.Brick.Draw 8 | import Mensam.Client.UI.Brick.Events 9 | import Mensam.Client.UI.Brick.Names 10 | 11 | import Brick 12 | import Brick.Widgets.Border 13 | import Brick.Widgets.Center 14 | import Brick.Widgets.List 15 | import Control.Monad.Trans.Class 16 | import Data.Kind 17 | import Data.Sequence qualified as Seq 18 | import Graphics.Vty.Input.Events 19 | import Lens.Micro.Platform 20 | 21 | menuListInitial :: GenericList ClientName Seq.Seq MenuButton 22 | menuListInitial = 23 | list 24 | ClientNameMenuList 25 | (Seq.fromList [minBound .. maxBound]) 26 | 1 27 | 28 | type MenuButton :: Type 29 | data MenuButton 30 | = MkMenuButtonLogin 31 | | MkMenuButtonRegister 32 | | MkMenuButtonSpaces 33 | deriving stock (Bounded, Enum, Eq, Ord, Read, Show) 34 | 35 | type ScreenMenuState :: Type 36 | newtype ScreenMenuState = MkScreenMenuState 37 | { _screenStateMenuList :: GenericList ClientName Seq.Seq MenuButton 38 | } 39 | makeLenses ''ScreenMenuState 40 | 41 | menuDraw :: ScreenMenuState -> [Widget ClientName] 42 | menuDraw = \case 43 | MkScreenMenuState {_screenStateMenuList = genericList} -> 44 | [ centerLayer $ 45 | borderWithLabel (txt "Menu") $ 46 | hLimit 20 $ 47 | vLimit 10 $ 48 | renderList buttonDraw True genericList 49 | , vBox 50 | [ txt title 51 | , padTop Max (padLeft Max (txt footerMenu)) 52 | ] 53 | ] 54 | where 55 | buttonDraw :: Bool -> MenuButton -> Widget n 56 | buttonDraw _selected = \case 57 | MkMenuButtonLogin -> padRight Max $ txt "Login" 58 | MkMenuButtonRegister -> padRight Max $ txt "Register" 59 | MkMenuButtonSpaces -> padRight Max $ txt "Spaces" 60 | 61 | menuHandleEvent :: BrickEvent ClientName ClientEvent -> ApplicationT (EventM ClientName ScreenMenuState) () 62 | menuHandleEvent event = 63 | case event of 64 | VtyEvent (EvKey KEsc []) -> do 65 | sendEvent ClientEventExit 66 | VtyEvent (EvKey KEnter []) -> do 67 | s <- lift get 68 | case listSelectedElement $ _screenStateMenuList s of 69 | Nothing -> pure () 70 | Just (_index, button) -> 71 | case button of 72 | MkMenuButtonLogin -> sendEvent ClientEventSwitchToScreenLogin 73 | MkMenuButtonRegister -> sendEvent ClientEventSwitchToScreenRegister 74 | MkMenuButtonSpaces -> sendEvent ClientEventSwitchToScreenSpaces 75 | VtyEvent e -> lift $ zoom screenStateMenuList $ handleListEvent e 76 | _ -> pure () 77 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Server/Server/Handler/RequestHash.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | 3 | module Mensam.Server.Server.Handler.RequestHash where 4 | 5 | import Mensam.Server.Application.LoggerCustom.Class 6 | 7 | import Control.Monad.Logger.CallStack 8 | import Control.Monad.Trans.Class 9 | import Control.Monad.Trans.Compose 10 | import Control.Monad.Trans.Control 11 | import Control.Monad.Trans.Control.Identity 12 | import Control.Monad.Trans.Reader 13 | import Data.Foldable 14 | import Data.Hashable qualified 15 | import Data.Kind 16 | import Network.Wai 17 | import Servant 18 | import Servant.Server.Internal.Delayed 19 | 20 | type Hash :: Type 21 | newtype Hash = MkHash {getHash :: Word} 22 | 23 | instance Show Hash where 24 | show hash = paddingString ++ hashString 25 | where 26 | hashString = show $ getHash hash 27 | paddingString = replicate paddingLength '0' 28 | paddingLength = maxHashLength - length hashString 29 | where 30 | maxHashLength = length $ show $ getHash $ MkHash maxBound 31 | 32 | requestHash :: Request -> Hash 33 | requestHash = MkHash . fromIntegral . Data.Hashable.hash . show 34 | 35 | type RequestHashT :: (Type -> Type) -> Type -> Type 36 | type role RequestHashT _ _ 37 | newtype RequestHashT m a = RequestHashT {unRequestHashT :: ReaderT Hash m a} 38 | deriving newtype (Applicative, Functor, Monad) 39 | deriving newtype (MonadTrans, MonadTransControl, MonadTransControlIdentity) 40 | 41 | instance MonadLoggerCustom m => MonadLogger (RequestHashT m) where 42 | monadLoggerLog loc logSource logLevel logStr = do 43 | reqHash <- toLogStr . show <$> RequestHashT ask 44 | logColorCapability <- lift colorfulLogCapability 45 | lift . monadLoggerLog loc logSource logLevel . toLogStr $ 46 | renderLogStrWithFontEffectsUnsafe logColorCapability $ 47 | fold 48 | [ withFontEffects (MkFontEffects [2, 33]) $ "#[" <> reqHash <> "]" 49 | , " " 50 | , withoutFontEffects $ toLogStr logStr 51 | ] 52 | 53 | deriving via 54 | RequestHashT ((t2 :: (Type -> Type) -> Type -> Type) m) 55 | instance 56 | MonadLoggerCustom (t2 m) => MonadLogger (ComposeT RequestHashT t2 m) 57 | 58 | runRequestHashT :: Hash -> RequestHashT m a -> m a 59 | runRequestHashT reqHash = flip runReaderT reqHash . unRequestHashT 60 | 61 | type RequestHash :: Type 62 | data RequestHash 63 | 64 | instance HasServer api context => HasServer (RequestHash :> api) context where 65 | type ServerT (RequestHash :> api) m = Hash -> ServerT api m 66 | hoistServerWithContext Proxy pc nt s = hoistServerWithContext (Proxy @api) pc nt . s 67 | route Proxy context subserver = route (Proxy @api) context $ passToServer subserver requestHash 68 | -------------------------------------------------------------------------------- /server/source/library/Mensam/API/Data/User.hs: -------------------------------------------------------------------------------- 1 | module Mensam.API.Data.User where 2 | 3 | import Mensam.API.Aeson 4 | import Mensam.API.Aeson.StaticText 5 | import Mensam.API.Pretty 6 | 7 | import Data.Aeson qualified as A 8 | import Data.Int 9 | import Data.Kind 10 | import Data.Text qualified as T 11 | import Data.Time qualified as T 12 | import Deriving.Aeson qualified as A 13 | import GHC.Generics 14 | import Servant.API qualified as Servant 15 | import Text.Email.OrphanInstances () 16 | 17 | type UserAuthenticated :: Type 18 | data UserAuthenticated = MkUserAuthenticated 19 | { userAuthenticatedId :: IdentifierUser 20 | , userAuthenticatedSession :: Maybe IdentifierSession 21 | } 22 | deriving stock (Eq, Generic, Ord, Read, Show) 23 | deriving 24 | (A.FromJSON, A.ToJSON) 25 | via A.CustomJSON (JSONSettings "Mk" "userAuthenticated") UserAuthenticated 26 | 27 | type IdentifierUser :: Type 28 | newtype IdentifierUser = MkIdentifierUser {unIdentifierUser :: Int64} 29 | deriving stock (Eq, Generic, Ord, Read, Show) 30 | deriving newtype (A.FromJSON, A.ToJSON) 31 | deriving newtype (Servant.FromHttpApiData, Servant.ToHttpApiData) 32 | 33 | instance ToPrettyText IdentifierUser where 34 | toPrettyText = ("#" <>) . T.pack . show . unIdentifierUser 35 | 36 | deriving via PrettyHtml5ViaPrettyText IdentifierUser instance ToPrettyHtml5 IdentifierUser 37 | 38 | type Session :: Type 39 | data Session = MkSession 40 | { sessionId :: IdentifierSession 41 | , sessionTimeCreated :: T.UTCTime 42 | , sessionTimeExpired :: Maybe T.UTCTime 43 | } 44 | deriving stock (Eq, Generic, Ord, Read, Show) 45 | deriving 46 | (A.FromJSON, A.ToJSON) 47 | via A.CustomJSON (JSONSettings "Mk" "session") Session 48 | 49 | type IdentifierSession :: Type 50 | newtype IdentifierSession = MkIdentifierSession {unIdentifierSession :: Int64} 51 | deriving stock (Eq, Generic, Ord, Read, Show) 52 | deriving newtype (A.FromJSON, A.ToJSON) 53 | 54 | type ConfirmationSecret :: Type 55 | newtype ConfirmationSecret = MkConfirmationSecret {unConfirmationSecret :: T.Text} 56 | deriving stock (Eq, Generic, Ord, Read, Show) 57 | deriving newtype (A.FromJSON, A.ToJSON) 58 | 59 | type ErrorBasicAuth :: Type 60 | data ErrorBasicAuth 61 | = MkErrorBasicAuthUsername 62 | | MkErrorBasicAuthPassword 63 | | MkErrorBasicAuthIndefinite 64 | deriving stock (Eq, Generic, Ord, Read, Show) 65 | deriving 66 | (A.FromJSON, A.ToJSON) 67 | via A.CustomJSON (JSONSettings "MkErrorBasicAuth" "") ErrorBasicAuth 68 | 69 | type ErrorBearerAuth :: Type 70 | newtype ErrorBearerAuth = MkErrorBearerAuth {unErrorBearerAuth :: StaticText "indefinite"} 71 | deriving stock (Eq, Generic, Ord, Read, Show) 72 | deriving newtype (A.FromJSON, A.ToJSON) 73 | -------------------------------------------------------------------------------- /frontend/source/Mensam/Api/ConfirmationRequest.elm: -------------------------------------------------------------------------------- 1 | module Mensam.Api.ConfirmationRequest exposing (..) 2 | 3 | import Http 4 | import Json.Decode as Decode 5 | import Mensam.Auth.Bearer 6 | import Mensam.Http.Tracker 7 | import Mensam.Url 8 | 9 | 10 | type alias Request = 11 | { jwt : Mensam.Auth.Bearer.Jwt 12 | } 13 | 14 | 15 | type Response 16 | = Success 17 | | ErrorAuth Mensam.Auth.Bearer.Error 18 | 19 | 20 | request : Maybe Mensam.Http.Tracker.Tracker -> Mensam.Url.BaseUrl -> Request -> (Result Http.Error Response -> a) -> Cmd a 21 | request tracker baseUrl body handleResult = 22 | Http.request 23 | { method = "POST" 24 | , headers = 25 | [ Mensam.Auth.Bearer.authorizationHeader body.jwt 26 | ] 27 | , url = 28 | Mensam.Url.absolute baseUrl 29 | [ "api" 30 | , "confirmation" 31 | , "request" 32 | ] 33 | [] 34 | , body = Http.emptyBody 35 | , expect = Http.expectStringResponse handleResult responseResult 36 | , timeout = Nothing 37 | , tracker = Maybe.map Mensam.Http.Tracker.toHttp tracker 38 | } 39 | 40 | 41 | responseResult : Http.Response String -> Result Http.Error Response 42 | responseResult httpResponse = 43 | case httpResponse of 44 | Http.BadUrl_ err -> 45 | Err <| Http.BadUrl err 46 | 47 | Http.Timeout_ -> 48 | Err <| Http.Timeout 49 | 50 | Http.NetworkError_ -> 51 | Err <| Http.NetworkError 52 | 53 | Http.BadStatus_ metadata body -> 54 | case metadata.statusCode of 55 | 401 -> 56 | case Decode.decodeString Mensam.Auth.Bearer.http401BodyDecoder body of 57 | Ok error -> 58 | Ok <| ErrorAuth error 59 | 60 | Err err -> 61 | Err <| Http.BadBody <| Decode.errorToString err 62 | 63 | status -> 64 | Err <| Http.BadStatus status 65 | 66 | Http.GoodStatus_ metadata body -> 67 | case metadata.statusCode of 68 | 200 -> 69 | case Decode.decodeString decodeBody200 body of 70 | Ok () -> 71 | Ok Success 72 | 73 | Err err -> 74 | Err <| Http.BadBody <| Decode.errorToString err 75 | 76 | status -> 77 | Err <| Http.BadStatus status 78 | 79 | 80 | decodeBody200 : Decode.Decoder () 81 | decodeBody200 = 82 | Decode.map (\_ -> ()) 83 | (Decode.field "unit" <| Decode.list <| Decode.succeed ()) 84 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Server/Server/Err404.hs: -------------------------------------------------------------------------------- 1 | module Mensam.Server.Server.Err404 where 2 | 3 | import Mensam.Server.Application.Configured.Class 4 | import Mensam.Server.Configuration 5 | import Mensam.Server.Configuration.BaseUrl 6 | 7 | import Control.Monad.Logger.CallStack 8 | import Data.ByteString.Builder 9 | import Network.HTTP.Types.Status 10 | import Network.Wai 11 | import Network.Wai.Trans 12 | import Text.Blaze.Html.Renderer.Utf8 13 | import Text.Blaze.Html5 qualified as H 14 | import Text.Blaze.Html5.Attributes as HA 15 | 16 | application404 :: 17 | (MonadConfigured m, MonadLogger m) => 18 | ApplicationT m 19 | application404 _req rsp = do 20 | html404' <- html404 21 | logInfo "Serve generic 404 page." 22 | rsp . responseBuilder status404 [(,) "Content-Type" "text/html"] $ 23 | lazyByteString $ 24 | renderHtml html404' 25 | 26 | html404 :: 27 | MonadConfigured m => 28 | m H.Html 29 | html404 = do 30 | baseUrl <- configBaseUrl <$> configuration 31 | maybeRevision <- configRevision <$> configuration 32 | pure $ H.docTypeHtml H.! HA.lang "en" $ do 33 | H.head $ do 34 | H.meta H.! HA.charset "UTF-8" 35 | H.meta H.! HA.name "description" H.! content "Mensam did not find, what you were looking for." 36 | H.meta H.! HA.name "viewport" H.! content "width=500" 37 | H.title "Mensam 404" 38 | H.link 39 | H.! HA.rel "icon" 40 | H.! HA.type_ "image/png" 41 | H.! HA.sizes "32x32" 42 | H.! HA.href (H.textValue $ displayBaseUrl baseUrl <> "/favicon.png") 43 | H.link 44 | H.! HA.rel "icon" 45 | H.! HA.type_ "image/png" 46 | H.! HA.sizes "192x192" 47 | H.! HA.href (H.textValue $ displayBaseUrl baseUrl <> "/favicon-192x192.png") 48 | H.link 49 | H.! HA.rel "icon" 50 | H.! HA.type_ "image/png" 51 | H.! HA.sizes "512x512" 52 | H.! HA.href (H.textValue $ displayBaseUrl baseUrl <> "/favicon-512x512.png") 53 | H.link 54 | H.! HA.rel "apple-touch-icon" 55 | H.! HA.type_ "image/png" 56 | H.! HA.sizes "512x512" 57 | H.! HA.href (H.textValue $ displayBaseUrl baseUrl <> "/favicon-512x512.png") 58 | H.link 59 | H.! HA.rel "stylesheet" 60 | H.! HA.type_ "text/css" 61 | H.! HA.href (H.textValue $ displayBaseUrl baseUrl <> "/stylesheet.css") 62 | H.body $ do 63 | H.h1 "404" 64 | H.h2 "You got lost?" 65 | H.p $ "Try starting " <> (H.a H.! HA.href (H.textValue (displayBaseUrl baseUrl)) $ "here") <> "." 66 | case maybeRevision of 67 | Nothing -> pure () 68 | Just revision -> 69 | H.p $ do 70 | "This happened on revision " 71 | H.code $ H.text revision 72 | "." 73 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Server/Application.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | 3 | module Mensam.Server.Application where 4 | 5 | import Mensam.Server.Application.Configured 6 | import Mensam.Server.Application.Configured.Class 7 | import Mensam.Server.Application.Email 8 | import Mensam.Server.Application.Email.Class 9 | import Mensam.Server.Application.Environment 10 | import Mensam.Server.Application.Environment.Acquisition 11 | import Mensam.Server.Application.Environment.Class 12 | import Mensam.Server.Application.LoggerCustom 13 | import Mensam.Server.Application.LoggerCustom.Class 14 | import Mensam.Server.Application.Secret 15 | import Mensam.Server.Application.Secret.Class 16 | import Mensam.Server.Application.SeldaPool 17 | import Mensam.Server.Application.SeldaPool.Class 18 | 19 | import Control.Monad.Base 20 | import Control.Monad.Catch 21 | import Control.Monad.IO.Unlift 22 | import Control.Monad.Logger.CallStack 23 | import Control.Monad.Trans.Class 24 | import Control.Monad.Trans.Compose.Stack 25 | import Control.Monad.Trans.Control 26 | import Control.Monad.Trans.Control.Identity 27 | import Data.Foldable 28 | import Data.Kind 29 | 30 | type Transformers :: Stack 31 | type Transformers = 32 | NilT 33 | :.|> EnvironmentT 34 | :.|> CustomLoggingT 35 | :.|> ConfiguredT 36 | :.|> SeldaPoolT 37 | :.|> SecretT 38 | :.|> EmailT 39 | 40 | type ApplicationT :: (Type -> Type) -> Type -> Type 41 | type role ApplicationT _ _ 42 | newtype ApplicationT m a = ApplicationT {unApplicationT :: StackT Transformers m a} 43 | deriving newtype (Applicative, Functor, Monad) 44 | deriving newtype (MonadTrans, MonadTransControl, MonadTransControlIdentity) 45 | deriving newtype (MonadBase b, MonadBaseControl b, MonadBaseControlIdentity b) 46 | deriving newtype (MonadIO, MonadUnliftIO) 47 | deriving newtype (MonadThrow, MonadCatch, MonadMask) 48 | deriving newtype (MonadEnvironment) 49 | deriving newtype (MonadLogger, MonadLoggerCustom) 50 | deriving newtype (MonadConfigured) 51 | deriving newtype (MonadSeldaPool) 52 | deriving newtype (MonadSecret) 53 | deriving newtype (MonadEmail) 54 | 55 | runApplicationT :: 56 | (MonadBaseControlIdentity IO m, MonadMask m, MonadUnliftIO m) => 57 | ApplicationT m a -> 58 | m a 59 | runApplicationT app = do 60 | (env, preLog) <- runWriterLoggingT $ do 61 | logInfo "Startup." 62 | acquireEnvironment 63 | 64 | let runTransformers = 65 | RunNilT 66 | :..> runEnvironmentT env 67 | :..> runAppCustomLoggingT 68 | . (traverse_ logLine preLog >>) 69 | :..> runAppConfiguredT 70 | :..> runSeldaPoolT 71 | :..> runAppSecretT 72 | :..> runAppEmailT 73 | 74 | runStackT runTransformers $ unApplicationT app 75 | -------------------------------------------------------------------------------- /frontend/source/Mensam/Error/Incorporation.elm: -------------------------------------------------------------------------------- 1 | module Mensam.Error.Incorporation exposing (..) 2 | 3 | import Dict 4 | import Mensam.Error 5 | import Time 6 | 7 | 8 | type IncorporatedErrors 9 | = MkIncorporatedErrors (Dict.Dict Int (List Mensam.Error.Error)) 10 | 11 | 12 | init : IncorporatedErrors 13 | init = 14 | MkIncorporatedErrors Dict.empty 15 | 16 | 17 | incorporate : Time.Posix -> Mensam.Error.Error -> IncorporatedErrors -> IncorporatedErrors 18 | incorporate time error (MkIncorporatedErrors incorporated) = 19 | let 20 | f maybeErrors = 21 | case maybeErrors of 22 | Nothing -> 23 | Just [ error ] 24 | 25 | Just errors -> 26 | Just <| error :: errors 27 | in 28 | MkIncorporatedErrors <| Dict.update (Time.posixToMillis time) f incorporated 29 | 30 | 31 | select : 32 | Maybe { now : Time.Posix, millisIntoThePast : Int } 33 | -> IncorporatedErrors 34 | -> 35 | List 36 | { error : Mensam.Error.Error 37 | , time : Time.Posix 38 | } 39 | select maybeTimeRange (MkIncorporatedErrors incorporated) = 40 | let 41 | isInTimeRange ( millis, _ ) = 42 | case maybeTimeRange of 43 | Nothing -> 44 | True 45 | 46 | Just { now, millisIntoThePast } -> 47 | Time.posixToMillis now - millis <= millisIntoThePast 48 | 49 | takeWhile : (a -> Bool) -> List a -> List a 50 | takeWhile p ls = 51 | case ls of 52 | [] -> 53 | [] 54 | 55 | x :: xs -> 56 | if p x then 57 | x :: takeWhile p xs 58 | 59 | else 60 | [] 61 | 62 | flattenTimeMultiples : 63 | List ( Int, List Mensam.Error.Error ) 64 | -> List ( Int, Mensam.Error.Error ) 65 | flattenTimeMultiples ls = 66 | case ls of 67 | [] -> 68 | [] 69 | 70 | ( n, errs ) :: rest -> 71 | List.map (\err -> ( n, err )) (List.reverse errs) ++ flattenTimeMultiples rest 72 | 73 | toOutputFormat : 74 | ( Int, Mensam.Error.Error ) 75 | -> 76 | { error : Mensam.Error.Error 77 | , time : Time.Posix 78 | } 79 | toOutputFormat ( n, err ) = 80 | { error = err 81 | , time = Time.millisToPosix n 82 | } 83 | in 84 | List.map toOutputFormat <| 85 | flattenTimeMultiples <| 86 | takeWhile isInTimeRange <| 87 | List.reverse <| 88 | Dict.toList incorporated 89 | -------------------------------------------------------------------------------- /frontend/source/Mensam/Http/Tracker.elm: -------------------------------------------------------------------------------- 1 | module Mensam.Http.Tracker exposing 2 | ( State 3 | , Tracker 4 | , clear 5 | , init 6 | , register 7 | , toHttp 8 | ) 9 | 10 | import Http 11 | 12 | 13 | {-| A token to identify a tracked HTTP request. 14 | -} 15 | type Tracker 16 | = MkTracker Int 17 | 18 | 19 | {-| Track registered and cancelled HTTP requests. 20 | -} 21 | type State 22 | = MkState 23 | { cancelled : Int 24 | , registered : Int 25 | } 26 | 27 | 28 | init : State 29 | init = 30 | MkState 31 | { cancelled = 0 32 | , registered = 0 33 | } 34 | 35 | 36 | {-| We are using an explicit maximum tracker to avoid integer overflow. 37 | -} 38 | maxTracker : Tracker 39 | maxTracker = 40 | MkTracker 32767 41 | 42 | 43 | {-| Cancel all registered HTTP requests. 44 | -} 45 | clear : State -> ( State, Cmd msg ) 46 | clear (MkState state) = 47 | ( MkState { state | cancelled = state.registered } 48 | , Cmd.batch <| 49 | List.map (Http.cancel << toHttp << MkTracker) <| 50 | if state.registered >= state.cancelled then 51 | List.range state.cancelled (state.registered - 1) 52 | 53 | else 54 | List.concat 55 | [ List.range state.cancelled 56 | (case maxTracker of 57 | MkTracker n -> 58 | n 59 | ) 60 | , List.range 61 | 0 62 | (state.registered - 1) 63 | ] 64 | ) 65 | 66 | 67 | {-| Register a new HTTP request. 68 | -} 69 | register : 70 | State 71 | -> (Tracker -> Cmd msg) 72 | -> ( State, Cmd msg ) 73 | register oldState useTracker = 74 | let 75 | ( state, tracker ) = 76 | newTracker oldState 77 | in 78 | ( state, useTracker tracker ) 79 | 80 | 81 | {-| Add a new tracker to `State`. 82 | -} 83 | newTracker : State -> ( State, Tracker ) 84 | newTracker (MkState state) = 85 | ( MkState 86 | { state 87 | | registered = 88 | modBy 89 | (case maxTracker of 90 | MkTracker n -> 91 | n + 1 92 | ) 93 | <| 94 | state.registered 95 | + 1 96 | } 97 | , MkTracker state.registered 98 | ) 99 | 100 | 101 | {-| Convert a `Tracker` to a type that is compatible with the elm/http library. 102 | -} 103 | toHttp : Tracker -> String 104 | toHttp (MkTracker n) = 105 | "tracker_registered_" ++ String.fromInt n 106 | -------------------------------------------------------------------------------- /frontend/source/Mensam/Widget/Month.elm: -------------------------------------------------------------------------------- 1 | module Mensam.Widget.Month exposing (..) 2 | 3 | import Element 4 | import Element.Background 5 | import Element.Events.Pointer 6 | import Html.Attributes 7 | import Mensam.Time 8 | 9 | 10 | type Model 11 | = MkModel 12 | { year : Mensam.Time.Year 13 | , month : Mensam.Time.Month 14 | } 15 | 16 | 17 | type Message 18 | = PreviousMonth 19 | | NextMonth 20 | 21 | 22 | elementPickMonth : Model -> Element.Element Message 23 | elementPickMonth (MkModel model) = 24 | Element.el 25 | [ Element.width <| Element.px 230 26 | , Element.height <| Element.px 40 27 | , Element.spaceEvenly 28 | , Element.htmlAttribute <| Html.Attributes.style "user-select" "none" 29 | ] 30 | <| 31 | Element.row 32 | [ Element.width Element.fill 33 | , Element.height Element.fill 34 | ] 35 | [ Element.el 36 | [ Element.width <| Element.px 40 37 | , Element.height <| Element.px 40 38 | , Element.htmlAttribute <| Html.Attributes.style "cursor" "pointer" 39 | , Element.mouseOver 40 | [ Element.Background.color <| Element.rgba 1 1 1 0.1 41 | ] 42 | , Element.Events.Pointer.onClick <| \_ -> PreviousMonth 43 | ] 44 | <| 45 | Element.el 46 | [ Element.centerX 47 | , Element.centerY 48 | ] 49 | <| 50 | Element.text "<" 51 | , Element.el 52 | [ Element.width <| Element.fill 53 | , Element.height <| Element.fill 54 | ] 55 | <| 56 | Element.el 57 | [ Element.centerX 58 | , Element.centerY 59 | ] 60 | <| 61 | Element.text <| 62 | Mensam.Time.yearToString model.year 63 | ++ ", " 64 | ++ Mensam.Time.monthToString model.month 65 | , Element.el 66 | [ Element.width <| Element.px 35 67 | , Element.height <| Element.px 35 68 | , Element.htmlAttribute <| Html.Attributes.style "cursor" "pointer" 69 | , Element.mouseOver 70 | [ Element.Background.color <| Element.rgba 1 1 1 0.1 71 | ] 72 | , Element.Events.Pointer.onClick <| \_ -> NextMonth 73 | ] 74 | <| 75 | Element.el 76 | [ Element.centerX 77 | , Element.centerY 78 | ] 79 | <| 80 | Element.text ">" 81 | ] 82 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Server/Application/LoggerCustom/Class.hs: -------------------------------------------------------------------------------- 1 | module Mensam.Server.Application.LoggerCustom.Class where 2 | 3 | import Control.Monad.Logger.CallStack 4 | import Control.Monad.Trans.Class 5 | import Control.Monad.Trans.Compose 6 | import Control.Monad.Trans.Elevator 7 | import Data.Foldable 8 | import Data.Kind 9 | import Data.List qualified as L 10 | import Data.String 11 | import GHC.Generics 12 | 13 | type MonadLoggerCustom :: (Type -> Type) -> Constraint 14 | class MonadLogger m => MonadLoggerCustom m where 15 | colorfulLogCapability :: m Bool 16 | 17 | instance 18 | ( MonadTrans t 19 | , MonadLoggerCustom m 20 | ) => 21 | MonadLoggerCustom (Elevator t m) 22 | where 23 | colorfulLogCapability = lift colorfulLogCapability 24 | 25 | deriving via 26 | Elevator t1 ((t2 :: (Type -> Type) -> Type -> Type) m) 27 | instance 28 | {-# OVERLAPPABLE #-} 29 | ( MonadTrans t1 30 | , MonadLoggerCustom (t2 m) 31 | ) => 32 | MonadLoggerCustom (ComposeT t1 t2 m) 33 | 34 | withoutFontEffects :: LogStr -> LogStrWithFontEffects 35 | withoutFontEffects logStr = MkLogStrWithFontEffectsUnsafe [Left logStr] 36 | 37 | withFontEffects :: FontEffects -> LogStr -> LogStrWithFontEffects 38 | withFontEffects fontEffects logStr = MkLogStrWithFontEffectsUnsafe [Right (logStr, fontEffects)] 39 | 40 | type LogStrWithFontEffects :: Type 41 | newtype LogStrWithFontEffects = MkLogStrWithFontEffectsUnsafe {unLogStrWithFontEffects :: [Either LogStr (LogStr, FontEffects)]} 42 | deriving stock (Eq, Show) 43 | deriving newtype (Semigroup, Monoid) 44 | 45 | instance IsString LogStrWithFontEffects where 46 | fromString = MkLogStrWithFontEffectsUnsafe . (: []) . Left . toLogStr 47 | 48 | type FontEffects :: Type 49 | newtype FontEffects = MkFontEffects {unFontEffects :: [Int]} 50 | deriving stock (Eq, Generic, Ord, Read, Show) 51 | 52 | renderLogStrWithFontEffectsUnsafe :: Bool -> LogStrWithFontEffects -> LogStr 53 | renderLogStrWithFontEffectsUnsafe colorCapability = \case 54 | MkLogStrWithFontEffectsUnsafe [] -> "" 55 | MkLogStrWithFontEffectsUnsafe (part : parts) -> 56 | let 57 | renderedPart = 58 | case part of 59 | Left logStr -> logStr 60 | Right (logStr, fontEffects) -> 61 | if colorCapability 62 | then wrapLogStrWithFontEffects fontEffects logStr 63 | else logStr 64 | renderedParts = renderLogStrWithFontEffectsUnsafe colorCapability $ MkLogStrWithFontEffectsUnsafe parts 65 | in 66 | renderedPart <> renderedParts 67 | where 68 | wrapLogStrWithFontEffects :: FontEffects -> LogStr -> LogStr 69 | wrapLogStrWithFontEffects fontEffects str = 70 | fold 71 | [ "\ESC[" <> fontEffectsRendered <> "m" 72 | , str 73 | , "\ESC[0m" 74 | ] 75 | where 76 | fontEffectsRendered = toLogStr $ fold $ L.intersperse ";" $ show <$> 0 : unFontEffects fontEffects 77 | -------------------------------------------------------------------------------- /server/source/library/Mensam/API/Aeson/StaticText/Internal/Union.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {-# OPTIONS_GHC -Wno-operator-whitespace #-} 3 | 4 | -- | This module is heavily inspired by servant's Servant.Api.Uverb.Union. 5 | module Mensam.API.Aeson.StaticText.Internal.Union where 6 | 7 | import Data.Kind 8 | import Data.SOP.BasicFunctors (I) 9 | import Data.SOP.NS 10 | import Data.Type.Bool (If) 11 | import Data.Type.Equality (type (==)) 12 | import GHC.TypeLits 13 | 14 | type Union :: [Type] -> Type 15 | type Union = NS I 16 | 17 | -- * Stuff stolen from 'Data.WorldPeace" but for generics-sop 18 | 19 | -- (this could to go sop-core, except it's probably too specialized to the servant use-case.) 20 | 21 | type IsMember :: u -> [u] -> Constraint 22 | type IsMember (a :: u) (as :: [u]) = (Unique as, CheckElemIsMember a as, UElem a as) 23 | 24 | type UElem :: k -> [k] -> Constraint 25 | class UElem x xs where 26 | inject :: f x -> NS f xs 27 | eject :: NS f xs -> Maybe (f x) 28 | 29 | instance {-# OVERLAPPING #-} UElem x (x ': xs) where 30 | inject = Z 31 | eject (Z x) = Just x 32 | eject _ = Nothing 33 | 34 | instance {-# OVERLAPPING #-} UElem x xs => UElem x (x' ': xs) where 35 | inject = S . inject 36 | eject (Z _) = Nothing 37 | eject (S ns) = eject ns 38 | 39 | -- | Check whether @a@ is in given type-level list. 40 | -- This will throw a nice error if the element is not in the list. 41 | type CheckElemIsMember :: k -> [k] -> Constraint 42 | type family CheckElemIsMember (a :: k) (as :: [k]) :: Constraint where 43 | CheckElemIsMember a as = 44 | If (Elem a as) (() :: Constraint) (TypeError (NoElementError a as)) 45 | 46 | type NoElementError :: k -> [k] -> ErrorMessage 47 | type NoElementError (r :: k) (rs :: [k]) = 48 | 'Text "Expected one of:" 49 | ':$$: 'Text " " ':<>: 'ShowType rs 50 | ':$$: 'Text "But got:" 51 | ':$$: 'Text " " ':<>: 'ShowType r 52 | 53 | type DuplicateElementError :: [k] -> ErrorMessage 54 | type DuplicateElementError (rs :: [k]) = 55 | 'Text "Duplicate element in list:" 56 | ':$$: 'Text " " ':<>: 'ShowType rs 57 | 58 | type Elem :: k -> [k] -> Bool 59 | type family Elem (x :: k) (xs :: [k]) :: Bool where 60 | Elem x (x ': _) = 'True 61 | Elem x (_ ': xs) = Elem x xs 62 | Elem _ '[] = 'False 63 | 64 | -- | Check whether all values in a type-level list are distinct. 65 | -- This will throw a nice error if there are any duplicate elements in the list. 66 | type Unique :: [k] -> Constraint 67 | type family Unique xs :: Constraint where 68 | Unique xs = If (Nubbed xs == 'True) (() :: Constraint) (TypeError (DuplicateElementError xs)) 69 | 70 | type Nubbed :: [k] -> Bool 71 | type family Nubbed xs :: Bool where 72 | Nubbed '[] = 'True 73 | Nubbed (x ': xs) = If (Elem x xs) 'False (Nubbed xs) 74 | 75 | type Map :: (a -> b) -> [a] -> [b] 76 | type family Map f xs where 77 | Map _ '[] = '[] 78 | Map f (x : xs) = f x : Map f xs 79 | -------------------------------------------------------------------------------- /frontend/source/Element/Events/Pointer.elm: -------------------------------------------------------------------------------- 1 | module Element.Events.Pointer exposing (Event, onClick, onDown, onEnter, onLeave, onMove, onUp) 2 | 3 | import Element 4 | import Html.Events.Extra.Mouse 5 | import Html.Events.Extra.Pointer 6 | 7 | 8 | type alias Event = 9 | { isPrimary : Bool 10 | , clientPos : { x : Float, y : Float } 11 | , offsetPos : { x : Float, y : Float } 12 | , pagePos : { x : Float, y : Float } 13 | , screenPos : { x : Float, y : Float } 14 | } 15 | 16 | 17 | onClick : (Event -> msg) -> Element.Attribute msg 18 | onClick handler = 19 | Element.htmlAttribute <| Html.Events.Extra.Mouse.onClick <| handler << translateMouseEvent 20 | 21 | 22 | onDown : (Event -> msg) -> Element.Attribute msg 23 | onDown handler = 24 | Element.htmlAttribute <| Html.Events.Extra.Pointer.onDown <| handler << translatePointerEvent 25 | 26 | 27 | onUp : (Event -> msg) -> Element.Attribute msg 28 | onUp handler = 29 | Element.htmlAttribute <| Html.Events.Extra.Pointer.onUp <| handler << translatePointerEvent 30 | 31 | 32 | onEnter : (Event -> msg) -> Element.Attribute msg 33 | onEnter handler = 34 | Element.htmlAttribute <| Html.Events.Extra.Pointer.onEnter <| handler << translatePointerEvent 35 | 36 | 37 | onLeave : (Event -> msg) -> Element.Attribute msg 38 | onLeave handler = 39 | Element.htmlAttribute <| Html.Events.Extra.Pointer.onLeave <| handler << translatePointerEvent 40 | 41 | 42 | onMove : (Event -> msg) -> Element.Attribute msg 43 | onMove handler = 44 | Element.htmlAttribute <| Html.Events.Extra.Pointer.onMove <| handler << translatePointerEvent 45 | 46 | 47 | translateMouseEvent : Html.Events.Extra.Mouse.Event -> Event 48 | translateMouseEvent event = 49 | { isPrimary = True 50 | , clientPos = 51 | case event.clientPos of 52 | ( x, y ) -> 53 | { x = x, y = y } 54 | , offsetPos = 55 | case event.offsetPos of 56 | ( x, y ) -> 57 | { x = x, y = y } 58 | , pagePos = 59 | case event.pagePos of 60 | ( x, y ) -> 61 | { x = x, y = y } 62 | , screenPos = 63 | case event.screenPos of 64 | ( x, y ) -> 65 | { x = x, y = y } 66 | } 67 | 68 | 69 | translatePointerEvent : Html.Events.Extra.Pointer.Event -> Event 70 | translatePointerEvent event = 71 | { isPrimary = event.isPrimary 72 | , clientPos = 73 | case event.pointer.clientPos of 74 | ( x, y ) -> 75 | { x = x, y = y } 76 | , offsetPos = 77 | case event.pointer.offsetPos of 78 | ( x, y ) -> 79 | { x = x, y = y } 80 | , pagePos = 81 | case event.pointer.pagePos of 82 | ( x, y ) -> 83 | { x = x, y = y } 84 | , screenPos = 85 | case event.pointer.screenPos of 86 | ( x, y ) -> 87 | { x = x, y = y } 88 | } 89 | -------------------------------------------------------------------------------- /frontend/source/TimeZone/Extra.elm: -------------------------------------------------------------------------------- 1 | module TimeZone.Extra exposing (zones) 2 | 3 | import Dict 4 | import Time 5 | import TimeZone 6 | 7 | 8 | zones : Dict.Dict String (() -> Time.Zone) 9 | zones = 10 | let 11 | aliases = 12 | regions1 ++ regions2 13 | 14 | additions = 15 | List.map (\( key, value ) -> ( key, \() -> value )) 16 | etcZones 17 | in 18 | List.foldl alias (List.foldl insertTuple TimeZone.zones additions) aliases 19 | 20 | 21 | insertTuple : ( comparable, v ) -> Dict.Dict comparable v -> Dict.Dict comparable v 22 | insertTuple ( key, value ) dict = 23 | Dict.insert key value dict 24 | 25 | 26 | alias : ( comparable, comparable ) -> Dict.Dict comparable v -> Dict.Dict comparable v 27 | alias ( aliasKey, originalKey ) dict = 28 | case Dict.get originalKey dict of 29 | Nothing -> 30 | dict 31 | 32 | Just value -> 33 | Dict.insert aliasKey value dict 34 | 35 | 36 | regions1 : List ( String, String ) 37 | regions1 = 38 | [ ( "CET", "Europe/Paris" ) 39 | , ( "EET", "Europe/Sofia" ) 40 | , ( "EST", "America/Cancun" ) 41 | , ( "HST", "Pacific/Honolulu" ) 42 | , ( "MET", "Europe/Paris" ) 43 | , ( "MST", "America/Phoenix" ) 44 | , ( "WET", "Europe/Lisbon" ) 45 | ] 46 | 47 | 48 | regions2 : List ( String, String ) 49 | regions2 = 50 | [ ( "CST6CDT", "America/Chicago" ) 51 | , ( "EST5EDT", "America/New_York" ) 52 | , ( "MST7MDT", "America/Denver" ) 53 | , ( "PST8PDT", "America/Los_Angeles" ) 54 | ] 55 | 56 | 57 | etcZones : List ( String, Time.Zone ) 58 | etcZones = 59 | let 60 | simpleZone offset = 61 | Time.customZone (offset * 60) [] 62 | in 63 | [ ( "Etc/GMT", simpleZone 0 ) 64 | , ( "Etc/GMT-14", simpleZone -14 ) 65 | , ( "Etc/GMT-13", simpleZone -13 ) 66 | , ( "Etc/GMT-12", simpleZone -12 ) 67 | , ( "Etc/GMT-11", simpleZone -11 ) 68 | , ( "Etc/GMT-10", simpleZone -10 ) 69 | , ( "Etc/GMT-9", simpleZone -9 ) 70 | , ( "Etc/GMT-8", simpleZone -8 ) 71 | , ( "Etc/GMT-7", simpleZone -7 ) 72 | , ( "Etc/GMT-6", simpleZone -6 ) 73 | , ( "Etc/GMT-5", simpleZone -5 ) 74 | , ( "Etc/GMT-4", simpleZone -4 ) 75 | , ( "Etc/GMT-3", simpleZone -3 ) 76 | , ( "Etc/GMT-2", simpleZone -2 ) 77 | , ( "Etc/GMT-1", simpleZone -1 ) 78 | , ( "Etc/GMT+0", simpleZone 0 ) 79 | , ( "Etc/GMT+1", simpleZone 1 ) 80 | , ( "Etc/GMT+2", simpleZone 2 ) 81 | , ( "Etc/GMT+3", simpleZone 3 ) 82 | , ( "Etc/GMT+4", simpleZone 4 ) 83 | , ( "Etc/GMT+5", simpleZone 5 ) 84 | , ( "Etc/GMT+6", simpleZone 6 ) 85 | , ( "Etc/GMT+7", simpleZone 7 ) 86 | , ( "Etc/GMT+8", simpleZone 8 ) 87 | , ( "Etc/GMT+9", simpleZone 9 ) 88 | , ( "Etc/GMT+10", simpleZone 10 ) 89 | , ( "Etc/GMT+11", simpleZone 11 ) 90 | , ( "Etc/GMT+12", simpleZone 12 ) 91 | , ( "Etc/UTC", simpleZone 0 ) 92 | ] 93 | -------------------------------------------------------------------------------- /frontend/source/Mensam/Api/PictureDelete.elm: -------------------------------------------------------------------------------- 1 | module Mensam.Api.PictureDelete exposing (..) 2 | 3 | import Http 4 | import Json.Decode as Decode 5 | import Mensam.Auth.Bearer 6 | import Mensam.Http.Tracker 7 | import Mensam.Url 8 | 9 | 10 | type alias Request = 11 | { jwt : Mensam.Auth.Bearer.Jwt 12 | } 13 | 14 | 15 | type Response 16 | = Success 17 | | ErrorAuth Mensam.Auth.Bearer.Error 18 | 19 | 20 | request : Maybe Mensam.Http.Tracker.Tracker -> Mensam.Url.BaseUrl -> Request -> (Result Http.Error Response -> a) -> Cmd a 21 | request tracker baseUrl body handleResult = 22 | Http.request 23 | { method = "DELETE" 24 | , headers = 25 | [ Mensam.Auth.Bearer.authorizationHeader body.jwt 26 | ] 27 | , url = 28 | Mensam.Url.absolute baseUrl 29 | [ "api" 30 | , "picture" 31 | ] 32 | [] 33 | , body = Http.emptyBody 34 | , expect = Http.expectStringResponse handleResult responseResult 35 | , timeout = Nothing 36 | , tracker = Maybe.map Mensam.Http.Tracker.toHttp tracker 37 | } 38 | 39 | 40 | responseResult : Http.Response String -> Result Http.Error Response 41 | responseResult httpResponse = 42 | case httpResponse of 43 | Http.BadUrl_ err -> 44 | Err <| Http.BadUrl err 45 | 46 | Http.Timeout_ -> 47 | Err <| Http.Timeout 48 | 49 | Http.NetworkError_ -> 50 | Err <| Http.NetworkError 51 | 52 | Http.BadStatus_ metadata body -> 53 | case metadata.statusCode of 54 | 401 -> 55 | case Decode.decodeString Mensam.Auth.Bearer.http401BodyDecoder body of 56 | Ok error -> 57 | Ok <| ErrorAuth error 58 | 59 | Err err -> 60 | Err <| Http.BadBody <| Decode.errorToString err 61 | 62 | status -> 63 | Err <| Http.BadStatus status 64 | 65 | Http.GoodStatus_ metadata body -> 66 | case metadata.statusCode of 67 | 200 -> 68 | case Decode.decodeString decodeBody200 body of 69 | Ok () -> 70 | Ok <| Success 71 | 72 | Err err -> 73 | Err <| Http.BadBody <| Decode.errorToString err 74 | 75 | status -> 76 | Err <| Http.BadStatus status 77 | 78 | 79 | decodeBody200 : Decode.Decoder () 80 | decodeBody200 = 81 | Decode.string 82 | |> Decode.andThen 83 | (\string -> 84 | case string of 85 | "Deleted profile picture." -> 86 | Decode.succeed () 87 | 88 | _ -> 89 | Decode.fail <| "Unexpected HTTP 200 message: " ++ string 90 | ) 91 | -------------------------------------------------------------------------------- /frontend/source/Mensam/Screen/Landing.elm: -------------------------------------------------------------------------------- 1 | module Mensam.Screen.Landing exposing (..) 2 | 3 | import Element 4 | import Element.Font 5 | import Mensam.Element.Button 6 | import Mensam.Element.Color 7 | 8 | 9 | type alias Model = 10 | () 11 | 12 | 13 | init : Model 14 | init = 15 | () 16 | 17 | 18 | element : Model -> Element.Element Message 19 | element () = 20 | Element.el 21 | [ Element.Font.color <| Mensam.Element.Color.bright.white Mensam.Element.Color.Opaque100 22 | , Element.Font.size 16 23 | , Element.width Element.fill 24 | , Element.height Element.fill 25 | ] 26 | <| 27 | Element.column 28 | [ Element.spacing 20 29 | , Element.centerX 30 | , Element.centerY 31 | , Element.width <| Element.maximum 300 Element.fill 32 | ] 33 | [ Element.el 34 | [ Element.Font.size 40 35 | , Element.Font.extraLight 36 | , Element.Font.italic 37 | , Element.Font.color <| Mensam.Element.Color.bright.yellow Mensam.Element.Color.Opaque100 38 | , Element.centerX 39 | ] 40 | <| 41 | Element.text "Mensam" 42 | , Element.el 43 | [ Element.Font.size 18 44 | , Element.Font.extraLight 45 | , Element.centerX 46 | ] 47 | <| 48 | Element.paragraph 49 | [] 50 | [ Element.text "A Desk-Booking Application." ] 51 | , Element.el 52 | [ Element.width Element.fill 53 | ] 54 | <| 55 | Element.row 56 | [ Element.width Element.fill 57 | , Element.spacing 30 58 | ] 59 | [ Mensam.Element.Button.button <| 60 | Mensam.Element.Button.MkButton 61 | { attributes = [ Element.width Element.fill ] 62 | , color = Mensam.Element.Button.Yellow 63 | , enabled = True 64 | , label = Element.text "Sign up" 65 | , message = Just <| MessageEffect Register 66 | , size = Mensam.Element.Button.Medium 67 | } 68 | , Mensam.Element.Button.button <| 69 | Mensam.Element.Button.MkButton 70 | { attributes = [ Element.width Element.fill ] 71 | , color = Mensam.Element.Button.Yellow 72 | , enabled = True 73 | , label = Element.text "Sign in" 74 | , message = Just <| MessageEffect Login 75 | , size = Mensam.Element.Button.Medium 76 | } 77 | ] 78 | ] 79 | 80 | 81 | type Message 82 | = MessageEffect MessageEffect 83 | 84 | 85 | type MessageEffect 86 | = Login 87 | | Register 88 | -------------------------------------------------------------------------------- /server/source/library/Mensam/Client/OrphanInstances.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | 3 | module Mensam.Client.OrphanInstances where 4 | 5 | import Mensam.API.Route.Api.User 6 | 7 | import Data.Base64.Types qualified as Base64 8 | import Data.ByteString qualified as B 9 | import Data.Kind 10 | import Data.Proxy 11 | import Data.Sequence 12 | import Data.Text qualified as T 13 | import Data.Text.Encoding qualified as T 14 | import Data.Text.Encoding.Base64 qualified as T 15 | import GHC.Generics 16 | import Network.HTTP.Types 17 | import Servant.API hiding (BasicAuth, Header) 18 | import Servant.Auth 19 | import Servant.Auth.JWT.WithSession 20 | import Servant.Client 21 | import Servant.Client.Core qualified as Core 22 | 23 | type AuthData :: [Type] -> Type 24 | type role AuthData nominal 25 | data AuthData xs :: Type where 26 | DataBasicAuth :: Credentials -> AuthData (BasicAuth ': auths) 27 | DataJWT :: Jwt -> AuthData (JWT ': auths) 28 | DataJWTWithSession :: Jwt -> AuthData (JWTWithSession ': auths) 29 | DataCookie :: Cookies -> AuthData (Cookie ': auths) 30 | DataNextAuth :: AuthData xs -> AuthData (x ': xs) 31 | 32 | instance HasClient m api => HasClient m (Auth auths a :> api) where 33 | type Client m (Auth auths a :> api) = AuthData auths -> Client m api 34 | clientWithRoute Proxy Proxy req = \case 35 | DataBasicAuth credentials -> 36 | clientWithRoute (Proxy @m) (Proxy @api) $ 37 | req {Core.requestHeaders = credentialsAuthorizationHeader credentials <| Core.requestHeaders req} 38 | DataJWT token -> 39 | clientWithRoute (Proxy @m) (Proxy @api) $ 40 | req {Core.requestHeaders = jwTokenAuthorizationHeader token <| Core.requestHeaders req} 41 | DataJWTWithSession token -> 42 | clientWithRoute (Proxy @m) (Proxy @api) $ 43 | req {Core.requestHeaders = jwTokenAuthorizationHeader token <| Core.requestHeaders req} 44 | DataCookie cookies -> 45 | clientWithRoute (Proxy @m) (Proxy @api) $ 46 | req {Core.requestHeaders = cookiesCookieHeader cookies <| Core.requestHeaders req} 47 | DataNextAuth (otherAuthData :: AuthData otherAuths) -> 48 | clientWithRoute (Proxy @m) (Proxy @(Auth otherAuths a :> api)) req otherAuthData 49 | hoistClientMonad Proxy Proxy f cl arg = 50 | hoistClientMonad (Proxy @m) (Proxy :: Proxy api) f (cl arg) 51 | 52 | type Credentials :: Type 53 | data Credentials = MkCredentials {credentialsUsername :: T.Text, credentialsPassword :: T.Text} 54 | deriving stock (Eq, Generic, Ord, Read, Show) 55 | 56 | credentialsAuthorizationHeader :: Credentials -> Header 57 | credentialsAuthorizationHeader MkCredentials {credentialsUsername, credentialsPassword} = 58 | (hAuthorization,) $ ("Basic " <>) $ T.encodeUtf8 $ Base64.extractBase64 $ T.encodeBase64 $ credentialsUsername <> ":" <> credentialsPassword 59 | 60 | jwTokenAuthorizationHeader :: Jwt -> Header 61 | jwTokenAuthorizationHeader MkJwt {unJwt = jwt} = 62 | (hAuthorization,) $ ("Bearer " <>) $ T.encodeUtf8 jwt 63 | 64 | type Cookies :: Type 65 | newtype Cookies = MkCookies {unCookies :: B.ByteString} 66 | deriving stock (Eq, Generic, Ord, Read, Show) 67 | 68 | cookiesCookieHeader :: Cookies -> Header 69 | cookiesCookieHeader MkCookies {unCookies} = (hCookie, unCookies) 70 | -------------------------------------------------------------------------------- /frontend/source/Mensam/Element/Font.elm: -------------------------------------------------------------------------------- 1 | module Mensam.Element.Font exposing (..) 2 | 3 | import Element 4 | import Element.Font 5 | 6 | 7 | font : Font -> List (Element.Attribute msg) 8 | font x = 9 | [ Element.Font.family 10 | [ case x of 11 | SansSerif _ -> 12 | sansSerif 13 | 14 | Condensed _ -> 15 | condensed 16 | 17 | Monospace400 -> 18 | monospace 19 | 20 | Monospace500 -> 21 | monospace 22 | 23 | Monospace700 -> 24 | monospace 25 | ] 26 | , case x of 27 | SansSerif { italic } -> 28 | if italic then 29 | Element.Font.italic 30 | 31 | else 32 | Element.Font.unitalicized 33 | 34 | Condensed { italic } -> 35 | if italic then 36 | Element.Font.italic 37 | 38 | else 39 | Element.Font.unitalicized 40 | 41 | Monospace400 -> 42 | Element.Font.unitalicized 43 | 44 | Monospace500 -> 45 | Element.Font.unitalicized 46 | 47 | Monospace700 -> 48 | Element.Font.unitalicized 49 | , case x of 50 | SansSerif { weight } -> 51 | fontWeight weight 52 | 53 | Condensed { weight } -> 54 | fontWeight weight 55 | 56 | Monospace400 -> 57 | fontWeight Regular400 58 | 59 | Monospace500 -> 60 | fontWeight Medium500 61 | 62 | Monospace700 -> 63 | fontWeight Bold700 64 | ] 65 | 66 | 67 | fontWeight : Weight -> Element.Attribute msg 68 | fontWeight weight = 69 | case weight of 70 | Hairline100 -> 71 | Element.Font.hairline 72 | 73 | ExtraLight200 -> 74 | Element.Font.extraLight 75 | 76 | Light300 -> 77 | Element.Font.light 78 | 79 | Regular400 -> 80 | Element.Font.regular 81 | 82 | Medium500 -> 83 | Element.Font.medium 84 | 85 | SemiBold600 -> 86 | Element.Font.semiBold 87 | 88 | Bold700 -> 89 | Element.Font.bold 90 | 91 | ExtraBold800 -> 92 | Element.Font.extraBold 93 | 94 | Heavy900 -> 95 | Element.Font.heavy 96 | 97 | 98 | type Font 99 | = SansSerif 100 | { weight : Weight 101 | , italic : Bool 102 | } 103 | | Condensed 104 | { weight : Weight 105 | , italic : Bool 106 | } 107 | | Monospace400 108 | | Monospace500 109 | | Monospace700 110 | 111 | 112 | type Weight 113 | = Hairline100 114 | | ExtraLight200 115 | | Light300 116 | | Regular400 117 | | Medium500 118 | | SemiBold600 119 | | Bold700 120 | | ExtraBold800 121 | | Heavy900 122 | 123 | 124 | sansSerif : Element.Font.Font 125 | sansSerif = 126 | Element.Font.typeface "Fira Sans" 127 | 128 | 129 | condensed : Element.Font.Font 130 | condensed = 131 | Element.Font.typeface "Fira Sans Condensed" 132 | 133 | 134 | monospace : Element.Font.Font 135 | monospace = 136 | Element.Font.typeface "Fira Mono" 137 | -------------------------------------------------------------------------------- /frontend/source/Mensam/Url.elm: -------------------------------------------------------------------------------- 1 | module Mensam.Url exposing 2 | ( BaseUrl 3 | , absolute 4 | , decoder 5 | , full 6 | , mockUnsafe 7 | , parsePrefix 8 | ) 9 | 10 | import Json.Decode as Decode 11 | import Url.Builder 12 | import Url.Parser exposing (()) 13 | 14 | 15 | type BaseUrl 16 | = MkBaseUrl 17 | { scheme : String 18 | , authority : 19 | Maybe 20 | { host : String 21 | , port_ : Maybe Int 22 | } 23 | , path : List String 24 | } 25 | 26 | 27 | decoder : Decode.Decoder BaseUrl 28 | decoder = 29 | Decode.map3 (\scheme authority path -> MkBaseUrl { scheme = scheme, authority = authority, path = path }) 30 | (Decode.field "scheme" Decode.string) 31 | (Decode.field "authority" <| 32 | Decode.nullable <| 33 | Decode.map2 (\host port_ -> { host = host, port_ = port_ }) 34 | (Decode.field "host" Decode.string) 35 | (Decode.field "port" <| Decode.nullable Decode.int) 36 | ) 37 | (Decode.field "path" (Decode.list Decode.string)) 38 | 39 | 40 | full : BaseUrl -> List String -> List Url.Builder.QueryParameter -> Maybe String -> String 41 | full (MkBaseUrl baseUrl) pathPieces queryParameters anchor = 42 | let 43 | root = 44 | Url.Builder.CrossOrigin <| 45 | String.concat 46 | [ baseUrl.scheme 47 | , ":" 48 | , case baseUrl.authority of 49 | Nothing -> 50 | "" 51 | 52 | Just authority -> 53 | String.concat 54 | [ "//" 55 | , authority.host 56 | , case authority.port_ of 57 | Nothing -> 58 | "" 59 | 60 | Just port_ -> 61 | ":" ++ String.fromInt port_ 62 | ] 63 | ] 64 | 65 | path = 66 | baseUrl.path ++ pathPieces 67 | in 68 | Url.Builder.custom root path queryParameters anchor 69 | 70 | 71 | absolute : BaseUrl -> List String -> List Url.Builder.QueryParameter -> String 72 | absolute (MkBaseUrl baseUrl) pathPieces queryParameters = 73 | Url.Builder.absolute (baseUrl.path ++ pathPieces) queryParameters 74 | 75 | 76 | parsePrefix : BaseUrl -> Url.Parser.Parser a a 77 | parsePrefix (MkBaseUrl baseUrl) = 78 | let 79 | go pathPieces = 80 | case pathPieces of 81 | [] -> 82 | Url.Parser.top 83 | 84 | p :: ps -> 85 | Url.Parser.s p go ps 86 | in 87 | go baseUrl.path 88 | 89 | 90 | mockUnsafe : BaseUrl 91 | mockUnsafe = 92 | MkBaseUrl 93 | { scheme = "https" 94 | , authority = 95 | Just 96 | { host = "mens.am" 97 | , port_ = Nothing 98 | } 99 | , path = [] 100 | } 101 | -------------------------------------------------------------------------------- /server/source/library/Servant/Auth/OrphanInstances.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | 3 | module Servant.Auth.OrphanInstances () where 4 | 5 | import Control.Lens 6 | import Data.HashMap.Strict.InsOrd qualified as HM 7 | import Data.OpenApi 8 | import Data.Proxy 9 | import Data.Text qualified as T 10 | import Servant.API 11 | import Servant.Auth qualified 12 | import Servant.Auth.JWT.WithSession 13 | import Servant.OpenApi 14 | 15 | instance HasOpenApi api => HasOpenApi (Servant.Auth.Auth '[] a :> api) where 16 | toOpenApi Proxy = toOpenApi $ Proxy @api 17 | 18 | instance HasOpenApi (Servant.Auth.Auth auths a :> api) => HasOpenApi (Servant.Auth.Auth (Servant.Auth.BasicAuth : auths) a :> api) where 19 | toOpenApi Proxy = addSecurity $ toOpenApi $ Proxy @(Servant.Auth.Auth auths a :> api) 20 | where 21 | addSecurity = addSecurityRequirement identifier . addSecurityScheme identifier securityScheme 22 | identifier :: T.Text = "BasicAuth" 23 | securityScheme = 24 | SecurityScheme 25 | { _securitySchemeType = SecuritySchemeHttp HttpSchemeBasic 26 | , _securitySchemeDescription = Just "Basic Authentication" 27 | } 28 | 29 | instance HasOpenApi (Servant.Auth.Auth auths a :> api) => HasOpenApi (Servant.Auth.Auth (Servant.Auth.JWT : auths) a :> api) where 30 | toOpenApi Proxy = addSecurity $ toOpenApi $ Proxy @(Servant.Auth.Auth auths a :> api) 31 | where 32 | addSecurity = addSecurityRequirement identifier . addSecurityScheme identifier securityScheme 33 | identifier :: T.Text = "JWT" 34 | securityScheme = 35 | SecurityScheme 36 | { _securitySchemeType = SecuritySchemeHttp $ HttpSchemeBearer $ Just "JWT" 37 | , _securitySchemeDescription = Just "Bearer Authentication" 38 | } 39 | 40 | instance HasOpenApi (Servant.Auth.Auth auths a :> api) => HasOpenApi (Servant.Auth.Auth (JWTWithSession : auths) a :> api) where 41 | toOpenApi Proxy = toOpenApi $ Proxy @(Servant.Auth.Auth (Servant.Auth.JWT : auths) a :> api) 42 | 43 | instance HasOpenApi (Servant.Auth.Auth auths a :> api) => HasOpenApi (Servant.Auth.Auth (Servant.Auth.Cookie : auths) a :> api) where 44 | toOpenApi Proxy = addSecurity $ toOpenApi $ Proxy @(Servant.Auth.Auth auths a :> api) 45 | where 46 | addSecurity = addSecurityRequirement identifier . addSecurityScheme identifier securityScheme 47 | identifier :: T.Text = "Cookie" 48 | securityScheme = 49 | SecurityScheme 50 | { _securitySchemeType = SecuritySchemeHttp $ HttpSchemeBearer $ Just "JWT" 51 | , _securitySchemeDescription = Just "Cookie Authentication" 52 | } 53 | 54 | addSecurityScheme :: T.Text -> SecurityScheme -> OpenApi -> OpenApi 55 | addSecurityScheme securityIdentifier securityScheme openApi = 56 | openApi 57 | { _openApiComponents = 58 | (_openApiComponents openApi) 59 | { _componentsSecuritySchemes = 60 | _componentsSecuritySchemes (_openApiComponents openApi) 61 | <> SecurityDefinitions (HM.singleton securityIdentifier securityScheme) 62 | } 63 | } 64 | 65 | addSecurityRequirement :: T.Text -> OpenApi -> OpenApi 66 | addSecurityRequirement securityRequirement = 67 | allOperations 68 | . security 69 | %~ ((SecurityRequirement $ HM.singleton securityRequirement []) :) 70 | --------------------------------------------------------------------------------