diff --git a/backend/src/ElmskellTypes.hs b/backend/app/ElmskellTypes.hs similarity index 100% rename from backend/src/ElmskellTypes.hs rename to backend/app/ElmskellTypes.hs diff --git a/elm.json b/elm.json new file mode 100644 index 0000000..de6a82a --- /dev/null +++ b/elm.json @@ -0,0 +1,37 @@ +{ + "type": "application", + "source-directories": [ + "src" + ], + "elm-version": "0.19.1", + "dependencies": { + "direct": { + "NoRedInk/elm-json-decode-pipeline": "1.0.1", + "bartavelle/json-helpers": "2.0.2", + "elm/browser": "1.0.2", + "elm/core": "1.0.5", + "elm/html": "1.0.0", + "elm/json": "1.1.3", + "elm/time": "1.0.0", + "elm/url": "1.0.0", + "lobanov/elm-localstorage": "1.0.1", + "rtfeldman/elm-css": "18.0.0", + "rtfeldman/elm-iso8601-date-strings": "1.1.4" + }, + "indirect": { + "elm/bytes": "1.0.8", + "elm/file": "1.0.5", + "elm/http": "2.0.0", + "elm/parser": "1.1.0", + "elm/random": "1.0.0", + "elm/virtual-dom": "1.0.3", + "lobanov/elm-taskport": "2.0.1", + "robinheghan/murmur3": "1.0.0", + "rtfeldman/elm-hex": "1.0.0" + } + }, + "test-dependencies": { + "direct": {}, + "indirect": {} + } +} diff --git a/elmskell-frontend.nix b/elmskell-frontend.nix new file mode 100644 index 0000000..6e4cf90 --- /dev/null +++ b/elmskell-frontend.nix @@ -0,0 +1,34 @@ +{ + esbuild, + stdenv, + elmPackages, + ... +}: let + elmConfig = elmPackages.fetchElmDeps { + elmPackages = import ./frontend/elm-srcs.nix; + elmVersion = "0.19.1"; + registryDat = ./frontend/registry.dat; + }; +in + stdenv.mkDerivation { + pname = "elmskell-backend"; + version = "0.1.0"; + src = ./frontend; + nativeBuildInputs = [ + esbuild + elmPackages.elm + ]; + buildInputs = [ + ]; + configurePhase = '' + ${elmConfig} + ''; + buildPhase = '' + elm make src/Main.elm --optimize --output=tmp.js + esbuild tmp.js --minify --target=es5 --outfile=main.js + ''; + installPhase = '' + mkdir -p $out + cp main.js $out/main.js + ''; + } diff --git a/flake.lock b/flake.lock new file mode 100644 index 0000000..190eaf7 --- /dev/null +++ b/flake.lock @@ -0,0 +1,26 @@ +{ + "nodes": { + "nixpkgs": { + "locked": { + "lastModified": 1748708770, + "narHash": "sha256-q8jG2HJWgooWa9H0iatZqBPF3bp0504e05MevFmnFLY=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "a59eb7800787c926045d51b70982ae285faa2346", + "type": "github" + }, + "original": { + "id": "nixpkgs", + "ref": "nixos-25.05", + "type": "indirect" + } + }, + "root": { + "inputs": { + "nixpkgs": "nixpkgs" + } + } + }, + "root": "root", + "version": 7 +} diff --git a/flake.nix b/flake.nix new file mode 100644 index 0000000..957e8e0 --- /dev/null +++ b/flake.nix @@ -0,0 +1,14 @@ +{ + inputs = { + nixpkgs.url = "nixpkgs/nixos-25.05"; + }; + outputs = {nixpkgs, ...}: let + system = "x86_64-linux"; + pkgs = nixpkgs.legacyPackages.${system}; + in { + packages.${system} = { + default = pkgs.callPackage ./package.nix {}; + frontend = pkgs.callPackage ./elmskell-frontend.nix {}; + }; + }; +} diff --git a/frontend/elm-srcs.nix b/frontend/elm-srcs.nix new file mode 100644 index 0000000..6f3f95d --- /dev/null +++ b/frontend/elm-srcs.nix @@ -0,0 +1,102 @@ +{ + + "NoRedInk/elm-json-decode-pipeline" = { + sha256 = "1k241pjz1wj5rqv95f1j86msa0s0p6w4v8n0jn26aw6cbadw363b"; + version = "1.0.1"; + }; + + "bartavelle/json-helpers" = { + sha256 = "0k96qra2nq1j4j4ahfl98dkpkc6f2831mq5d5xxg27mp31qwq5nn"; + version = "2.0.2"; + }; + + "elm/browser" = { + sha256 = "0nagb9ajacxbbg985r4k9h0jadqpp0gp84nm94kcgbr5sf8i9x13"; + version = "1.0.2"; + }; + + "elm/core" = { + sha256 = "19w0iisdd66ywjayyga4kv2p1v9rxzqjaxhckp8ni6n8i0fb2dvf"; + version = "1.0.5"; + }; + + "elm/html" = { + sha256 = "1n3gpzmpqqdsldys4ipgyl1zacn0kbpc3g4v3hdpiyfjlgh8bf3k"; + version = "1.0.0"; + }; + + "elm/json" = { + sha256 = "0kjwrz195z84kwywaxhhlnpl3p251qlbm5iz6byd6jky2crmyqyh"; + version = "1.1.3"; + }; + + "elm/time" = { + sha256 = "0vch7i86vn0x8b850w1p69vplll1bnbkp8s383z7pinyg94cm2z1"; + version = "1.0.0"; + }; + + "elm/url" = { + sha256 = "0av8x5syid40sgpl5vd7pry2rq0q4pga28b4yykn9gd9v12rs3l4"; + version = "1.0.0"; + }; + + "lobanov/elm-localstorage" = { + sha256 = "00n3hk6gzrg637n4vfwk7arbj78bppqjn0mcnl7yp2ypva971dia"; + version = "1.0.1"; + }; + + "rtfeldman/elm-css" = { + sha256 = "1gwhgqwclc7clk1ns4qqzyn7b4wvcmccg9qavvb8m694qmwlkzjy"; + version = "18.0.0"; + }; + + "rtfeldman/elm-iso8601-date-strings" = { + sha256 = "1ah491kgyicgvy1c9myylqvhzb7ya9kgmn0hcsv23ymvqgaf6b1a"; + version = "1.1.4"; + }; + + "elm/bytes" = { + sha256 = "02ywbf52akvxclpxwj9n04jydajcbsbcbsnjs53yjc5lwck3abwj"; + version = "1.0.8"; + }; + + "elm/file" = { + sha256 = "1rljcb41dl97myidyjih2yliyzddkr2m7n74x7gg46rcw4jl0ny8"; + version = "1.0.5"; + }; + + "elm/http" = { + sha256 = "008bs76mnp48b4dw8qwjj4fyvzbxvlrl4xpa2qh1gg2kfwyw56v1"; + version = "2.0.0"; + }; + + "elm/parser" = { + sha256 = "0a3cxrvbm7mwg9ykynhp7vjid58zsw03r63qxipxp3z09qks7512"; + version = "1.1.0"; + }; + + "elm/random" = { + sha256 = "138n2455wdjwa657w6sjq18wx2r0k60ibpc4frhbqr50sncxrfdl"; + version = "1.0.0"; + }; + + "elm/virtual-dom" = { + sha256 = "1yvb8px2z62xd578ag2q0r5hd1vkz9y7dfkx05355iiy1d7jwq4v"; + version = "1.0.3"; + }; + + "lobanov/elm-taskport" = { + sha256 = "16vf3k80sicmhnr1k2nmdc9713ips7nyaxzjzkb6w8mi5w4qsmc0"; + version = "2.0.1"; + }; + + "robinheghan/murmur3" = { + sha256 = "15asmgr2zqh7rkywrg5647rpdqkpzxk02v5qc6ndj60jza3gsmjk"; + version = "1.0.0"; + }; + + "rtfeldman/elm-hex" = { + sha256 = "1y0aa16asvwdqmgbskh5iba6psp43lkcjjw9mgzj3gsrg33lp00d"; + version = "1.0.0"; + }; +} diff --git a/frontend/registry.dat b/frontend/registry.dat new file mode 100644 index 0000000..8067038 Binary files /dev/null and b/frontend/registry.dat differ diff --git a/justfile b/justfile deleted file mode 100644 index 123d885..0000000 --- a/justfile +++ /dev/null @@ -1,32 +0,0 @@ -produce: produce-elm haskell - echo "REMEMBER to RESTART elmskell.service TO UPDATE SITE IN PLACE" - echo "REMEMBER to RUN sudo iptables-apply -t 60 /etc/iptables/iptables.rules IF YOU HAVEN'T SINCE RESTART" - -types: haskell - rm -rf frontend/src/ElmskellTypes/Generated - stack exec ~/.local/bin/hs-server-exe - -compile: elm haskell - -run: produce exec - -exec: - stack exec ~/.local/bin/hs-server-exe - -haskell: - cd backend && stack install - -elm: - cd frontend && elm make src/Main.elm --output=../assets/js/main.js - rm -rf frontend/elm-stuff - -produce-elm: - cd frontend && elm make src/Main.elm --optimize --output=tmp.js - mv frontend/tmp.js assets/js/tmp.js - rm -rf frontend/elm-stuff - rm assets/js/main.js - esbuild assets/js/tmp.js --minify --target=es5 --outfile=assets/js/main.js - rm assets/js/tmp.js - -format-elm: - elm-format frontend/src/Main.elm --yes diff --git a/package.nix b/package.nix new file mode 100644 index 0000000..5810f12 --- /dev/null +++ b/package.nix @@ -0,0 +1,53 @@ +{ + esbuild, + elmPackages, + haskellPackages, + stdenv, + ... +}: let + ghcExeOptions = "-Wall -Wcompact -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N"; + ghcPackages = p: [ + p.aeson + p.blaze-html + p.blaze-markup + p.directory + p.elm-street + p.http-types + p.scotty + p.text + p.wai-extra + p.warp + ]; + elmConfig = elmPackages.fetchElmDeps { + elmPackages = import ./frontend/elm-srcs.nix; + elmVersion = "0.19.1"; + registryDat = ./frontend/registry.dat; + }; +in + stdenv.mkDerivation { + pname = "elmskell"; + version = "0.1.0"; + src = ./src; + nativeBuildInputs = [ + esbuild + (haskellPackages.ghcWithPackages ghcPackages) + elmPackages.elm + ]; + buildInputs = [ + ]; + configurePhase = '' + ${elmConfig} + ''; + buildPhase = '' + ghc -v ${ghcExeOptions} ./Main.hs -o ./main + elm make ./Main.elm --optimize --output=tmp.js + esbuild ./tmp.js --minify --target=es5 --outfile=main.js + ''; + installPhase = '' + mkdir -p $out/bin + mkdir -p $out/src + cp ./main $out/bin/elmskell + cp ./main.js $out/src/main.js + cp ./init.js $out/src/init.js + ''; + } diff --git a/result b/result new file mode 120000 index 0000000..90c41cf --- /dev/null +++ b/result @@ -0,0 +1 @@ +/nix/store/afnd25aqbkrr55z46pld1yg1fdnv893w-elmskell-0.1.0 \ No newline at end of file diff --git a/shell.nix b/shell.nix deleted file mode 100644 index 859347a..0000000 --- a/shell.nix +++ /dev/null @@ -1,27 +0,0 @@ -{pkgs ? import {}}: let - elmInputs = [ - pkgs.elmPackages.elm - pkgs.elmPackages.elm-format - pkgs.esbuild - ]; - haskellInputs = [ - pkgs.stack - ]; - buildTools = [ - pkgs.just - ]; - cliTools = [ - pkgs.httpie - pkgs.ungoogled-chromium - ]; -in - pkgs.mkShell { - buildInputs = [ - elmInputs - haskellInputs - ]; - packages = [ - buildTools - cliTools - ]; - } diff --git a/src/ElmskellTypes.hs b/src/ElmskellTypes.hs new file mode 100644 index 0000000..dc36597 --- /dev/null +++ b/src/ElmskellTypes.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE TypeApplications #-} + +module ElmskellTypes (generateElmskellTypes) where + +import Data.Aeson (ToJSON (..), FromJSON (..)) +import Elm +import GHC.Generics + +data Command + = ClearCommand + | ColorsCommand + | CookiesCommand + | DebugCommand + | FontCommand + | HelloCommand + | HelpCommand + | PromptCommand + | ThemeCommand + | TodoCommand + deriving (Generic) + deriving (Elm, ToJSON, FromJSON) via ElmStreet Command + +data CookiesKept = CookiesKept + { cookiesKeptKeepFont :: Bool + , cookiesKeptKeepPrompt :: Bool + , cookiesKeptKeepTheme :: Bool + } deriving (Generic) + deriving (Elm, ToJSON, FromJSON) via ElmStreet CookiesKept + +data CoreColor + = Red + | Green + | Yellow + | Blue + | Magenta + | Cyan + | BrightRed + | BrightGreen + | BrightYellow + | BrightBlue + | BrightMagenta + | BrightCyan + deriving (Generic) + deriving (Elm, ToJSON, FromJSON) via ElmStreet CoreColor + +data Font = Font + { fontFontSize :: Float + } deriving (Generic) + deriving (Elm, ToJSON, FromJSON) via ElmStreet Font + +data Input = Input + { inputCommand :: Command + , inputArgs :: [String] + } + deriving (Generic) + deriving (Elm, ToJSON, FromJSON) via ElmStreet Input + +data Prompt = Prompt + { promptPrompt :: String + } deriving (Generic) + deriving (Elm, ToJSON, FromJSON) via ElmStreet Prompt + +data Theme + = Pit + | Dim + | Sky + | Sun + deriving (Generic) + deriving (Elm, ToJSON, FromJSON) via ElmStreet Theme + +data ThemeColor + = Background + | Foreground + | Cursor + | Black + | White + | BrightBlack + | BrightWhite + deriving (Generic) + deriving (Elm, ToJSON, FromJSON) via ElmStreet ThemeColor + +type Types = + '[Command + , CookiesKept + , CoreColor + , Font + , Input + , Prompt + , Theme + , ThemeColor + ] + +generateElmskellTypes :: IO () +generateElmskellTypes = generateElm @Types $ defaultSettings "frontend/src" ["ElmskellTypes", "Generated"] diff --git a/src/Main.elm b/src/Main.elm deleted file mode 120000 index 0e01ba0..0000000 --- a/src/Main.elm +++ /dev/null @@ -1 +0,0 @@ -../frontend/src/Main.elm \ No newline at end of file diff --git a/src/Main.elm b/src/Main.elm new file mode 100644 index 0000000..7ef05a4 --- /dev/null +++ b/src/Main.elm @@ -0,0 +1,1173 @@ +port module Main exposing (..) + +import Browser +import Browser.Dom as Dom +import Browser.Navigation as Nav +import Css exposing (..) +import ElmskellTypes.Generated.Decoder exposing (..) +import ElmskellTypes.Generated.ElmStreet exposing (..) +import ElmskellTypes.Generated.Encoder exposing (..) +import ElmskellTypes.Generated.Types exposing (..) +import Html.Styled exposing (Attribute, Html, styled, text, toUnstyled) +import Html.Styled.Attributes exposing (id, value) +import Html.Styled.Events exposing (onInput) +import Json.Decode as D +import Json.Encode as E +import Task +import Url + + + +-- MAIN + + +main : Program E.Value Model Msg +main = + Browser.application + { init = init + , view = view + , update = update + , subscriptions = subscriptions + , onUrlChange = UrlChanged + , onUrlRequest = LinkClicked + } + + + +-- MODEL + + +type alias Model = + { key : Nav.Key + , url : Url.Url + , theme : Theme + , font : Font + , cookiesKept : CookiesKept + , prompt : Prompt + , content : List (Html Msg) + , cliContent : String + } + + +defaultCookies : + { cookiesKept : CookiesKept + , font : Font + , prompt : Prompt + , theme : Theme + } +defaultCookies = + { font = { fontSize = 20.0 } + , cookiesKept = + { keepTheme = True + , keepFont = True + , keepPrompt = True + } + , theme = Dim + , prompt = { prompt = ">" } + } + + +init : E.Value -> Url.Url -> Nav.Key -> ( Model, Cmd Msg ) +init flags url key = + let + initContent = + [ text "Welcome to my website! Pardon the alpha quality for the time being" + , text "\nRun `help` to get started" + ] + + th = + case D.decodeValue (D.field "Theme" decodeTheme) flags of + Ok val -> + val + + Err _ -> + defaultCookies.theme + + pr = + case D.decodeValue (D.field "Prompt" decodePrompt) flags of + Ok val -> + val + + Err _ -> + defaultCookies.prompt + + cK = + case D.decodeValue (D.field "CookiesKept" decodeCookiesKept) flags of + Ok val -> + val + + Err _ -> + defaultCookies.cookiesKept + + fo = + case D.decodeValue (D.field "Font" decodeFont) flags of + Ok val -> + val + + Err _ -> + defaultCookies.font + in + ( { key = key + , url = url + , theme = th + , font = fo + , cookiesKept = cK + , prompt = pr + , content = initContent + , cliContent = "" + } + , Task.attempt (\_ -> NoInitFocus) (Dom.focus "init-focus") + ) + + + +-- UPDATE + + +type Msg + = LinkClicked Browser.UrlRequest + | UrlChanged Url.Url + | TakeInput String + | NoInitFocus + | ReceivedStorage E.Value + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case msg of + LinkClicked urlRequest -> + case urlRequest of + Browser.Internal url -> + ( model, Nav.pushUrl model.key (Url.toString url) ) + + Browser.External href -> + ( model, Nav.load href ) + + UrlChanged url -> + ( { model | url = url } + , Cmd.none + ) + + TakeInput string -> + if String.endsWith "\n" string then + runCommand + { model + | cliContent = "" + , content = + model.content + ++ [ text + (if model.content /= [] then + "\n" + + else + "" + ) + , coloredText (coreColor BrightMagenta) model.prompt.prompt + , text <| String.trim string + ] + } + (parseInput string) + + else + ( { model | cliContent = string }, Cmd.none ) + + NoInitFocus -> + ( model, Cmd.none ) + + ReceivedStorage value -> + applyJSONData model value + + +applyJSONData : Model -> E.Value -> ( Model, Cmd Msg ) +applyJSONData model data = + case D.decodeValue (D.field "name" D.string) data of + Ok "Theme" -> + case D.decodeValue (D.field "data" decodeTheme) data of + Ok th -> + ( { model | theme = th }, Cmd.none ) + + Err e -> + errApplyingJSON model e + + Ok "Prompt" -> + case D.decodeValue (D.field "data" decodePrompt) data of + Ok pr -> + ( { model | prompt = pr }, Cmd.none ) + + Err e -> + errApplyingJSON model e + + Ok "Font" -> + case D.decodeValue (D.field "data" decodeFont) data of + Ok fo -> + ( { model | font = fo }, Cmd.none ) + + Err e -> + errApplyingJSON model e + + Ok _ -> + ( { model | content = model.content ++ [ text "expecting field `name` to contain type while applyJSONData" ] }, Cmd.none ) + + Err e -> + errApplyingJSON model e + + +errApplyingJSON : Model -> D.Error -> ( Model, Cmd Msg ) +errApplyingJSON model e = + ( { model | content = model.content ++ [ coloredText (coreColor Red) <| "\n" ++ D.errorToString e ] }, Cmd.none ) + + +isOK : Result x a -> Bool +isOK res = + case res of + Ok _ -> + True + + Err _ -> + False + + + +-- COMMANDS + + +parseInput : String -> Result String Input +parseInput input = + let + tokens = + List.map String.trim (String.split " " input) + + command = + case List.head tokens of + Just "help" -> + Ok HelpCommand + + Just "clear" -> + Ok ClearCommand + + Just "colors" -> + Ok ColorsCommand + + Just "cookies" -> + Ok CookiesCommand + + Just "debug" -> + Ok DebugCommand + + Just "font" -> + Ok FontCommand + + Just "hello" -> + Ok HelloCommand + + Just "prompt" -> + Ok PromptCommand + + Just "theme" -> + Ok ThemeCommand + + Just "todo" -> + Ok TodoCommand + + Just trimput -> + Err trimput + + _ -> + Err "error in parseInput parsing tokens" + + args = + case List.tail tokens of + Just tail -> + Ok <| List.filter ((/=) "") tail + + _ -> + Err "error in parseInput parsing tokens" + in + case args of + Ok arguments -> + case command of + Ok cmd -> + Ok { command = cmd, args = arguments } + + Err err -> + Err err + + Err err -> + Err err + + +runCommand : Model -> Result String Input -> ( Model, Cmd Msg ) +runCommand model input = + case input of + Ok { command, args } -> + (case command of + HelpCommand -> + runHelp + + ClearCommand -> + runClear + + ColorsCommand -> + runColors + + CookiesCommand -> + runCookies + + DebugCommand -> + runDebug + + FontCommand -> + runFont + + HelloCommand -> + runHello + + PromptCommand -> + runPrompt + + ThemeCommand -> + runTheme + + TodoCommand -> + runTodo + ) + model + args + + Err "" -> + ( model, Cmd.none ) + + Err string -> + ( { model + | content = model.content ++ [ text <| "\ncommand " ++ string ++ " not recognised. Run `help` to find a valid command" ] + } + , Cmd.none + ) + + +type alias CommandRunner = + Model -> List String -> ( Model, Cmd Msg ) + + +runHelp : CommandRunner +runHelp model args = + ( { model + | content = + model.content + ++ (if List.length args < 2 then + case List.head args of + Nothing -> + [ text <| + "\n+--------------------------------------------------+" + ++ "\n|help prints this message |" + ++ "\n|help prints more information about |" + ++ "\n+--------------------------------------------------+" + ++ "\nclear clears the screen" + ++ "\ncookies [UNSTABLE] manages cookies" + ++ "\nhello prints hello world message" + ++ "\nfont manages font" + ++ "\nprompt [UNFINISHED] manages prompt" + ++ "\ntheme manages theme" + ++ "\ntodo prints aspirations for the site" + ] + + Just "help" -> + [ text <| + "\nhelp lists available commands with a short summary" + ++ "\nhelp prints more information about " + ] + + Just "clear" -> + [ text <| "\nclear clears the screen" + ] + + Just "colors" -> + [ text "\ncolors ", coloredText (coreColor BrightCyan) "[UNIMPLEMENTED]" ] + + Just "cookies" -> + [ text <| + "\ncookies prints info about the current cookie settings" + ++ "\ncookies set [true|false] sets whether to store a certain cookie" + ++ "\noptions for are:" + ++ "\n keepFont - whether to store fontSize. Default fontSize is 20" + ++ "\n keepPrompt - whether to store prompt. Default prompt is >" + ++ "\n keepTheme - whether to store theme. Default theme is pit" + ] + + Just "hello" -> + [ text <| "\nhello prints `Hello World!`" + ] + + Just "font" -> + [ text <| + "\nfont size prints info about the current font size" + ++ "\nfont size changes fontSize to if is >0" + ++ "\nfont reset changes fontSize to the default of 20px" + ] + + Just "prompt" -> + [ text <| + "\nprompt prints info about the current prompt" + ++ "\nprompt set sets prompt text to " + ++ "\n is specified in quotes" + ++ "\nprompt color sets prompt color to " + ++ "\n run `colors` to list available colors" + ] + + Just "theme" -> + [ text <| + "\ntheme sets the current theme according to " + ++ "\nOptions for are:" + ++ "\n sun - a theme blinding like the sun" + ++ "\n sky - a toned-down light theme" + ++ "\n dim - a deep and colorful dark theme" + ++ "\n pit - nearly black like the bottom of a pit" + ] + + Just "todo" -> + [ text "\ntodo prints aspirations for the site" ] + + Just string -> + wrongArgs HelpCommand 1 args + + else + wrongArgs HelpCommand 1 args + ) + } + , Cmd.none + ) + + +runClear : CommandRunner +runClear model args = + ( case List.head args of + Nothing -> + { model | content = [] } + + Just string -> + { model | content = model.content ++ wrongArgs ClearCommand 0 args } + , Cmd.none + ) + + +runColors : CommandRunner +runColors model args = + case List.head args of + Nothing -> + ( { model | content = model.content ++ wrongArgs ColorsCommand 1 args }, Cmd.none ) + + Just "test" -> + ( { model + | content = + model.content + ++ [ coloredText (coreColor Red) "Red" ] + } + , Cmd.none + ) + + Just _ -> + ( { model | content = model.content ++ wrongArgs ColorsCommand 1 args }, Cmd.none ) + + +runCookies : CommandRunner +runCookies model args = + case List.head args of + Nothing -> + ( { model | content = model.content ++ [ text <| "\n" ++ cookiesKeptToString model.cookiesKept ] }, Cmd.none ) + + Just "set" -> + let + cookiesKept = + model.cookiesKept + + second = + case List.tail args of + Just tail -> + Maybe.withDefault "" (List.head tail) + + Nothing -> + "" + + third = + case List.tail args of + Just tail -> + case List.tail tail of + Just tail2 -> + Maybe.withDefault "" (List.head tail2) + + Nothing -> + "" + + Nothing -> + "" + in + if third == "" then + ( { model | content = model.content ++ wrongArgs CookiesCommand 3 args }, Cmd.none ) + + else + case second of + "" -> + ( { model | content = model.content ++ wrongArgs CookiesCommand 2 args }, Cmd.none ) + + "keepFont" -> + case third of + "true" -> + saveCookiesKept { model | cookiesKept = { cookiesKept | keepFont = True } } + + "false" -> + saveCookiesKept { model | cookiesKept = { cookiesKept | keepFont = False } } + + _ -> + ( { model | content = model.content ++ wrongArgs CookiesCommand 3 args }, Cmd.none ) + + "keepTheme" -> + case third of + "true" -> + saveCookiesKept { model | cookiesKept = { cookiesKept | keepTheme = True } } + + "false" -> + saveCookiesKept { model | cookiesKept = { cookiesKept | keepTheme = False } } + + _ -> + ( { model | content = model.content ++ wrongArgs CookiesCommand 3 args }, Cmd.none ) + + "keepPrompt" -> + case third of + "true" -> + saveCookiesKept { model | cookiesKept = { cookiesKept | keepPrompt = True } } + + "false" -> + saveCookiesKept { model | cookiesKept = { cookiesKept | keepPrompt = False } } + + _ -> + ( { model | content = model.content ++ wrongArgs CookiesCommand 3 args }, Cmd.none ) + + _ -> + ( { model | content = model.content ++ wrongArgs CookiesCommand 2 args }, Cmd.none ) + + Just string -> + ( { model | content = model.content ++ wrongArgs CookiesCommand 1 args }, Cmd.none ) + + +runDebug : CommandRunner +runDebug model args = + ( model, getStorage "Theme" ) + + +runHello : CommandRunner +runHello model args = + case List.head args of + Nothing -> + ( { model | content = model.content ++ [ text "\nHello World!" ] }, Cmd.none ) + + _ -> + ( { model | content = model.content ++ wrongArgs HelloCommand 0 args }, Cmd.none ) + + +runFont : CommandRunner +runFont model args = + case List.head args of + Nothing -> + ( { model | content = model.content ++ wrongArgs FontCommand 1 args }, Cmd.none ) + + Just "size" -> + let + string = + case List.tail args of + Just tail -> + Maybe.withDefault "" (List.head tail) + + Nothing -> + "" + + fl = + String.toFloat string + in + case fl of + Just float -> + if float > 0 then + let + newModel = + { model + | content = + model.content + ++ [ text <| + "\nfontSize successfully set to " + ++ string + ++ "px" + ] + , font = { fontSize = float } + } + in + saveFont newModel + + else + ( { model + | content = + model.content + ++ [ text "\nPlease enter a valid fontSize, a Float greater than 0" ] + } + , Cmd.none + ) + + Nothing -> + case string of + "" -> + ( { model | content = model.content ++ [ text <| "\nfontSize is " ++ String.fromFloat model.font.fontSize ++ "px" ] } + , Cmd.none + ) + + "reset" -> + let + newModel = + { model + | content = + model.content + ++ [ text "\nfontSize reset to 20px" ] + , font = { fontSize = 20 } + } + in + saveFont newModel + + _ -> + ( { model + | content = + model.content + ++ [ text <| + "\nfontSize " + ++ string + ++ " not recognised; font size expected" + ] + } + , Cmd.none + ) + + Just "reset" -> + let + newModel = + { model + | content = model.content ++ [ text "\nfontSize reset to 20px" ] + , font = { fontSize = 20 } + } + in + saveFont newModel + + Just string -> + ( { model | content = model.content ++ wrongArgs FontCommand 1 args }, Cmd.none ) + + +runPrompt : CommandRunner +runPrompt model args = + case List.head args of + Nothing -> + ( { model | content = model.content ++ [ text <| "\ncurrent prompt is " ++ model.prompt.prompt ] }, Cmd.none ) + + Just string -> + let + oldPrompt = + model.prompt + in + savePrompt { model | prompt = { oldPrompt | prompt = string } } + + +runTheme : CommandRunner +runTheme model args = + case List.head args of + Nothing -> + ( { model + | content = + model.content + ++ [ text <| + "\nThe current theme is " + ++ (case model.theme of + Sun -> + "sun" + + Sky -> + "sky" + + Dim -> + "dim" + + Pit -> + "pit" + ) + ] + } + , Cmd.none + ) + + Just "sun" -> + setTheme model Sun + + Just "sky" -> + setTheme model Sky + + Just "dim" -> + setTheme model Dim + + Just "pit" -> + setTheme model Pit + + Just string -> + ( { model | content = model.content ++ wrongArgs ThemeCommand 1 args }, Cmd.none ) + + +runTodo : CommandRunner +runTodo model args = + ( case List.head args of + Nothing -> + { model + | content = + model.content + ++ [ text <| + "\nIn no particular order:" + ++ "\n- Implement colors throughout existing methods" + ++ "\n- Something like Neofetch" + ++ "\n- Collect and store feedback in a database" + ++ "\n- Create a style guide for programs involving console colors" + ++ "\n- Modularise the code (to have something more elegant than a single 2k line file)" + ++ "\n- Figure out a better way to parse commands" + ++ "\n- Add cache headers" + ] + } + + Just _ -> + { model | content = model.content ++ wrongArgs TodoCommand 0 args } + , Cmd.none + ) + + + +-- COMMAND ABSTRACTIONS + + +setTheme : Model -> Theme -> ( Model, Cmd Msg ) +setTheme model theme = + let + newModel = + { model | theme = theme } + in + saveTheme newModel + + +wrongArgs : Command -> Int -> List String -> List (Html Msg) +wrongArgs command expected args = + let + comstr = + case command of + HelpCommand -> + "help" + + ClearCommand -> + "clear" + + ColorsCommand -> + "colors" + + CookiesCommand -> + "cookies" + + DebugCommand -> + "debug" + + FontCommand -> + "font" + + HelloCommand -> + "hello" + + PromptCommand -> + "prompt" + + ThemeCommand -> + "theme" + + TodoCommand -> + "todo" + in + [ text + ((if expected > List.length args then + "\nToo few arguments for " ++ comstr + + else if expected < List.length args then + "\nToo many arguments for " ++ comstr + + else + "\nUnexpected arguments " ++ listToString args + ) + ++ ". Run `help " + ++ comstr + ++ "` for usage" + ) + ] + + +listToString : List String -> String +listToString list = + "[" ++ String.join "," list ++ "]" + + +boolToString : Bool -> String +boolToString bool = + case bool of + True -> + "True" + + False -> + "False" + + +cookiesKeptToString : CookiesKept -> String +cookiesKeptToString cookiesKept = + "{ keepFont = " + ++ boolToString cookiesKept.keepFont + ++ "\n, keepPrompt = " + ++ boolToString cookiesKept.keepPrompt + ++ "\n, keepTheme = " + ++ boolToString cookiesKept.keepTheme + ++ "\n}" + + + +-- PORTS +-- sets localStorage 'cookies' to E.Value + + +port setStorage : ( String, E.Value ) -> Cmd a + + +port getStorage : String -> Cmd a + + +port receiveStorageFromJS : (E.Value -> msg) -> Sub msg + + + +-- JSON + + +saveCookiesKept : Model -> ( Model, Cmd Msg ) +saveCookiesKept model = + ( model, setStorage ( "CookiesKept", encodeCookiesKept model.cookiesKept ) ) + + +saveFont : Model -> ( Model, Cmd Msg ) +saveFont model = + ( model, setStorage ( "Font", encodeFont model.font ) ) + + +savePrompt : Model -> ( Model, Cmd Msg ) +savePrompt model = + ( model, setStorage ( "Prompt", encodePrompt model.prompt ) ) + + +saveTheme : Model -> ( Model, Cmd Msg ) +saveTheme model = + ( model, setStorage ( "Theme", encodeTheme model.theme ) ) + + +loadStorage : Model -> String -> ( Model, Cmd Msg ) +loadStorage model key = + ( model, getStorage key ) + + + +-- SUBSCRIPTIONS + + +subscriptions : Model -> Sub Msg +subscriptions model = + receiveStorageFromJS ReceivedStorage + + + +-- VIEW + + +view : Model -> Browser.Document Msg +view model = + Browser.Document "elmskell" + [ toUnstyled <| viewBody model ] + + +viewBody : Model -> Html Msg +viewBody model = + styledBody model + [] + [ styledContent model [] model.content + , styledCL + model + [] + [ styledPrompt model [] [ coloredText (coreColor BrightMagenta) model.prompt.prompt ] + , styledCLI model [ onInput TakeInput, value model.cliContent, id "init-focus" ] [] + ] + ] + + + +-- STYLES + + +allColors : Model -> List Color +allColors model = + List.map + coreColor + [ Red + , Green + , Yellow + , Blue + , Magenta + , Cyan + , BrightRed + , BrightGreen + , BrightYellow + , BrightBlue + , BrightMagenta + , BrightCyan + ] + ++ List.map + (themeColor model) + [ Background + , Foreground + , Cursor + , Black + , White + , BrightBlack + , BrightWhite + ] + + + +-- Colors from Root Loops +-- flavor: intense +-- fruit: raspberry +-- milk: each option +-- sugar: 6 +-- colors: 9 +-- sogginess: 7 + + +coreColor : CoreColor -> Color +coreColor color = + case color of + Red -> + hex "e14433" + + Green -> + hex "#359b54" + + Yellow -> + hex "#a08016" + + Blue -> + hex "#5a77f2" + + Magenta -> + hex "#cf2ec8" + + Cyan -> + hex "1894a5" + + BrightRed -> + hex "#f36552" + + BrightGreen -> + hex "#3db361" + + BrightYellow -> + hex "#b9941a" + + BrightBlue -> + hex "#7491f8" + + BrightMagenta -> + hex "#e54ede" + + BrightCyan -> + hex "#1eabbf" + + +themeColor : Model -> ThemeColor -> Color +themeColor model color = + case model.theme of + Pit -> + case color of + Background -> + hex "#120211" + + Foreground -> + hex "#f3d9f0" + + Cursor -> + themeColor model White + + Black -> + hex "#380e36" + + White -> + hex "#e29edc" + + BrightBlack -> + hex "#7c2b77" + + BrightWhite -> + hex "#f9ecf7" + + Dim -> + case color of + Background -> + hex "#380e36" + + Foreground -> + hex "#f7e5f4" + + Cursor -> + themeColor model White + + Black -> + hex "#5e1c56" + + White -> + hex "#e8b2e2" + + BrightBlack -> + hex "#9d3c98" + + BrightWhite -> + hex "#fbf4fa" + + Sky -> + case color of + Background -> + hex "#f3d9f0" + + Foreground -> + hex "#380e36" + + Cursor -> + themeColor model White + + Black -> + hex "#eec6e9" + + White -> + hex "#7c2b77" + + BrightBlack -> + hex "#d575cd" + + BrightWhite -> + hex "#120211" + + Sun -> + case color of + Background -> + hex "#f9ecf7" + + Foreground -> + hex "#5a1c56" + + Cursor -> + themeColor model White + + Black -> + hex "#f3d9f0" + + White -> + hex "#9d3c98" + + BrightBlack -> + hex "#dc8ed5" + + BrightWhite -> + hex "#380e36" + + +styledBody : Model -> List (Attribute Msg) -> List (Html Msg) -> Html Msg +styledBody model = + styled Html.Styled.main_ + [ backgroundColor <| themeColor model Background + , color <| themeColor model Foreground + , minHeight (vh 100) + , width (vw 100) + , margin (px 0) + , padding (px 0) + ] + + +styledContent : Model -> List (Attribute Msg) -> List (Html Msg) -> Html Msg +styledContent model = + styled Html.Styled.span + [ color <| themeColor model Foreground + , fontSize (px model.font.fontSize) + , padding (px 0) + , margin (px 0) + , backgroundColor <| themeColor model Background + , borderWidth (px 0) + , width (vw 100) + , whiteSpace preWrap + , fontFamily monospace + ] + + +styledCL : Model -> List (Attribute Msg) -> List (Html Msg) -> Html Msg +styledCL model = + styled Html.Styled.span + [ backgroundColor <| themeColor model Background + , padding (px 0) + , margin (px 0) + , displayFlex + , flexDirection row + , flexWrap noWrap + , justifyContent flexStart + ] + + +styledCLI : Model -> List (Attribute Msg) -> List (Html Msg) -> Html Msg +styledCLI model = + styled Html.Styled.textarea + [ color <| themeColor model Foreground + , fontSize (px model.font.fontSize) + , padding (px 0) + , margin (px 0) + , backgroundColor <| themeColor model Background + , borderWidth (px 0) + , outlineWidth (px 0) + , height (px model.font.fontSize) + , resize none + , overflow hidden + , flexGrow (Css.int 100) + ] + + +styledPrompt : Model -> List (Attribute Msg) -> List (Html Msg) -> Html Msg +styledPrompt model = + styled Html.Styled.span + [ color <| themeColor model Foreground + , fontSize (px model.font.fontSize) + , padding (px 0) + , margin (px 0) + , backgroundColor <| themeColor model Background + , borderWidth (px 0) + , height (px model.font.fontSize) + , fontFamily monospace + ] + + +coloredText : Color -> String -> Html Msg +coloredText fgColor string = + coloredTextWBackground fgColor (rgba 0 0 0 0) string + + +coloredTextWBackground : Color -> Color -> String -> Html Msg +coloredTextWBackground fgColor bgColor string = + styled Html.Styled.span + [ color fgColor + , backgroundColor bgColor + , padding (px 0) + , margin (px 0) + , borderWidth (px 0) + ] + [] + [ text string ] diff --git a/src/Main.hs b/src/Main.hs deleted file mode 120000 index d97d299..0000000 --- a/src/Main.hs +++ /dev/null @@ -1 +0,0 @@ -../backend/app/Main.hs \ No newline at end of file diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 index 0000000..e2b879a --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import ElmskellTypes +import Data.Text.Lazy (Text) +import Network.Wai.Handler.Warp (Port) +import Network.Wai.Middleware.RequestLogger (logStdoutDev) +import Text.Blaze ((!)) +import Text.Blaze.Html.Renderer.Text (renderHtml) + +import Network.HTTP.Types +import Network.Wai.Middleware.Gzip +import Web.Scotty as S + +import qualified Control.Exception as E +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as A + +-- HTML +index :: H.Html -> Text +index compiledElmApp = renderHtml $ do + H.docTypeHtml $ do + H.head $ do + H.title "TESTING Scotty+Elm" + H.meta ! A.charset "utf-8" + H.style "body{margin:0px;}" + (H.body ! A.id "body") $ do + embedJs compiledElmApp + +-- CONF +port :: Port +port = 8080 + +adminContact :: String +adminContact = "[Matrix] @mtgmonkey:calitabby.net" + +compiledElmAppFile :: AssetPath +compiledElmAppFile = "/js/main.js" + +boilerplateJsFile :: AssetPath +boilerplateJsFile = "/js/init.js" + +assetsFolder :: FilePath +assetsFolder = "/home/mtgmonkey/elmskell/assets" + +-- MAIN +main :: IO () +main = do + + generateElmskellTypes + + compiledElmAppOrExc <- E.try $ readFile $ assetsFolder ++ compiledElmAppFile :: IO (Either E.IOException String) + let compiledElmApp = case compiledElmAppOrExc of + Left e -> serverErrorReadFile e + Right contents -> H.toHtml $ contents + + boilerplateJsOrExc <- E.try $ readFile $ assetsFolder ++ boilerplateJsFile :: IO (Either E.IOException String) + let boilerplateJs = case boilerplateJsOrExc of + Left e -> serverErrorReadFile e + Right contents -> H.toHtml $ contents + + let anyRoute = regex "^.*$" + scotty port $ do + + middleware $ gzip $ def { gzipFiles = GzipCompress } + middleware logStdoutDev + + -- GET requests + get "/" $ do + shortCache + status ok200 + S.html $ index $ do + compiledElmApp + boilerplateJs + + get "/favicon.ico/" $ do + shortCache + status notFound404 + S.html $ "you want a favi-whatnow!?" + + -- ERR + notFound $ do + noCache + status methodNotAllowed405 + S.text "Verb disallowed; OR, route doesn't exist :(" + + +-- FUNC +serverErrorReadFile :: E.IOException -> Js +serverErrorReadFile e = H.toHtml $ "document.getElementById('body').innerHTML='Server-side error occurred: " + ++ (show e) + ++ "; report this to a site administrator: " + ++ adminContact + ++ "';" + +shortCache :: ActionM () +shortCache = addHeader "Cache-Control" "max-age=21600" + +noCache :: ActionM () +noCache = addHeader "Cache-Control" "no-cache" + +embedJs :: Js -> H.Html +embedJs js = H.script $ js + + -- TYPES +type AssetPath = FilePath +type Js = H.Html