summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorBen Sima <ben@bsima.me>2022-07-18 22:09:58 -0400
committerBen Sima <ben@bsima.me>2022-07-19 09:22:58 -0400
commitbc9e5b0ea863a17537987faa5a72b00efc7767d1 (patch)
treea22df5a00c29f5612a5f6885b9e6bb9a7a56d420
parentf034ad709ba0de5a2e5ec6be47523f595e381d7a (diff)
Upgrade nixpkgs, ghc923
I ended up deleting miso, and consequently all files under Hero/ and Miso/, because I couldn't get miso to build with GHC 9.2. Other things: - Niv has been wrapped by Biz/Bild/Deps.hs, so I can extend it to my liking. - Apply-refact is gone because I couldn't get it to build. - Disabled python stuff.
Diffstat
-rw-r--r--Biz/Bild.hs4
-rw-r--r--Biz/Bild.nix17
-rw-r--r--Biz/Bild/Constants.nix2
-rw-r--r--Biz/Bild/Deps.hs16
-rw-r--r--Biz/Bild/Deps.nix10
-rw-r--r--Biz/Bild/Deps/Haskell.nix3
-rw-r--r--Biz/Bild/Nixpkgs.nix7
-rw-r--r--Biz/Bild/Sources.json65
-rw-r--r--Biz/Dragons.hs14
-rw-r--r--Biz/Id.hs2
-rwxr-xr-xBiz/Ide/hooks/pre-commit4
-rwxr-xr-xBiz/Ide/version14
-rw-r--r--Biz/Lint.hs2
-rw-r--r--Biz/Namespace.hs1
-rw-r--r--Biz/Pie.hs192
-rw-r--r--Biz/Que/Host.hs4
-rw-r--r--Data/String/Quote.hs2
-rw-r--r--Hero/Core.hs939
-rw-r--r--Hero/Host.hs395
-rw-r--r--Hero/Keep.hs109
-rw-r--r--Hero/Look.hs568
-rw-r--r--Hero/Look/Typography.hs84
-rw-r--r--Hero/Node.hs248
-rw-r--r--Hero/Pack.hs16
-rw-r--r--Hero/Prod.nix57
-rw-r--r--Hero/Service.nix88
-rw-r--r--Miso/Extend.hs28
-rw-r--r--Miso/FFI/Audio.hs21
-rw-r--r--Miso/FFI/Document.hs12
-rw-r--r--Miso/FFI/Fullscreen.hs29
30 files changed, 81 insertions, 2872 deletions
diff --git a/Biz/Bild.hs b/Biz/Bild.hs
index cba5232..0e6daf4 100644
--- a/Biz/Bild.hs
+++ b/Biz/Bild.hs
@@ -232,8 +232,8 @@ data Target = Target
-- | We can't build everything yet...
isBuildableNs :: Namespace -> Bool
-isBuildableNs (Namespace (x : _) Namespace.Hs) | x /= "Hero" = True
-isBuildableNs (Namespace _ Namespace.Scm) = True
+isBuildableNs (Namespace _ Namespace.Hs) = True
+isBuildableNs (Namespace _ Namespace.Scm) = False
isBuildableNs (Namespace _ Namespace.Rs) = True
isBuildableNs ns
| ns `elem` nixTargets = True
diff --git a/Biz/Bild.nix b/Biz/Bild.nix
index c007661..e675b68 100644
--- a/Biz/Bild.nix
+++ b/Biz/Bild.nix
@@ -1,8 +1,7 @@
{ nixpkgs ? import ./Bild/Nixpkgs.nix }:
-with import ./Bild/Constants.nix;
-
rec {
+ constants = import ./Bild/Constants.nix;
private = {
inherit nixpkgs;
@@ -21,7 +20,7 @@ rec {
haskellDeps = import ./Bild/Deps/Haskell.nix;
- ghcWith = nixpkgs.haskell.packages.${ghcCompiler}.ghcWithHoogle;
+ ghcWith = nixpkgs.haskell.packages.${constants.ghcCompiler}.ghcWithHoogle;
#mkGhcjsPackageSet = nixpkgs.haskell.packages.${ghcjsCompiler}.ghcWithPackages;
ghcPackageSetFull = private.ghcWith private.haskellDeps;
@@ -140,20 +139,20 @@ rec {
env = nixpkgs.pkgs.mkShell {
name = "bizdev";
+ # this should just be dev tools
buildInputs = with nixpkgs.pkgs; [
- # this should just be dev tools
- haskell.packages.${ghcCompiler}.apply-refact
+ #haskell.packages.${constants.ghcCompiler}.apply-refact
bild
figlet
git
- haskell.packages.${ghcCompiler}.fast-tags
+ haskell.packages.${constants.ghcCompiler}.fast-tags
hlint
lolcat
- niv.niv
nixops
ormolu
- python38Packages.black
- python38Packages.pylint
+ # not using python now, should remove
+ #python38Packages.black
+ #python38Packages.pylint
rustc
sbcl
lispPackages.swank
diff --git a/Biz/Bild/Constants.nix b/Biz/Bild/Constants.nix
index 652e022..0ffc85d 100644
--- a/Biz/Bild/Constants.nix
+++ b/Biz/Bild/Constants.nix
@@ -1,4 +1,4 @@
{
- ghcCompiler = "ghc8104";
+ ghcCompiler = "ghc923";
ghcjsCompiler = "ghcjs86";
}
diff --git a/Biz/Bild/Deps.hs b/Biz/Bild/Deps.hs
new file mode 100644
index 0000000..908f188
--- /dev/null
+++ b/Biz/Bild/Deps.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE LambdaCase #-}
+
+-- | A specific-purpose dependency manager.
+--
+-- : out deps
+module Biz.Bild.Deps where
+
+import Alpha
+import qualified Niv.Cli
+import qualified System.Environment as Env
+
+main :: IO ()
+main =
+ Env.getArgs +> \case
+ ["test"] -> pure ()
+ _ -> Niv.Cli.cli
diff --git a/Biz/Bild/Deps.nix b/Biz/Bild/Deps.nix
index 4f16250..84639b5 100644
--- a/Biz/Bild/Deps.nix
+++ b/Biz/Bild/Deps.nix
@@ -14,11 +14,17 @@ in rec
overrides = with super.pkgs.haskell.lib; sel: sup:
super.overridePinnedDeps (buildCabal sel) // {
acid-state = dontCheck sup.acid-state; # mac: "too many open files"
+ clay = doJailbreak sup.clay;
+ envy = doJailbreak sup.envy;
+ fast-tags = sup.fast-tags.overrideAttrs (old: old // { patches = []; });
+ generic-data = dontCheck sup.generic-data; # https://github.com/Lysxia/generic-data/issues/56
ghcjs-base = null; # otherwise ghc tries to build this via overridePinnedDeps
- servant-auth = buildCabalSubdir sel {name = "servant-auth";};
+ readable = doJailbreak sup.readable; # why is this even being built?
+ servant-auth = doJailbreak (buildCabalSubdir sel {name = "servant-auth"; subdir = "servant-auth/servant-auth";});
servant-server = doJailbreak sup.servant-server;
+ stripe-core = doJailbreak sup.stripe-core;
stripe-haskell = dontCheck sup.stripe-haskell;
- stripe-http-client = dontCheck sup.stripe-http-client;
+ stripe-http-client = doJailbreak (dontCheck sup.stripe-http-client);
temporary = dontCheck sup.temporary;
wai-middleware-metrics = dontCheck sup.wai-middleware-metrics;
};
diff --git a/Biz/Bild/Deps/Haskell.nix b/Biz/Bild/Deps/Haskell.nix
index 39139af..7e9f4fe 100644
--- a/Biz/Bild/Deps/Haskell.nix
+++ b/Biz/Bild/Deps/Haskell.nix
@@ -20,7 +20,6 @@ with hpkgs;
containers
directory
docopt
- ekg
envy
fast-logger
filepath
@@ -33,12 +32,12 @@ with hpkgs;
ixset
katip
lucid
- miso
monad-logger
monad-metrics
mtl
neat-interpolation
network-uri
+ niv
optparse-simple
parsec
process
diff --git a/Biz/Bild/Nixpkgs.nix b/Biz/Bild/Nixpkgs.nix
index d29519c..480662a 100644
--- a/Biz/Bild/Nixpkgs.nix
+++ b/Biz/Bild/Nixpkgs.nix
@@ -6,6 +6,10 @@ import sources.nixpkgs {
overlays = [
(_: _: { inherit sources; })
(_: pkgs: {
+ # Given a generic `builder`, will generate an attrset for all the packages
+ # pinned by `deps` with `builder` applied to the package. This attrset can
+ # then be merged with the rest of the packages in the set as part of an
+ # overlay or overrides.
overridePinnedDeps = builder:
pkgs.lib.genAttrs (builtins.attrNames pkgs.sources) builder;
})
@@ -28,5 +32,8 @@ import sources.nixpkgs {
config = {
allowBroken = true;
allowUnfree = true;
+ permittedInsecurePackages = [
+ "python2.7-pyjwt-1.7.1"
+ ];
};
}
diff --git a/Biz/Bild/Sources.json b/Biz/Bild/Sources.json
index 7659958..b754685 100644
--- a/Biz/Bild/Sources.json
+++ b/Biz/Bild/Sources.json
@@ -1,17 +1,4 @@
{
- "apply-refact": {
- "branch": "master",
- "description": "Refactor Haskell source files",
- "homepage": "",
- "owner": "mpickering",
- "repo": "apply-refact",
- "rev": "0.8.2.1",
- "sha256": "0wyamn4w3lsayhsqs6h60f0m337b1p5byw1frmcyima3pqsgprvl",
- "type": "tarball",
- "url": "https://github.com/mpickering/apply-refact/archive/0.8.2.1.tar.gz",
- "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz",
- "version": "0.8.2.1"
- },
"clay": {
"branch": "master",
"description": "A CSS preprocessor as embedded Haskell.",
@@ -96,36 +83,23 @@
"homepage": "",
"owner": "ghcjs",
"repo": "jsaddle",
- "rev": "d569be43f92b9b8c01dc3ee4c41401ab406a2076",
- "sha256": "1m1xxy4l9ii91k1k504qkxh9k1ybprm1m66mkb9dqlwcpyhcccmv",
+ "rev": "00b206288c2cd019b56ff9f0b72a065f67ffb242",
+ "sha256": "179q0j4wmn28h1ny2p8qgpr25krl4v6dn3xmbn8zkvylkz4f3m42",
"type": "tarball",
- "url": "https://github.com/ghcjs/jsaddle/archive/d569be43f92b9b8c01dc3ee4c41401ab406a2076.tar.gz",
+ "url": "https://github.com/ghcjs/jsaddle/archive/00b206288c2cd019b56ff9f0b72a065f67ffb242.tar.gz",
"url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz",
"version": "1e39844"
},
- "miso": {
- "branch": "master",
- "description": ":ramen: A tasty Haskell front-end framework",
- "homepage": "https://haskell-miso.org",
- "owner": "dmjio",
- "repo": "miso",
- "rev": "41234e419d6177fe05913a1bd885f811afe5cc9f",
- "sha256": "1nby1y8yixv0a47h1bzdfjcwzah3km7bfd0phdb520ci4dgs30w1",
- "type": "tarball",
- "url": "https://github.com/dmjio/miso/archive/41234e419d6177fe05913a1bd885f811afe5cc9f.tar.gz",
- "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz",
- "version": "1.5"
- },
"niv": {
"branch": "master",
"description": "Easy dependency management for Nix projects",
"homepage": "https://github.com/nmattia/niv",
"owner": "nmattia",
"repo": "niv",
- "rev": "af958e8057f345ee1aca714c1247ef3ba1c15f5e",
- "sha256": "1qjavxabbrsh73yck5dcq8jggvh3r2jkbr6b5nlz5d9yrqm9255n",
+ "rev": "82e5cd1ad3c387863f0545d7591512e76ab0fc41",
+ "sha256": "090l219mzc0gi33i3psgph6s2pwsc8qy4lyrqjdj4qzkvmaj65a7",
"type": "tarball",
- "url": "https://github.com/nmattia/niv/archive/af958e8057f345ee1aca714c1247ef3ba1c15f5e.tar.gz",
+ "url": "https://github.com/nmattia/niv/archive/82e5cd1ad3c387863f0545d7591512e76ab0fc41.tar.gz",
"url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
},
"nixos-mailserver": {
@@ -144,10 +118,10 @@
"name": "nixpkgs",
"owner": "bsima",
"repo": "nixpkgs",
- "rev": "11452e4fe3b4afe566b47f1f85c2cec863a4f5bb",
- "sha256": "0csm6wxf1s6vx9kl0yl28lgiwnxans0023ib47qlrjbkmpaqy4b8",
+ "rev": "30216881bc4c0faf52f048b9141afe167762b917",
+ "sha256": "11qwps5mg8pgy5hvb2cw5l0vj7igk5gi7gskn9z6mqf7rv29yh4x",
"type": "tarball",
- "url": "https://github.com/bsima/nixpkgs/archive/11452e4fe3b4afe566b47f1f85c2cec863a4f5bb.tar.gz",
+ "url": "https://github.com/bsima/nixpkgs/archive/30216881bc4c0faf52f048b9141afe167762b917.tar.gz",
"url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
},
"regex-applicative": {
@@ -164,29 +138,16 @@
"url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz",
"version": "0.3.4"
},
- "req": {
- "branch": "master",
- "description": "Easy-to-use, type-safe, expandable, high-level HTTP client library",
- "homepage": "",
- "owner": "mrkkrp",
- "repo": "req",
- "rev": "0f799e9076053c4bdd685b81e0393d1682de8735",
- "sha256": "1xrzplgas107zxnv23ai14r4s6wz57ycsav1zhikhk04zz442zhh",
- "type": "tarball",
- "url": "https://github.com/mrkkrp/req/archive/0f799e9076053c4bdd685b81e0393d1682de8735.tar.gz",
- "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz",
- "version": "3.8.0"
- },
"servant-auth": {
"branch": "master",
"description": null,
"homepage": null,
"owner": "haskell-servant",
- "repo": "servant-auth",
- "rev": "servant-auth-0.4.0.0",
- "sha256": "1wg67mr472mracyjd63ldlfiv85v2kdw2rvcvq1sahp05i591j26",
+ "repo": "servant",
+ "rev": "f0e2316895ee5fda52ba9d5b2b7e10f8a80a9019",
+ "sha256": "0ndan9zxvg5zvrl42zvppc9vhbn5skgsyqyxp2v685h82lfz74ps",
"type": "tarball",
- "url": "https://github.com/haskell-servant/servant-auth/archive/servant-auth-0.4.0.0.tar.gz",
+ "url": "https://github.com/haskell-servant/servant/archive/f0e2316895ee5fda52ba9d5b2b7e10f8a80a9019.tar.gz",
"url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz",
"version": "0.4.0.0"
}
diff --git a/Biz/Dragons.hs b/Biz/Dragons.hs
index 0a3583d..7307f69 100644
--- a/Biz/Dragons.hs
+++ b/Biz/Dragons.hs
@@ -540,9 +540,9 @@ data Keep = Keep
$(deriveSafeCopy 0 'base ''Keep)
createUser :: User -> Acid.Update Keep User
-createUser u = do
+createUser User {..} = do
keep <- get
- let newUser = u {userId = nextUserId keep} :: User
+ let newUser = User {userId = nextUserId keep, ..}
put
<| keep
{ users = IxSet.insert newUser (users keep),
@@ -644,9 +644,10 @@ upsertGitHubUser keep tok ghUser =
|> GetUserByGitHubId
|> Acid.query keep
+> \case
- Just user ->
+ Just User {..} ->
-- if we already know this user, we need to refresh the token
- UpdateUser user {userGitHubToken = Encoding.decodeUtf8 tok}
+ User {userGitHubToken = Encoding.decodeUtf8 tok, ..}
+ |> UpdateUser
|> Acid.update keep
Nothing ->
CreateUser
@@ -1036,8 +1037,9 @@ htmlApp jwtCfg cooks kp cfg oAuthArgs =
guardAuth >=> UserAccount .> App.Html .> pure,
postAccount = \a subscription ->
guardAuth a
- +> \user ->
- UpdateUser user {userSubscription = subscription}
+ +> \User {..} ->
+ User {userSubscription = subscription, ..}
+ |> UpdateUser
|> Acid.update' kp
+> UserAccount
.> App.Html
diff --git a/Biz/Id.hs b/Biz/Id.hs
index 4635f7f..344149d 100644
--- a/Biz/Id.hs
+++ b/Biz/Id.hs
@@ -30,7 +30,7 @@ instance Hashable (Id entity)
instance Binary (Id entity)
instance Enum (Id entity) where
- toEnum n = mk (Proxy :: Proxy entity) n
+ toEnum = mk (Proxy :: Proxy entity)
fromEnum = untag
instance NFData (Id entity) where
diff --git a/Biz/Ide/hooks/pre-commit b/Biz/Ide/hooks/pre-commit
index 507d7e6..31a4e68 100755
--- a/Biz/Ide/hooks/pre-commit
+++ b/Biz/Ide/hooks/pre-commit
@@ -8,7 +8,9 @@
for ns in ${changed[@]}
do
version=$($BIZ_ROOT/Biz/Ide/version $ns)
- if (( $version < 1 )); then
+ if (( $version == -1 )); then
+ echo "info: version: $ns: deleted"
+ elif (( $version < 1 )); then
echo "fail: version: $ns: $version"
exit 1
else
diff --git a/Biz/Ide/version b/Biz/Ide/version
index 3a02b95..5b017d9 100755
--- a/Biz/Ide/version
+++ b/Biz/Ide/version
@@ -3,9 +3,13 @@
# simple implementation of kelvin versioning
##
ns=$1
- commits=$(git log --oneline --follow $ns | wc -l)
- # gold melts at 1337 kelvin, so we start with this
- # bc we are forging gold here
- version=$(bc -l <<< "1337 - $commits")
- echo $version
+ if [[ -e "$1" ]]; then
+ commits=$(git log --oneline --follow $ns | wc -l)
+ # gold melts at 1337 kelvin, so we start with this
+ # bc we are forging gold here
+ version=$(bc -l <<< "1337 - $commits")
+ echo $version
+ else
+ echo -1 # signal that file doesn't exist
+ fi
##
diff --git a/Biz/Lint.hs b/Biz/Lint.hs
index 23a6834..8dafcb3 100644
--- a/Biz/Lint.hs
+++ b/Biz/Lint.hs
@@ -159,7 +159,7 @@ runOne mode root cwd path_ = results +> traverse_ printResult >> results
[ lint mode ormolu path_,
lint mode hlint path_
]
- Just (Namespace _ Py) -> [lint mode pylint path_]
+ Just (Namespace _ Py) -> [] -- [lint mode pylint path_]
Just (Namespace _ Sh) -> [lint mode shellcheck path_]
Just (Namespace _ Nix) -> [pure <| NoOp path_]
Just (Namespace _ Scm) -> [pure <| NoOp path_]
diff --git a/Biz/Namespace.hs b/Biz/Namespace.hs
index b9ef994..1365919 100644
--- a/Biz/Namespace.hs
+++ b/Biz/Namespace.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
diff --git a/Biz/Pie.hs b/Biz/Pie.hs
index ff02716..3914674 100644
--- a/Biz/Pie.hs
+++ b/Biz/Pie.hs
@@ -1,12 +1,3 @@
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
-- | [P]roduct [I]mprovement [E]ngine
--
-- A product improvement engine must measure two things:
@@ -30,186 +21,3 @@
-- - Sean Ellis' question: "How would you feel if you could no longer use this
-- product? (a) Very disappointed, (b) somewhat disappointed, (c) not
-- disappointed" and then measure the percentage who answer (a).
---
--- Bild Metadata:
---
--- : out pie
-module Biz.Pie
- ( main,
- )
-where
-
-import Alpha
-import qualified Biz.Cli as Cli
-import Biz.Test ((@=?))
-import qualified Biz.Test as Test
-import qualified Data.Aeson as Aeson
-import qualified Data.Maybe as Maybe
-import qualified Data.Text as Text
-import qualified Data.Time as Time
-import qualified System.Console.Haskeline as Haskeline
-import qualified System.Directory as Directory
-import qualified System.Exit as Exit
-import qualified System.Process as Process
-import qualified Text.Parsec as Parsec
-import qualified Text.Parsec.String as Parsec
-
-main :: IO ()
-main = Cli.main <| Cli.Plan help move test pure
-
-test :: Test.Tree
-test = Test.group "Biz.Pie" [Test.unit "id" <| 1 @=? (1 :: Integer)]
-
-help :: Cli.Docopt
-help =
- [Cli.docopt|
-[p]roduct [i]mprovement [e]ngine
-manages .pie files, records data from product build sprints and user testing
-
-Usage:
- pie new
- pie update <ns>
- pie feedback <ns>
- pie test
-|]
-
-newtype Form = Form {roll :: [Entry]}
- deriving (Generic, Aeson.ToJSON, Aeson.FromJSON, Show)
-
-instance Monoid Form where
- mempty = Form []
-
-instance Semigroup Form where
- a <> b = Form (roll a <> roll b)
-
-formFile :: String -> FilePath
-formFile ns = ns ++ ".pie"
-
-loadForm :: String -> IO Form
-loadForm ns =
- Directory.doesFileExist file +> \case
- False -> pure mempty
- True ->
- Aeson.decodeFileStrict file +> \case
- Nothing -> panic <| Text.pack <| "could not decode: " ++ file
- Just x -> pure x
- where
- file = formFile ns
-
-saveForm :: String -> Form -> IO ()
-saveForm "" _ = pure ()
-saveForm namespace form = Aeson.encodeFile (formFile namespace) form
-
-data Move
- = New
- | Update String
- | Feedback String
-
-fromArgs :: Cli.Arguments -> Move
-fromArgs args
- | cmd "new" = New
- | cmd "update" = Update <| getArg "ns"
- | cmd "feedback" = Feedback <| getArg "ns"
- | otherwise = panic "could not get move from args"
- where
- cmd a = args `Cli.has` Cli.command a
- getArg a = Maybe.fromJust <| args `Cli.getArg` Cli.argument a
-
-move :: Cli.Arguments -> IO ()
-move args = case fromArgs args of
- New -> do
- week <- Time.getCurrentTime +> pure <. Time.formatTime Time.defaultTimeLocale "%V"
- let branch = "sprint-" <> week
- proc <- Process.spawnProcess "git" ["show-ref", branch]
- Process.waitForProcess proc +> \case
- Exit.ExitSuccess ->
- Process.callProcess "git" ["switch", branch]
- Exit.ExitFailure _ ->
- Process.callProcess "git" ["switch", "-c", branch]
- Update namespace ->
- Haskeline.runInputT Haskeline.defaultSettings <| do
- form <- liftIO <| loadForm namespace
- timestamp <- liftIO Time.getCurrentTime
- onTrack <- parseBool </ question "Are you on track?"
- isLaunched <- parseBool </ question "Are you launched?"
- weeksUntilLaunch <- parseInt </ question "How many weeks to launch?"
- usersTalkedWith <- parseInt </ question "Haw many (prospective) users have you talked to in the last week?"
- learnings <- parseText </ question "What have you learned from them?"
- morale <- parseInt </ question "On a scale of 1-10, what is your morale?"
- mostImprovement <- parseText </ question "What most improved your primary metric?"
- biggestObstacle <- parseText </ question "What is your biggest obstacle?"
- goals <- parseText </ question "What are your top 1-3 goals for next week?"
- liftIO <| saveForm namespace <| form {roll = BuildSprint {..} : roll form}
- Feedback namespace ->
- Haskeline.runInputT Haskeline.defaultSettings <| do
- form <- liftIO <| loadForm namespace
- timestamp <- liftIO Time.getCurrentTime
- user <- parseText </ question "User?"
- howDisappointed <- parseDisappointment </ question "How disappointed? (1=very, 2=somewhat, 3=not)"
- liftIO <| saveForm namespace <| form {roll = UserFeedback {..} : roll form}
-
-question :: String -> Haskeline.InputT IO String
-question q = Maybe.fromJust </ (Haskeline.getInputLine <| q ++ " ")
-
-data Entry
- = BuildSprint
- { timestamp :: Time.UTCTime,
- -- | Last week your goals were X. As of now, do you feel like you're on
- -- track to hit your goals?
- onTrack :: Bool,
- -- | Are you launched?
- isLaunched :: Bool,
- -- | How many weeks to launch?
- weeksUntilLaunch :: Int,
- -- | Haw many (prospective) users have you talked to in the last week?
- usersTalkedWith :: Int,
- -- | What have you learned from them?
- learnings :: Text,
- -- | On a scale of 1-10, what is your morale?
- morale :: Int,
- -- | What most improved your primary metric?
- mostImprovement :: Text,
- -- | What is your biggest obstacle?
- biggestObstacle :: Text,
- -- | What are your top 1-3 goals for next week?
- goals :: Text
- }
- | UserFeedback
- { timestamp :: Time.UTCTime,
- user :: Text,
- howDisappointed :: Disappointment
- }
- deriving (Generic, Aeson.ToJSON, Aeson.FromJSON, Show)
-
-data Disappointment = Very | Somewhat | NotAtAll
- deriving (Generic, Aeson.ToJSON, Aeson.FromJSON, Show)
-
--- helpers for parsing user input
-
-parseInput :: Parsec.Parser a -> String -> Either Parsec.ParseError a
-parseInput p = Parsec.parse (p <* Parsec.eof) ""
-
-parseDisappointment :: String -> Disappointment
-parseDisappointment s = case parseInt s of
- 1 -> Very
- 2 -> Somewhat
- 3 -> NotAtAll
- _ -> panic "could not parse disappointment"
-
-parseText :: String -> Text
-parseText s =
- parseInput (Parsec.many1 Parsec.anyChar) s
- |> fromRight ""
- |> Text.pack
-
-parseBool :: String -> Bool
-parseBool s =
- parseInput (Parsec.oneOf "yn") s
- /> (== 'y')
- |> fromRight False
-
-parseInt :: String -> Int
-parseInt s =
- parseInput (Parsec.many1 Parsec.digit /> readMaybe) s
- /> Maybe.fromJust
- |> fromRight 0
diff --git a/Biz/Que/Host.hs b/Biz/Que/Host.hs
index 702827e..b26f9c7 100644
--- a/Biz/Que/Host.hs
+++ b/Biz/Que/Host.hs
@@ -106,7 +106,7 @@ instance Accept HTML where
contentTypes _ = "text" // "html" /: ("charset", "utf-8") :| ["text" // "html"]
instance MimeRender HTML ByteString where
- mimeRender _ x = str x
+ mimeRender _ = str
instance MimeUnrender HTML Text where
mimeUnrender _ bs = Right <| str bs
@@ -115,7 +115,7 @@ instance MimeUnrender OctetStream Text where
mimeUnrender _ bs = Right <| str bs
instance MimeRender PlainText ByteString where
- mimeRender _ bs = str bs
+ mimeRender _ = str
instance MimeUnrender PlainText ByteString where
mimeUnrender _ bs = Right <| str bs
diff --git a/Data/String/Quote.hs b/Data/String/Quote.hs
index 7efe692..75881a5 100644
--- a/Data/String/Quote.hs
+++ b/Data/String/Quote.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TemplateHaskellQuotes #-}
-- | QuasiQuoter for non-interpolated strings, texts and bytestrings.
--
diff --git a/Hero/Core.hs b/Hero/Core.hs
deleted file mode 100644
index 86b0638..0000000
--- a/Hero/Core.hs
+++ /dev/null
@@ -1,939 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
-
-module Hero.Core where
-
-import Alpha
-import qualified Clay
-import Data.Aeson
- ( FromJSON (..),
- ToJSON (..),
- defaultOptions,
- genericParseJSON,
- genericToJSON,
- )
-import Data.Data (Data, Typeable)
-import qualified Data.List as List
-import qualified Data.List.Split as List
-import Data.Proxy (Proxy (..))
-import Data.String.Quote
-import Data.Text (Text)
-import GHC.Generics (Generic)
-import qualified GHC.Show as Legacy
-import Hero.Look as Look
-import Hero.Look.Typography
-import qualified Hero.Pack as Pack
-import Miso
-import qualified Miso (for_)
-import Miso.Extend
-import Miso.String
-import Network.RemoteData
-import Servant.API
- ( (:<|>) (..),
- (:>),
- )
-import qualified Servant.API as Api
-import Servant.Links (linkURI)
-
--- | The css id for controling music in the comic player.
-audioId :: MisoString
-audioId = "audioSource"
-
--- TODO: make ComicId a hashid
--- https://hackage.haskell.org/package/hashids-1.0.2.4/docs/Web-Hashids.html
-newtype ComicId
- = ComicId String
- deriving
- ( Show,
- Eq,
- Ord,
- Data,
- Typeable,
- Generic,
- ToMisoString,
- IsString,
- Api.ToHttpApiData,
- Api.FromHttpApiData
- )
-
-instance ToJSON ComicId where
- toJSON = genericToJSON Data.Aeson.defaultOptions
-
-instance FromJSON ComicId where
- parseJSON = genericParseJSON Data.Aeson.defaultOptions
-
--- | Used for looking up images on S3, mostly
-comicSlug :: Comic -> Text
-comicSlug Comic {..} = snake comicName <> "-" <> comicIssue
-
--- * user
-
-data User = User
- { userEmail :: Text,
- userName :: Text,
- userLibrary :: [Comic]
- }
- deriving (Show, Eq, Generic, Data, Ord)
-
-instance Semigroup User where
- a <> b =
- User
- (userEmail a <> userEmail b)
- (userName a <> userName b)
- (userLibrary a <> userLibrary b)
-
-instance Monoid User where
- mempty = User mempty mempty mempty
-
-instance ToJSON User where
- toJSON = genericToJSON Data.Aeson.defaultOptions
-
-instance FromJSON User where
- parseJSON = genericParseJSON Data.Aeson.defaultOptions
-
--- | Class for rendering media objects in different ways.
-class IsMediaObject o where
- -- | Render a thumbnail for use in a shelf, or otherwise.
- thumbnail :: o -> View Move
-
- -- | Render a featured banner.
- feature :: o -> User -> View Move
-
- -- | Media info view
- info :: o -> User -> View Move
-
--- | How much to Zoom the comic image
-type Magnification = Int
-
--- | All the buttons.
-data Button
- = Watch Comic
- | Read Comic
- | Save Comic User
- | SaveIcon Comic User
- | ZoomIcon Magnification Comic PageNumber
- | PlayPause MisoString AudioState
- | Arrow Move
-
--- | Class for defining general, widely used elements in the heroverse.
-class Elemental v where el :: v -> View Move
-
--- TODO: what if I just did this on all actions?
--- then I could e.g. `el <| ToggleAudio audioId audioState`
-instance Elemental Button where
- el (PlayPause id form) =
- button_
- [ class_ "button is-large icon",
- onClick <| ToggleAudio id
- ]
- [i_ [class_ <| "fa " <> icon] []]
- where
- icon = case form of
- Paused -> "fa-play-circle"
- Playing -> "fa-pause-circle"
- el (Arrow act) =
- button_
- [class_ "button is-large turn-page", onClick act]
- [img_ [src_ <| ms <| Pack.demo <> image <> ".png"]]
- where
- image = case act of
- PrevPage -> "prev-page"
- NextPage -> "next-page"
- _ -> "prev-page"
- el (Save c u) =
- if c `elem` userLibrary u -- in library
- then
- a_
- [class_ "wrs-button saved", onClick <| ToggleInLibrary c]
- [ img_ [src_ <| ms <| Pack.icon <> "save.svg"],
- span_ [] [text "saved"]
- ]
- else -- not in library
-
- a_
- [class_ "wrs-button", onClick <| ToggleInLibrary c]
- [ img_ [src_ <| ms <| Pack.icon <> "save.svg"],
- span_ [] [text "save"]
- ]
- el (SaveIcon c u) =
- if c `elem` userLibrary u -- in library
- then
- button_
- [ class_ "button is-large has-background-black",
- onClick <| ToggleInLibrary c
- ]
- [img_ [src_ <| ms <| Pack.demo <> "library-add.png"]]
- else -- not in library
-
- button_
- [ class_ "button is-large has-background-black-bis",
- onClick <| ToggleInLibrary c
- ]
- [img_ [src_ <| ms <| Pack.demo <> "library-add.png"]]
- el (ZoomIcon zform comic page) =
- button_
- [ id_ "zoom-button",
- class_ "button is-large",
- onClick <| ToggleZoom comic page
- ]
- [ img_ [src_ <| ms <| Pack.demo <> "zoom.png"],
- input_
- [ type_ "range",
- min_ "0",
- max_ "100",
- disabled_ True,
- value_ <| ms (show zform :: String),
- class_ "ctrl",
- id_ "zoom"
- ],
- label_
- [class_ "ctrl", Miso.for_ "zoom"]
- [text <| ms <| (show zform :: String) ++ "%"]
- ]
- el (Read c) =
- a_
- [class_ "wrs-button", onClick <| SelectExperience c]
- [ img_ [src_ <| ms <| Pack.icon <> "read.svg"],
- span_ [] [text "read"]
- ]
- el (Watch c) =
- a_
- [class_ "wrs-button", onClick <| StartWatching c]
- [ img_ [src_ <| ms <| Pack.icon <> "watch.svg"],
- span_ [] [text "watch"]
- ]
-
-data AudioState = Playing | Paused
- deriving (Show, Eq)
-
-data ComicReaderState
- = NotReading
- | Cover ComicId
- | ChooseExperience ComicId PageNumber
- | Reading ComicReaderView ComicId PageNumber
- | Watching ComicId
- deriving (Show, Eq)
-
-findComic :: ComicId -> [Comic] -> Maybe Comic
-findComic id = List.find (\c -> comicId c == id)
-
--- | Main form for the app.
---
--- Try to prefix component-specific state with the component initials: 'd' for
--- discover, 'cp' for comic player.
-data Form = Form
- { uri :: Api.URI,
- appComics :: RemoteData MisoString [Comic],
- user :: User,
- dMediaInfo :: Maybe Comic,
- cpState :: ComicReaderState,
- cpAudioState :: AudioState,
- magnification :: Magnification
- }
- deriving (Show, Eq)
-
-initForm :: Api.URI -> Form
-initForm uri_ =
- Form
- { uri = uri_,
- appComics = NotAsked,
- dMediaInfo = Nothing,
- user = mempty,
- cpState = detectPlayerState uri_,
- cpAudioState = Paused,
- magnification = 100
- }
-
--- | Hacky way to initialize the 'ComicReaderState' from the Api.URI.
-detectPlayerState :: Api.URI -> ComicReaderState
-detectPlayerState u = case List.splitOn "/" <| Api.uriPath u of
- ["", "comic", id, pg, "experience"] -> ChooseExperience (ComicId id) (toPage pg)
- ["", "comic", id, _, "video"] -> Watching <| ComicId id
- ["", "comic", id, pg, "full"] -> Reading Full (ComicId id) (toPage pg)
- ["", "comic", id, pg] -> Reading Spread (ComicId id) (toPage pg)
- ["", "comic", id] -> Cover <| ComicId id
- _ -> NotReading
- where
- toPage pg = fromMaybe 1 (readMaybe pg :: Maybe PageNumber)
-
-type PageNumber = Int
-
-data Move
- = NoOp
- | -- comic player stuff
- SelectExperience Comic
- | StartReading Comic
- | StartWatching Comic
- | NextPage
- | PrevPage
- | ToggleZoom Comic PageNumber
- | ToggleAudio MisoString
- | FetchComics
- | SetComics (RemoteData MisoString [Comic])
- | ToggleFullscreen
- | -- discover stuff
- SetMediaInfo (Maybe Comic)
- | ToggleInLibrary Comic
- | -- login
- ValidateUserPassword
- | -- app stuff
- ScrollIntoView MisoString
- | HandleURI Api.URI
- | ChangeURI Api.URI
- | Dumpform
- deriving (Show, Eq)
-
-type AppRoutes =
- Home
- :<|> ComicCover
- :<|> ComicReaderSpread
- :<|> ComicReaderFull
- :<|> ComicVideo
- :<|> Discover
- :<|> ChooseExperience
-
-handlers =
- home
- :<|> comicCover
- :<|> comicReader
- :<|> comicReader
- :<|> comicReader
- :<|> discover
- :<|> comicReader
-
-routes :: Proxy AppRoutes
-routes = Proxy
-
-type PubRoutes =
- Home
- :<|> Login
-
-pubRoutes :: Proxy PubRoutes
-pubRoutes = Proxy
-
--- * pages
-
---
--- TODO: consider making a typeclass, something like:
---
--- class Page name where
--- type Route name :: View Move
--- proxy :: Proxy name
--- proxy = Proxy name
--- view :: form -> View Move
--- link :: Api.URI
-
--- ** home
-
---
--- this is the unauthenticated page that you see when you first visit
-
-type Home =
- View Move
-
-homeProxy :: Proxy Home
-homeProxy = Proxy
-
-homeLink :: Api.URI
-homeLink = linkURI <| Api.safeLink front homeProxy
- where
- front = Proxy :: Proxy Home
-
-home :: form -> View Move
-home = login
-
--- ** login
-
-data LoginForm = LoginForm {loginEmail :: String, loginPass :: String}
- deriving (Eq, Show, Read, Generic)
-
-instance ToJSON LoginForm
-
-instance FromJSON LoginForm
-
-type Login =
- "login" :> View Move
-
-loginProxy :: Proxy Login
-loginProxy = Proxy
-
-loginLink :: Api.URI
-loginLink = linkURI <| Api.safeLink pubRoutes loginProxy
-
-login :: form -> View Move
-login _ =
- template
- "login"
- [ div_
- [id_ "login-inner"]
- [ img_
- [ class_ fadeIn,
- src_ <| ms <| Pack.cdnEdge <> "/old-assets/images/icons/hero-large.png"
- ],
- hr_ [class_ fadeIn],
- form_
- [class_ fadeIn]
- [ ctrl [id_ "user", class_ "input", type_ "email", placeholder_ "Email"],
- ctrl [id_ "pass", class_ "input", type_ "password", placeholder_ "Password"],
- div_
- [class_ "action", css euro]
- [ div_
- [class_ "checkbox remember-me"]
- [ input_ [type_ "checkbox"],
- label_ [Miso.for_ "checkbox"] [text "Remember Me"]
- ],
- div_
- [class_ "button is-black", onClick ValidateUserPassword]
- [text "Login"]
- ]
- ],
- hr_ [class_ fadeIn],
- p_
- [class_ <| "help " <> fadeIn]
- [ a_ [href_ "#"] [text "Forgot your username or password?"],
- a_ [href_ "#"] [text "Don't have an account? Sign Up"]
- ],
- img_
- [ id_ "hero-logo",
- class_ "blur-out",
- src_ <| ms <| Pack.cdnEdge <> "/old-assets/images/icons/success-her-image.png"
- ]
- ]
- ]
- where
- fadeIn = "animated fadeIn delay-2s"
- ctrl x = div_ [class_ "control"] [input_ x]
-
--- ** discover
-
-type Discover = "discover" :> View Move
-
-discoverLink :: Api.URI
-discoverLink = linkURI <| Api.safeLink routes discoverProxy
-
-discoverProxy :: Proxy Discover
-discoverProxy = Proxy
-
-discover :: Form -> View Move
-discover form@Form {user = u} =
- template
- "discover"
- [ topbar,
- main_ [id_ "app-body"] <| case appComics form of
- NotAsked -> [loading]
- Loading -> [loading]
- Failure _ -> [nocomics]
- Success [] -> [nocomics]
- Success (comic : rest) ->
- [ feature comic u,
- shelf "Recent Releases" (comic : rest),
- maybeView (`info` u) <| dMediaInfo form
- ],
- appmenu,
- discoverFooter
- ]
-
-discoverFooter :: View Move
-discoverFooter =
- footer_
- [ id_ "app-foot",
- class_ "is-black"
- ]
- [ div_
- [id_ "app-foot-social", css euro]
- [ div_
- [class_ "row is-marginless"]
- [ smallImg "facebook.png" <| Just "https://www.facebook.com/musicmeetscomics",
- smallImg "twitter.png" <| Just "https://twitter.com/musicmeetscomic",
- smallImg "instagram.png" <| Just "https://www.instagram.com/musicmeetscomics/",
- smallImg "spotify.png" <| Just "https://open.spotify.com/user/i4ntfg6ganjgxdsylinigcjlq?si=ymWsSkwsT9iaLw2LeAJNNg",
- smallImg "youtube.png" <| Just "https://www.youtube.com/channel/UCnNPLiuJ1ueo1KTPgHDE7lA/"
- ],
- div_ [class_ "row"] [text "Team | Contact Us | Privacy Policy"]
- ],
- div_
- [id_ "app-foot-quote", css euro]
- [ p_ [] [text "With great power comes great responsiblity."],
- p_ [] [text "-Stan Lee"]
- ],
- div_
- [css euro, id_ "app-foot-logo", onClick Dumpform]
- [ a_ [class_ "social-icon", href_ "#"] [img_ [src_ <| ms <| Pack.icon <> "hero-logo.svg"]],
- span_ [] [text "© Hero Records, Inc. All Rights Reserved"]
- ]
- ]
- where
- attrs Nothing = [class_ "social-icon"]
- attrs (Just lnk) = [class_ "social-icon", href_ lnk, target_ "_blank"]
- smallImg x lnk =
- a_
- (attrs lnk)
- [img_ [src_ <| ms <| Pack.cdnEdge <> "/old-assets/images/icons/" <> x]]
-
--- ** comic
-
-data Comic = Comic
- { comicId :: ComicId,
- comicPages :: Integer,
- comicName :: Text,
- -- | Ideally this would be a dynamic number-like type
- comicIssue :: Text,
- comicDescription :: Text
- }
- deriving (Show, Eq, Generic, Data, Ord)
-
-instance ToJSON Comic where
- toJSON = genericToJSON Data.Aeson.defaultOptions
-
-instance FromJSON Comic where
- parseJSON = genericParseJSON Data.Aeson.defaultOptions
-
-instance IsMediaObject Comic where
- thumbnail c@Comic {..} =
- li_
- []
- [ a_
- [ class_ "comic grow clickable",
- id_ <| "comic-" <> ms comicId,
- onClick <| SetMediaInfo <| Just c
- ]
- [ img_ [src_ <| ms <| Pack.demo <> comicSlug c <> ".png"],
- span_ [] [text <| "Issue #" <> ms comicIssue],
- span_ [] [text <| ms comicName]
- ]
- ]
- feature comic lib =
- div_
- [id_ "featured-comic"]
- [ img_
- [ id_ "featured-banner",
- src_ <| ms <| Pack.demo <> "feature-banner.png"
- ],
- div_
- [id_ "featured-content"]
- [ div_
- [class_ "hero-original", css wide]
- [ span_ [css thicc] [text "Herø"],
- span_ [css euro] [text " Original"]
- ],
- div_
- [class_ "comic-logo"]
- [ img_
- [ src_
- <| ms
- <| Pack.demo <> comicSlug comic <> "-logo.png"
- ]
- ],
- div_ [class_ "comic-action-menu"]
- <| el </ [Watch comic, Read comic, Save comic lib],
- p_
- [class_ "description"]
- [ text <. ms <| comicDescription comic
- ]
- ]
- ]
- info c@Comic {..} lib =
- div_
- [class_ "media-info", css euro]
- [ div_
- [class_ "media-info-meta"]
- [ column [img_ [src_ <| ms <| Pack.demo <> "dmc-widethumb.png"]],
- column
- [ span_ [style_ title] [text <| ms comicName],
- span_ [style_ subtitle] [text <| "Issue #" <> ms comicIssue],
- span_ [] [text "Released: "],
- span_ [] [text <| "Pages: " <> ms (show comicPages :: String)]
- ]
- ],
- div_
- [class_ "media-info-summary"]
- [ p_
- [style_ <| uppercase <> bold <> Look.expanded <> "font-size" =: ".8rem"]
- [text "Summary"],
- p_ [] [text <| ms comicDescription]
- ],
- div_ [class_ "media-info-actions"] <| el </ [Save c lib, Read c, Watch c]
- -- , row [ text "credits" ]
- ]
- where
- title =
- "color" =: "red" <> "font-size" =: "1.6rem" <> uppercase
- <> "line-height"
- =: "100%"
- <> Look.condensed
- <> bold
- subtitle = "color" =: "#fff" <> "font-size" =: "1.2rem" <> bold <> Look.condensed
-
-type ComicCover =
- "comic"
- :> Api.Capture "comicId" ComicId
- :> View Move
-
-comicProxy :: Proxy ComicCover
-comicProxy = Proxy
-
-comicCover :: ComicId -> Form -> View Move
-comicCover comicId_ = comicReader comicId_ 1
-
-comicLink :: ComicId -> Api.URI
-comicLink comicId_ = linkURI <| Api.safeLink routes comicProxy comicId_
-
--- ** chooseExperience
-
-type ChooseExperience =
- "comic"
- :> Api.Capture "id" ComicId
- :> Api.Capture "page" PageNumber
- :> "experience"
- :> View Move
-
-chooseExperienceProxy :: Proxy ChooseExperience
-chooseExperienceProxy = Proxy
-
-chooseExperienceLink :: ComicId -> PageNumber -> Api.URI
-chooseExperienceLink id page =
- linkURI <| Api.safeLink routes chooseExperienceProxy id page
-
-chooseExperiencePage :: Comic -> PageNumber -> Form -> View Move
-chooseExperiencePage comic page form =
- template
- "choose-experience"
- [ topbar,
- main_
- [id_ "app-body"]
- [ h2_ [] [text "Choose Your Musical Experience"],
- p_ [] [text experienceBlurb],
- ul_ [] <| li comic </ experiences
- ],
- appmenu,
- comicControls comic page form
- ]
- where
- li c (name, artist, track) =
- li_
- [onClick <| StartReading c]
- [ div_
- []
- [ img_ [src_ <| ms <| Pack.demo <> name <> ".png"],
- span_ [] [text <| ms name]
- ],
- span_ [css thicc] [text <| ms artist],
- span_ [] [text <| ms track]
- ]
- experiences :: [(Text, Text, Text)]
- experiences =
- [ ("comedic", "RxGF", "Soft Reveal"),
- ("dark", "Logan Henderson", "Speak of the Devil"),
- ("original", "Mehcad Brooks", "Stars"),
- ("energetic", "Skela", "What's wrong with me"),
- ("dramatic", "Josh Jacobson", "Sideline")
- ]
-
-experienceBlurb :: MisoString
-experienceBlurb =
- [s|
-As you enter the world of Hero, you will find that music and visual art have a
-symbiotic relationship that can only be experienced, not described. Here, choose
-the tonality of the experience you wish to adventure on, whether it's a comedic,
-dark, energetic or dramatic. Feeling indecisive? Let us navigate your journey
-with the original curated music for this piece of visual art.
-|]
-
--- ** comicReader
-
-data ComicReaderView = Spread | Full
- deriving (Show, Eq)
-
-comicReader :: ComicId -> PageNumber -> Form -> View Move
-comicReader _ _ form = case appComics form of
- NotAsked -> loading
- Loading -> loading
- Failure _ -> nocomics
- Success comics -> case cpState form of
- NotReading -> template "comic-player" [text "error: not reading"]
- Cover id -> viewOr404 comics comicSpread id 1 form
- ChooseExperience id pg ->
- viewOr404 comics chooseExperiencePage id pg form
- Reading Spread id pg -> viewOr404 comics comicSpread id pg form
- Reading Full id pg -> viewOr404 comics zoomScreen id pg form
- Watching id -> viewOr404 comics comicVideo id 0 form
-
-zoomScreen :: Comic -> PageNumber -> Form -> View Move
-zoomScreen comic page form =
- template
- "comic-player"
- [ topbar,
- main_
- [id_ "app-body"]
- [ img_
- [ src_ comicImg,
- class_ "comic-page-full"
- ]
- ],
- comicControls comic page form
- ]
- where
- comicImg =
- ms Pack.demo
- <> ms (comicSlug comic)
- <> "-"
- <> padLeft page
- <> ".png"
-
--- ** comicReaderSpread
-
-type ComicReaderSpread =
- "comic"
- :> Api.Capture "id" ComicId
- :> Api.Capture "page" PageNumber
- :> View Move
-
-comicReaderSpreadProxy :: Proxy ComicReaderSpread
-comicReaderSpreadProxy = Proxy
-
-comicReaderSpreadLink :: ComicId -> PageNumber -> Api.URI
-comicReaderSpreadLink id page =
- linkURI <| Api.safeLink routes comicReaderSpreadProxy id page
-
-comicSpread :: Comic -> PageNumber -> Form -> View Move
-comicSpread comic page form =
- template
- "comic-player"
- [ topbar,
- main_
- [id_ "app-body"]
- [ div_
- [class_ "comic-player"]
- [ img_ [src_ comicImgLeft, class_ "comic-page"],
- img_ [src_ comicImgRight, class_ "comic-page"]
- ],
- closeButton
- ],
- appmenu,
- comicControls comic page form
- ]
- where
- comicImgLeft, comicImgRight :: MisoString
- comicImgLeft =
- ms Pack.demo
- <> ms (comicSlug comic)
- <> "-"
- <> padLeft page
- <> ".png"
- comicImgRight =
- ms Pack.demo
- <> ms (comicSlug comic)
- <> "-"
- <> padLeft (1 + page)
- <> ".png"
-
-closeButton :: View Move
-closeButton =
- a_
- [id_ "close-button", onClick <| ChangeURI discoverLink]
- [text "x"]
-
--- * comicReaderFull
-
-type ComicReaderFull =
- "comic"
- :> Api.Capture "id" ComicId
- :> Api.Capture "page" PageNumber
- :> "full"
- :> View Move
-
-comicReaderFullProxy :: Proxy ComicReaderFull
-comicReaderFullProxy = Proxy
-
-comicReaderFullLink :: ComicId -> PageNumber -> Api.URI
-comicReaderFullLink id page =
- linkURI <| Api.safeLink routes comicReaderFullProxy id page
-
--- * comicVideo
-
-type ComicVideo =
- "comic"
- :> Api.Capture "id" ComicId
- :> Api.Capture "page" PageNumber
- :> "video"
- :> View Move
-
-comicVideoProxy :: Proxy ComicVideo
-comicVideoProxy = Proxy
-
-comicVideoLink :: ComicId -> PageNumber -> Api.URI
-comicVideoLink id page =
- linkURI <| Api.safeLink routes comicVideoProxy id page
-
-frameborder_ :: MisoString -> Attribute action
-frameborder_ = textProp "frameborder"
-
-allowfullscreen_ :: Bool -> Attribute action
-allowfullscreen_ = boolProp "allowfullscreen"
-
-comicVideo :: Comic -> PageNumber -> Form -> View Move
-comicVideo _ _ _ =
- template
- "comic-player"
- [ topbar,
- main_
- [id_ "app-body"]
- [ div_
- [class_ "comic-video"]
- [ iframe_
- [ src_ "//player.vimeo.com/video/325757560",
- frameborder_ "0",
- allowfullscreen_ True
- ]
- []
- ]
- ]
- ]
-
--- * general page components |> utils
-
--- | If 'View' had a 'Monoid' instance, then '(text "")' could just be 'mempty'
-maybeView :: (a -> View action) -> Maybe a -> View action
-maybeView = maybe (text "")
-
-mediaInfo :: Maybe Comic -> User -> View Move
-mediaInfo Nothing _ = text ""
-mediaInfo (Just comic) user =
- div_ [class_ "media-info"] [info comic user]
-
-appmenu :: View Move
-appmenu = aside_ [id_ "appmenu"] <| btn </ links
- where
- links =
- -- these extra 'discoverLink's are just dummies
- [ (discoverLink, "discover.svg", "discover"),
- (discoverLink, "save.svg", "library"),
- (discoverLink, "watch.svg", "videos"),
- (comicLink "1", "read.svg", "comics"),
- (discoverLink, "listen.svg", "music")
- ]
- btn (lnk, img, label) =
- a_
- [ class_ "button",
- onPreventClick <| ChangeURI lnk
- ]
- [ img_ [src_ <| ms <| Pack.icon <> img],
- span_ [] [text label]
- ]
-
--- TODO: make this a loading gif of some sort... maybe the hero icon filling
--- from white to red
-loading :: View Move
-loading = div_ [class_ "loading"] [text "Loading..."]
-
-nocomics :: View Move
-nocomics = div_ [class_ "loading"] [text "error: no comics found"]
-
-shelf :: IsMediaObject o => MisoString -> [o] -> View Move
-shelf title comics =
- div_
- [class_ "shelf"]
- [ div_ [class_ "shelf-head"] [text title],
- ul_ [class_ "shelf-body"] <| thumbnail </ comics
- ]
-
-viewOr404 ::
- [Comic] ->
- (Comic -> PageNumber -> form -> View Move) ->
- ComicId ->
- PageNumber ->
- form ->
- View Move
-viewOr404 comics f id pg form =
- case findComic id comics of
- Just c -> f c pg form
- Nothing -> the404 form
-
-template :: MisoString -> [View Move] -> View Move
-template id = div_ [id_ id, class_ "app is-black"]
-
-padLeft :: Int -> MisoString
-padLeft n
- | n < 10 = ms ("0" <> Legacy.show n)
- | otherwise = ms <| Legacy.show n
-
-comicControls :: Comic -> PageNumber -> Form -> View Move
-comicControls comic page form =
- footer_
- [id_ "app-foot", class_ "comic-controls"]
- [ div_
- [ class_ "comic-nav-audio",
- css flexCenter
- ]
- [ audio_
- [id_ audioId, loop_ True, crossorigin_ "anonymous"]
- [source_ [src_ <| ms <| Pack.demo <> "stars-instrumental.mp3"]],
- el <| PlayPause audioId <| cpAudioState form,
- span_
- [css <| euro <> thicc <> smol <> wide]
- [text "Experiencing: Original"]
- ],
- div_
- [class_ "comic-controls-pages", css euro]
- [ el <| Arrow PrevPage,
- span_ [] [text <| leftPage <> "-" <> rightPage <> " of " <> totalpages],
- el <| Arrow NextPage
- ],
- div_
- [class_ "comic-controls-share"]
- [ el <| SaveIcon comic <| user form,
- el <| ZoomIcon (magnification form) comic page,
- button_
- [class_ "button icon is-large", onClick ToggleFullscreen]
- [i_ [class_ "fa fa-expand"] []]
- ]
- ]
- where
- leftPage = ms <. Legacy.show <| page
- rightPage = ms <. Legacy.show <| 1 + page
- totalpages = ms <. Legacy.show <| comicPages comic
-
-topbar :: View Move
-topbar =
- header_
- [id_ "app-head", class_ "is-black", css euro]
- [ a_
- [ class_ "button is-medium is-black",
- onClick <| ChangeURI discoverLink
- ]
- [img_ [src_ <| ms <| Pack.icon <> "hero-logo.svg"]],
- div_
- [id_ "app-head-right"]
- [ button_
- [class_ "button icon is-medium is-black"]
- [i_ [class_ "fas fa-search"] []],
- button_
- [ class_ "button is-medium is-black is-size-7",
- css <| euro <> wide <> thicc
- ]
- [text "News"],
- span_
- [class_ "icon is-large"]
- [ i_ [class_ "fas fa-user"] []
- ]
- ]
- ]
-
-row :: [View Move] -> View Move
-row = div_ [css <| Clay.display Clay.flex <> Clay.flexDirection Clay.row]
-
-column :: [View Move] -> View Move
-column = div_ [css <| Clay.display Clay.flex <> Clay.flexDirection Clay.column]
-
--- | Links
-the404 :: form -> View Move
-the404 _ = template "404" [p_ [] [text "Not found"]]
diff --git a/Hero/Host.hs b/Hero/Host.hs
deleted file mode 100644
index 7cc5986..0000000
--- a/Hero/Host.hs
+++ /dev/null
@@ -1,395 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PolyKinds #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
--- | Hero web app
---
--- : out mmc
-module Hero.Host
- ( main,
- )
-where
-
-import Alpha
-import Biz.App (CSS (..), Manifest (..))
-import qualified Biz.Cli as Cli
-import qualified Biz.Log as Log
-import Biz.Test ((@=?))
-import qualified Biz.Test as Test
-import qualified Clay
-import qualified Crypto.JOSE.JWK as Crypto
-import Data.Acid (AcidState)
-import qualified Data.Acid.Abstract as Acid
-import Data.Text (Text)
-import qualified Data.Text as Text
-import qualified Data.Text.Lazy as Lazy
-import Hero.Core
-import qualified Hero.Keep as Keep
-import qualified Hero.Look as Look
-import qualified Hero.Look.Typography as Typography
-import qualified Hero.Pack as Pack
-import qualified Lucid as L
-import Lucid.Base
-import Miso
-import Miso.String
-import Network.HTTP.Types hiding (Header)
-import Network.Wai
-import Network.Wai.Application.Static
-import qualified Network.Wai.Handler.Warp as Warp
-import Servant
-import qualified Servant.Auth.Server as Auth
-import qualified System.Directory as Directory
-import qualified System.Envy as Envy
-import qualified System.Exit as Exit
-import qualified System.IO as IO
-
-main :: IO ()
-main = Cli.main <| Cli.Plan help move test pure
-
-help :: Cli.Docopt
-help =
- [Cli.docopt|
-mmc
-
-Usage:
- mmc
- mmc test
-|]
-
-test :: Test.Tree
-test = Test.group "Hero.Host" [Test.unit "id" <| 1 @=? (1 :: Integer)]
-
-move :: Cli.Arguments -> IO ()
-move _ = bracket startup shutdown run
- where
- run (cfg, app, _) = Warp.run (heroPort cfg) app
- prn = IO.hPutStrLn IO.stderr
- startup =
- Envy.decodeEnv +> \case
- Left e -> Exit.die e
- Right cfg ->
- do
- keep <- Keep.open (heroKeep cfg)
- skey <- upsertKey (heroSkey cfg)
- Log.info ["!", "hero"] >> Log.br
- Log.info ["port", show <| heroPort cfg] >> Log.br
- Log.info ["keep", Text.pack <| heroKeep cfg] >> Log.br
- Log.info ["node", Text.pack <| heroNode cfg] >> Log.br
- Log.info ["skey", Text.pack <| heroSkey cfg] >> Log.br
- let jwts = Auth.defaultJWTSettings skey
- cs =
- Auth.defaultCookieSettings
- { -- uncomment this for insecure dev
- Auth.cookieIsSecure = Auth.NotSecure,
- Auth.cookieXsrfSetting = Nothing
- }
- ctx = cs :. jwts :. EmptyContext
- proxy = Proxy @(AllRoutes '[Auth.JWT, Auth.Cookie])
- static = serveDirectoryWith <| defaultWebAppSettings <| heroNode cfg
- server =
- -- assets, auth, and the homepage is public
- static
- :<|> cssHandlers
- :<|> pure heroManifest
- :<|> pubHostHandlers
- :<|> authHandler cs jwts
- -- app and api are private
- :<|> wrapAuth (jsonHandlers keep)
- :<|> wrapAuth appHostHandlers
- -- fall through to 404
- :<|> Tagged handle404
- pure
- ( cfg,
- serveWithContext
- proxy
- ctx
- server,
- keep
- )
- shutdown :: App -> IO ()
- shutdown (_, _, keep) = do
- Keep.close keep
- pure ()
-
-upsertKey :: FilePath -> IO Crypto.JWK
-upsertKey fp =
- Directory.doesFileExist fp +> \exists ->
- if exists
- then Auth.readKey fp
- else Auth.writeKey fp >> Auth.readKey fp
-
--- This part is a little confusing. I have:
---
--- - 'App' which encapsulates the entire runtime state
--- - 'Config' has stuff I can set at startup
--- - 'HeroKeep' is the database and any other persistance
--- - the above are then put together in the 'startup' private function in
--- `main` above
---
--- I'm sure this can be cleaned up with a monad stack of some sort, but I
--- haven't the brain power to think through that. For now, just try and keep
--- things named clearly so I don't get confused.
-
--- | This can be generalized I think, put in Biz.App, or something
-type App = (Config, Application, AcidState Keep.HeroKeep)
-
-data Config = Config
- { heroPort :: Warp.Port,
- heroNode :: FilePath,
- heroKeep :: FilePath,
- heroSkey :: FilePath
- }
- deriving (Generic, Show)
-
-instance Envy.DefConfig Config where
- defConfig = Config 3000 "_/bild/dev/Hero.Node/static" "_/keep" "/run/hero/skey"
-
-instance Envy.FromEnv Config
-
--- | Convert client side routes into server-side web handlers
-type AppHostRoutes = ToServerRoutes AppRoutes Templated Move
-
--- | These are the main app handlers, and should require authentication.
-appHostHandlers :: User -> Server AppHostRoutes
-appHostHandlers _ =
- homeHandler
- :<|> comicCoverHandler
- :<|> comicPageHandler
- :<|> comicPageFullHandler
- :<|> comicVideoHandler
- :<|> discoverHandler
- :<|> chooseExperienceHandler
-
--- | Marketing pages
-type PubHostRoutes = ToServerRoutes PubRoutes Templated Move
-
-pubHostHandlers :: Server PubHostRoutes
-pubHostHandlers =
- homeHandler :<|> loginHandler
-
-type JsonApi = "api" :> "comic" :> Get '[JSON] [Comic]
-
--- TODO: need a "you're not logged in" page
-wrapAuth ::
- Auth.ThrowAll route =>
- (user -> route) ->
- Auth.AuthResult user ->
- route
-wrapAuth f authResult = case authResult of
- Auth.Authenticated u -> f u
- Auth.BadPassword -> Auth.throwAll err401
- Auth.NoSuchUser -> Auth.throwAll err406
- Auth.Indefinite -> Auth.throwAll err422
-
-jsonHandlers :: AcidState Keep.HeroKeep -> User -> Server JsonApi
-jsonHandlers keep _ = Acid.query' keep <| Keep.GetComics 10
-
-type CssRoute = "css" :> "main.css" :> Get '[CSS] Text
-
-cssHandlers :: Server CssRoute
-cssHandlers =
- pure <. Lazy.toStrict <. Clay.render <| Typography.main <> Look.main
-
-type AuthRoute =
- "auth"
- :> ReqBody '[JSON] LoginForm
- :> Post
- '[JSON]
- ( Headers
- '[ Header "Set-Cookie" Auth.SetCookie,
- Header "Set-Cookie" Auth.SetCookie
- ]
- User
- )
-
-instance Auth.ToJWT User
-
-instance Auth.FromJWT User
-
--- | Endpoint for performing authentication
---
--- TODO: get creds from keep
--- TODO: load initial library for user
-authHandler ::
- Auth.CookieSettings ->
- Auth.JWTSettings ->
- LoginForm ->
- Handler
- ( Headers
- '[ Header "Set-Cookie" Auth.SetCookie,
- Header "Set-Cookie" Auth.SetCookie
- ]
- User
- )
-authHandler cookieSettings jwtSettings loginForm =
- case loginForm of
- (LoginForm "ben@bsima.me" "test") ->
- applyCreds <| User "ben@bsima.me" "ben" []
- (LoginForm "mcovino@heroprojects.io" "test") ->
- applyCreds <| User "mcovino@heroprojects.io" "mike" []
- _ -> throwError err401
- where
- applyCreds usr = do
- mApplyCookies <- liftIO <| Auth.acceptLogin cookieSettings jwtSettings usr
- case mApplyCookies of
- Nothing -> throwError err401
- Just applyCookies -> pure <| applyCookies usr
-
--- | See also 'server' above
-type AllRoutes auths =
- ("static" :> Raw)
- :<|> CssRoute
- :<|> ("manifest.json" :> Get '[JSON] Manifest)
- :<|> PubHostRoutes
- :<|> AuthRoute
- :<|> (Auth.Auth auths User :> JsonApi)
- :<|> (Auth.Auth auths User :> AppHostRoutes)
- :<|> Raw
-
-heroManifest :: Manifest
-heroManifest =
- Manifest
- { name = "Hero",
- short_name = "Hero",
- start_url = ".",
- display = "standalone",
- theme_color = "#0a0a0a",
- description = "Comics for all"
- }
-
--- | Type for setting wrapping a view in HTML doctype, header, etc
-newtype Templated a = Templated a
- deriving (Show, Eq)
-
-instance L.ToHtml a => L.ToHtml (Templated a) where
- toHtmlRaw = L.toHtml
- toHtml (Templated x) = do
- L.doctype_
- L.html_ [L.lang_ "en"] <| do
- L.head_ <| do
- L.title_ "Hero [alpha]"
- L.link_ [L.rel_ "manifest", L.href_ "/manifest.json"]
- L.link_ [L.rel_ "icon", L.type_ ""]
- -- icons
- L.link_
- [ L.rel_ "apple-touch-icon",
- L.sizes_ "180x180",
- L.href_
- <| Pack.cdnEdge
- <> "/old-assets/images/favicons/apple-touch-icon.png"
- ]
- L.link_
- [ L.rel_ "icon",
- L.type_ "image/png",
- L.sizes_ "32x32",
- L.href_
- <| Pack.cdnEdge
- <> "/old-assets/images/favicons/favicon-32x32.png"
- ]
- L.link_
- [ L.rel_ "icon",
- L.type_ "image/png",
- L.sizes_ "16x16",
- L.href_
- <| Pack.cdnEdge
- <> "/old-assets/images/favicons/favicon-16x16.png"
- ]
- L.link_
- [ L.rel_ "manifest",
- L.href_
- <| Pack.cdnEdge
- <> "/old-assets/images/favicons/manifest.json"
- ]
- L.link_
- [ L.rel_ "mask-icon",
- L.href_
- <| Pack.cdnEdge
- <> "/old-assets/images/favicons/safari-pinned-tab.svg"
- ]
- L.meta_ [L.charset_ "utf-8"]
- L.meta_ [L.name_ "theme-color", L.content_ "#000"]
- L.meta_ [L.httpEquiv_ "X-UA-Compatible", L.content_ "IE=edge"]
- L.meta_
- [L.name_ "viewport", L.content_ "width=device-width, initial-scale=1"]
- cssRef animateRef
- cssRef bulmaRef
- cssRef fontAwesomeRef
- cssRef "/css/main.css" -- TODO: make this a safeLink?
- jsRef "/static/all.js"
- jsRef "/static/usersnap.js"
- L.body_ (L.toHtml x)
- where
- jsRef href =
- L.with
- (L.script_ mempty)
- [ makeAttribute "src" href,
- makeAttribute "async" mempty,
- makeAttribute "defer" mempty
- ]
- cssRef href =
- L.with
- (L.link_ mempty)
- [L.rel_ "stylesheet", L.type_ "text/css", L.href_ href]
-
-handle404 :: Application
-handle404 _ respond =
- respond
- <| responseLBS status404 [("Content-Type", "text/html")]
- <| renderBS
- <| toHtml
- <| Templated
- <| the404
- <| initForm homeLink
-
-fontAwesomeRef :: MisoString
-fontAwesomeRef = "https://use.fontawesome.com/releases/v5.7.2/css/all.css"
-
-animateRef :: MisoString
-animateRef =
- "https://cdnjs.cloudflare.com/ajax/libs/animate.css/3.7.0/animate.min.css"
-
--- TODO: if I remove this, then the login form (and probably other stuff) gets
--- messed up. When I remove this, I need to also port the necessary CSS styles
--- to make stuff look good.
-bulmaRef :: MisoString
-bulmaRef =
- "https://cdnjs.cloudflare.com/ajax/libs/bulma/0.7.2/css/bulma.min.css"
-
-homeHandler :: Handler (Templated (View Move))
-homeHandler = pure <. Templated <. home <| initForm homeLink
-
-comicCoverHandler :: ComicId -> Handler (Templated (View Move))
-comicCoverHandler id =
- pure <. Templated <. comicCover id <. initForm <| comicLink id
-
-comicPageHandler :: ComicId -> PageNumber -> Handler (Templated (View Move))
-comicPageHandler id n =
- pure <. Templated <. comicReader id n <. initForm <| comicReaderSpreadLink id n
-
-comicPageFullHandler :: ComicId -> PageNumber -> Handler (Templated (View Move))
-comicPageFullHandler id n =
- pure <. Templated <. comicReader id n <. initForm <| comicReaderFullLink id n
-
-comicVideoHandler :: ComicId -> PageNumber -> Handler (Templated (View Move))
-comicVideoHandler id n =
- pure <. Templated <. comicReader id n <. initForm <| comicVideoLink id n
-
-discoverHandler :: Handler (Templated (View Move))
-discoverHandler = pure <. Templated <. discover <| initForm discoverLink
-
-chooseExperienceHandler :: ComicId -> PageNumber -> Handler (Templated (View Move))
-chooseExperienceHandler id n =
- pure <. Templated <. comicReader id n <. initForm <| chooseExperienceLink id n
-
-loginHandler :: Handler (Templated (View Move))
-loginHandler = pure <. Templated <. login <| initForm loginLink
diff --git a/Hero/Keep.hs b/Hero/Keep.hs
deleted file mode 100644
index 10ef732..0000000
--- a/Hero/Keep.hs
+++ /dev/null
@@ -1,109 +0,0 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module Hero.Keep
- ( HeroKeep,
- GetComics (..),
- getComics,
- NewComic (..),
- newComic,
- open,
- close,
- )
-where
-
-import Alpha
-import Data.Acid (Update, makeAcidic)
-import qualified Data.Acid as Acid
-import Data.Data (Data, Typeable)
-import Data.IxSet (Indexable (..), IxSet, ixFun, ixSet)
-import qualified Data.IxSet as IxSet
-import Data.SafeCopy (base, deriveSafeCopy)
-import qualified Data.Text as Text
-import Hero.Core
-
--- * Keep
-
--- | Main database.
-data HeroKeep = HeroKeep
- { _comics :: IxSet Comic,
- _users :: IxSet User
- }
- deriving (Data, Typeable)
-
-$(deriveSafeCopy 0 'base ''HeroKeep)
-
--- * Index @Comic@
-
-$(deriveSafeCopy 0 'base ''Comic)
-
-$(deriveSafeCopy 0 'base ''User)
-
-$(deriveSafeCopy 0 'base ''ComicId)
-
-instance Indexable Comic where
- empty =
- ixSet
- [ ixFun <| \c -> [comicId c],
- ixFun <| \c -> [comicPages c],
- ixFun <| \c -> [comicName c],
- ixFun <| \c -> [comicIssue c],
- ixFun <| \c -> [comicDescription c]
- ]
-
-instance Indexable User where
- empty =
- ixSet
- [ ixFun <| \u -> [userEmail u],
- ixFun <| \u -> [userName u],
- ixFun <| \u -> [userLibrary u]
- ]
-
-newComic :: Comic -> Update HeroKeep Comic
-newComic c = do
- keep <- get
- put <| keep {_comics = IxSet.insert c (_comics keep)}
- pure c
-
-getComics :: Int -> Acid.Query HeroKeep [Comic]
-getComics n = ask /> _comics /> IxSet.toList /> take n
-
--- * Opening the keep
-
-$(makeAcidic ''HeroKeep ['newComic, 'getComics])
-
-initialHeroKeep :: HeroKeep
-initialHeroKeep =
- HeroKeep
- { _comics = IxSet.fromList [theRed],
- _users =
- IxSet.fromList
- [ User "a" "micheal" [],
- User "b" "ben" []
- ]
- }
- where
- theRed =
- Comic
- { comicId = "1",
- comicPages = 42,
- comicName = "The Red",
- comicIssue = "1.0",
- comicDescription =
- Text.unlines
- [ "In the future, a nuclear world war has changed the course",
- "of history forever. A single government entity now presides",
- "over what's left of the world, and prohibits certain content",
- "that is deemed emotionall dangerous, or \"red\", in attempt",
- "to maintain order and keep society working..."
- ]
- }
-
-open :: String -> IO (Acid.AcidState HeroKeep)
-open dir = Acid.openLocalStateFrom dir initialHeroKeep
-
-close :: Acid.AcidState HeroKeep -> IO ()
-close = Acid.closeAcidState
diff --git a/Hero/Look.hs b/Hero/Look.hs
deleted file mode 100644
index e3958d5..0000000
--- a/Hero/Look.hs
+++ /dev/null
@@ -1,568 +0,0 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
-{- HLINT ignore "Use |>" -}
-
--- | Styles
---
--- Eventually move make this mostly well-typed. Use this EDSL:
--- http://fvisser.nl/clay/
-module Hero.Look where
-
-import Alpha hiding (rem, (**), (|>))
-import Clay
-import qualified Clay.Flexbox as Flexbox
-import qualified Clay.Media as Media
-import qualified Clay.Render as Clay
-import qualified Clay.Stylesheet as Stylesheet
-import qualified Data.Map as Map
-import qualified Data.Text.Lazy as L
-import Hero.Look.Typography as Typo
-import Miso (Attribute, style_, (=:))
-import Miso.String (MisoString, toMisoString)
-
-main :: Css
-main = do
- -- bulma adjustments
- input ? marginRight (px 10) <> marginBottom (px 10)
- -- base
- ".fixed" ? position fixed
- ".clickable" ? clickable
- ".row" ? centerJustify
- a <> a # hover <> a # visited ? do
- color white
- textDecoration none
- ".loading" ? do
- centered
- height <| vh 100
- width <| vw 100
- -- animations
- ".grow" ? do
- transition "all" (sec 0.2) easeInOut (sec 0.2)
- ":hover" & transform (scale 1.1 1.1)
- ".blur-out" ? do
- position absolute
- animation
- "blur"
- (sec 1)
- easeInOut
- (sec 1)
- (iterationCount 1)
- normal
- forwards
- keyframes
- "blur"
- [ (0, Clay.filter <| blur (px 0)),
- (50, Clay.filter <| blur (px 0)),
- (100, Clay.filter <| blur (px 10))
- ]
- html <> body ? do
- background nite
- mobile <| do
- overflowX hidden
- width (vw 100)
- -- general app wrapper stuf
- ".app" ? do
- display flex
- justifyContent spaceBetween
- alignItems stretch
- flexDirection column
- color white
- "#hero-logo" ? zIndex (-1)
- "#app-head" <> "#app-body" <> "#app-foot" ? flexGrow 1
- "#app-head" <> "#app-foot" ? do
- display flex
- alignItems center
- flexShrink 0
- justifyContent spaceBetween
- padding 0 (rem 2) 0 (rem 2)
- width (pct 100)
- height (px navbarHeight)
- background nite
- position fixed
- zIndex 999
- "#app-head" ? do
- alignSelf flexStart
- borderBottom solid (px 3) grai
- wide
- top (px 0)
- mobile <| noBorder <> width (vw 100)
- "#app-body" ? do
- display flex
- desktop <| width (vw 93)
- alignContent center
- alignItems flexStart
- justifyContent flexStart
- flexDirection column
- flexShrink 0
- padding (px 0) 0 0 0
- marginY <| px 74
- mobile <| flexDirection column
- "#discover #app-body" ? do desktop <| marginLeft appmenuWidth
- "#app-head-right" ? do
- display flex
- justifyContent spaceBetween
- textTransform Clay.uppercase
- thicc
- alignItems center
- width (px 200)
- "#app-foot" ? do
- alignSelf flexEnd
- bottom (px 0)
- mobile remove
- "#app-foot-social" ? do
- display flex
- flexDirection column
- alignSelf flexStart
- ".social-icon" ? padding 0 (px 20) (px 10) 0
- "#app-foot-logo" ? do
- display flex
- flexDirection column
- alignItems flexEnd
- "#app-foot-quote" ? do
- textTransform Clay.uppercase
- textAlign center
- -- hide app-foot-quote when it gets crowded
- query
- Clay.all
- [Media.maxDeviceWidth (px 800)]
- hide
- -- login
- "#login" ? do
- -- TODO: next 3 lines can be DRYed up, methinks
- centered
- height (vh 100)
- "#login-inner" ? do
- centered
- flexDirection column
- zIndex 1
- height (vh 100)
- width (px 400)
- mobile <| width (vw 90)
- "#login" ** ".help" ** a ? do
- color white
- display flex
- alignItems center
- flexDirection column
- "#login" ** form <> "#login" ** hr
- ? width (pct 100)
- "#login" ** hr ? border solid (px 1) grai
- "#login" ** ".button" ? do
- marginTop (px 10)
- display inlineBlock
- border solid (px 2) white
- "#login" ** ".action" ? do
- display flex
- justifyContent spaceBetween
- alignItems baseline
- -- choose your experience
- "#choose-experience" ** "#app-body" ? do
- euro <> wide
- flexCenter
- width (pct 100)
- desktop <| marginLeft appmenuWidth <> height (vh 90)
- mobile <| marginX (rem 0) <> marginTop (rem 0) <> minHeight (vh 90)
- h2 ? do
- thicc <> wide <> smol <> lower <> coat 2
- textAlign center
- mobile <| coat 0.8
- p ? do
- thicc <> coat 0.8 <> textAlign center
- maxWidth (px 900)
- marginAll (rem 1)
- mobile <| coat 0.6
- ul ? do
- display flex
- flexDirection row
- flexWrap Flexbox.wrap
- justifyContent spaceAround
- li ? do
- width (px 111)
- position relative
- display flex
- flexDirection column
- textAlign center
- mobile <| coat 0.6
- coat 0.8 <> clickable
- divv <? do
- position relative
- flexCenter
- flexDirection column
- span <? do
- position absolute
- width (pct 100)
- smol <> thicc
- -- comic player
- ".comic-player" ? marginAll auto
- ".comic-page" <> ".comic-page-full" ? do
- width auto
- marginAll auto
- transform (scale 1 1)
- ".comic-page" ? height (vh 90)
- let ccb = ".comic-controls" ** button
- ccb <> ccb # hover ? do
- background nite
- borderColor nite
- color white
- ".comic-controls-pages" ? do
- justifyContent center
- alignItems center
- display flex
- ".comic-video" & iframe ? do
- position absolute
- height (pct 93)
- width (pct 100)
- "#close-button" ? do
- euro <> wide
- position fixed
- cursor pointer
- let z = rem 1.8
- fontSize z
- lineHeight z
- let m = 24 :: Double
- top <| px <| navbarHeight + m
- left <| px m
- zIndex 999
- -- zoom button and slider
- "#zoom-button" ? do
- position relative
- let sliderY = 75
- let sliderYY = 250
- euro <> wide
- input ? do
- transform <| Clay.rotate (deg (-90))
- margin 0 0 (px sliderYY) 0
- position absolute
- height <| px sliderY
- width <| px 200
- hide
- label ? do
- coat 0.9
- marginBottom <| px <| 2 * sliderYY
- position absolute
- hide
- ":hover" & ".ctrl" ? visibility visible
- -- discover
- "#discover" ? do
- alignItems flexStart
- flexDirection column
- ".media-info" ? do
- padding (rem 2) 0 (rem 2) (rem 2)
- margin (rem 2) 0 (rem 2) (rem 2)
- borderTop solid (px 1) white
- borderBottom solid (px 1) white
- flexDirection row
- centerJustify
- mobile <| do
- margin (rem 2) 0 (rem 2) 0
- padding 0 0 0 (rem 0)
- noBorder
- width (vw 100)
- flexDirection column
- ".media-info-meta" ? do
- Flexbox.flex 2 1 (px 0)
- display flex
- flexDirection row
- divv # lastChild <? paddingLeft (rem 1)
- mobile <| do
- width (vw 90) -- this line can be commented if you want to center the meta
- img ? width (px 150)
- order (-1)
- Flexbox.flex 1 1 auto
- ".media-info-summary" ? do
- Flexbox.flex 2 1 (px 0)
- paddingRight (rem 3)
- mobile <| do
- marginAll (rem 1)
- padding 0 0 0 (rem 0)
- ".media-info-actions" ? do
- Flexbox.flex 1 1 (px 132)
- maxWidth (px 132)
- display flex
- flexDirection column
- justifyContent spaceAround
- mobile <| do
- maxWidth (vw 100)
- flexDirection row
- order 1
- flexBasis auto -- initial
- height (px 50)
- -- appmenu
- "#appmenu" ? do
- euro <> wide
- fontVariant smallCaps
- position fixed
- height (pct 100)
- display flex
- justifyContent center
- zIndex 99
- alignContent center
- alignItems center
- flexDirection column
- minWidth appmenuWidth
- a ? do
- display flex
- flexDirection column
- color white
- background nite
- borderColor nite
- a |> img ? do
- width (px 22)
- height (px 22)
- desktop <| a |> span ? remove
- mobile <| do
- order 2
- flexDirection row
- position fixed
- bottom (px 0)
- width (vw 100)
- height (px 74)
- background nite
- justifyContent center
- alignItems center
- a |> span ? fontSize (rem 0.5)
- button ? margin (rem 0.5) 0 (rem 0.5) 0
- -- feature
- "#featured-comic" ? do
- display flex
- justifyContent center
- alignSelf flexStart
- flexDirection column
- Typo.euro
- height (px 411)
- mobile <| do
- padding (px 0) 0 0 0
- margin 0 0 (px 50) 0
- after & do
- display block
- position relative
- background
- <| linearGradient
- (straight sideTop)
- [ (setA 0 nite, pct 0),
- (nite, pct 100)
- ]
- let h = 149
- marginTop (px (- h))
- -- without +1, the gradient is offset by 1 px in chrome
- height (px (h + 1))
- content blank
- ".hero-original" ? do
- textTransform Clay.uppercase
- fontSize (rem 1.2)
- ".description" ? do
- width (px 400)
- mobile remove
- "#featured-banner" ? do
- position relative
- minHeight (px 411)
- minWidth (px 1214)
- mobile <| marginLeft (px (-310))
- "#featured-content" ? do
- position absolute
- width (pct 100)
- zIndex 9
- top (px 200) -- b/c Firefox & WebKit autocalc "top" differently
- mobile <| do
- marginTop (px 200)
- alignItems center
- display flex
- flexDirection column
- padding (rem 0.5) (rem 0.5) (rem 0.5) (rem 0.5)
- width (vw 100)
- -- buttons
- "a.wrs-button" ? do
- -- the "watch/read/save" button
- flexCenter
- height (px 36)
- width (px 132)
- border solid (px 2) white
- rounded
- color white
- margin 0 (px 15) (rem 1) 0
- fontSize (rem 0.8)
- fontVariant smallCaps
- euro <> thicc <> wide
- mobile <| do
- height (px 26)
- width (px 100)
- margin 0 (px 5) 0 (px 5)
- fontSize (rem 0.6)
- let alive = backgroundColor hero <> borderColor hero <> color white
- ":hover" & alive
- ".saved" & alive
- img ? do
- marginRight (px 7)
- height (px 15)
- mobile <| height (px 10)
- --
- ".comic-action-menu" ? display flex <> justifyContent (JustifyContentValue "left")
- -- shelving
- ".shelf" ? do
- display flex
- flexDirection column
- justifyContent flexStart
- alignItems flexStart
- mobile <| do
- padding (rem 0.5) (rem 0.5) (rem 0.5) (rem 0.5)
- width (vw 100)
- ".comic" ? do
- centered
- flexDirection column
- textAlign center
- euro
- maxWidth (px 110)
- img ? do
- marginBottom (rem 0.5)
- minHeight (px 170)
- minWidth (px 110)
- ".shelf-head" ? do
- width (pct 100)
- margin (rem 1.5) 0 (rem 1.5) 0
- borderBottom solid (px 1) white
- padding (rem 0.5) 0 0.5 0
- euro <> thicc
- ".shelf-body" ? do
- display flex
- flexDirection row
- justifyContent spaceBetween
- width (vw 93)
- alignItems baseline
- li ? padding 0 (rem 0.5) 0 (rem 0.5)
- overflowY visible
- star ? overflowY visible
- overflowX scroll
- flexWrap Flexbox.nowrap
- li <? do
- margin 0 (rem 1) (rem 1) 0
- Flexbox.flex 0 0 auto
-
-navbarHeight :: Double
-navbarHeight = 74
-
-centered :: Css
-centered = do
- display flex
- justifyContent center
- alignItems center
- alignSelf center
-
-centerJustify :: Css
-centerJustify = do
- display flex
- alignItems center
- justifyContent spaceBetween
-
-hide :: Css
-hide = visibility hidden
-
-remove :: Css
-remove = display none
-
-noBorder :: Css
-noBorder = border none 0 transparent
-
-mobile :: Css -> Css
-mobile = query Clay.all [Media.maxDeviceWidth (px 500)]
-
-desktop :: Css -> Css
-desktop = query Clay.all [Media.minDeviceWidth (px 500)]
-
-rounded :: Css
-rounded = borderRadius (px 30) (px 30) (px 30) (px 30)
-
-appmenuWidth :: Size LengthUnit
-appmenuWidth = px 67
-
-flexCenter :: Css
-flexCenter = do
- display flex
- justifyContent center
- justifyItems center
- alignContent center
- alignItems center
-
-blank :: Content
-blank = stringContent ""
-
-divv :: Clay.Selector
-divv = Clay.div
-
-marginAll :: Size a -> Css
-marginAll x = margin x x x x
-
-marginX :: Size a -> Css
-marginX n = marginLeft n <> marginRight n
-
-marginY :: Size a -> Css
-marginY n = marginTop n <> marginBottom n
-
-clickable :: Css
-clickable = cursor pointer
-
--- heroic colors ---------------------------------------------------------------
-
-hero :: Color
-hero = rgb 241 32 32 -- #f12020
-
-nite :: Color
-nite = rgb 10 10 10 -- #0a0a0a
-
-grai :: Color
-grai = rgb 221 221 221 -- #dddddd
-
--- runtime (client) style stuff ------------------------------------------------
-
--- | Put 'Clay.Css' into a Miso-compatible style property.
---
--- Allows us to use any amount of CSS written with Clay inlined in HTML or
--- dynamically as JavaScript object properties. The implementation is a bit
--- hacky, but works.
-css :: Clay.Css -> Attribute action
-css = Miso.style_ <. Map.fromList <. f <. Clay.renderWith Clay.htmlInline []
- where
- f :: L.Text -> [(MisoString, MisoString)]
- f t =
- L.splitOn ";" t
- <&> L.splitOn ":"
- <&> \(x : y) -> (toMisoString x, toMisoString <| L.intercalate ":" y)
-
-inlineCss :: Css -> MisoString
-inlineCss = toMisoString <. render
-
-type Style = Map MisoString MisoString
-
-red :: MisoString
-red = "#f12020"
-
-bold :: Style
-bold = "font-weight" =: "bold"
-
-condensed :: Style
-condensed = "font-stretch" =: "condensed"
-
-expanded :: Style
-expanded = "font-stretch" =: "expanded"
-
-uppercase :: Style
-uppercase = "text-transform" =: "uppercase"
-
----------------------------------------------------------------------------------
--- upstream this to Clay
----------------------------------------------------------------------------------
-
-newtype JustifyItemsValue = JustifyItemsValue Value
- deriving
- ( Val,
- Other,
- Inherit,
- Center,
- FlexEnd,
- FlexStart,
- SpaceAround,
- SpaceBetween
- )
-
-justifyItems :: JustifyItemsValue -> Css
-justifyItems = Stylesheet.key "justify-items"
diff --git a/Hero/Look/Typography.hs b/Hero/Look/Typography.hs
deleted file mode 100644
index 603e78b..0000000
--- a/Hero/Look/Typography.hs
+++ /dev/null
@@ -1,84 +0,0 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module Hero.Look.Typography where
-
-import Alpha
-import Clay
-import Clay.Stylesheet (key)
-import Data.Semigroup ((<>))
-import qualified Hero.Pack as Pack
-
-main :: Css
-main = fonts
-
--- font modifiers
-
-euro, slim, wide, thicc, thinn, norm, lean, smol, lower, upper :: Css
-euro = fontFamily ["Eurostile"] [sansSerif]
-
--- | stretch
-slim = fontStretch condensed
-
-wide = fontStretch expanded
-
--- | weight
-thicc = fontWeight bold
-
-thinn = fontWeight normal
-
--- | style
-norm = fontStyle normal
-
-lean = fontStyle italic
-
--- | "smallcaps" is already taken by Clay
-smol = fontVariant smallCaps
-
-lower = textTransform Clay.lowercase
-
-upper = textTransform uppercase
-
--- | font sizing
-
--- | apparently "coat" is a synonym for "size"
-coat :: Double -> Css
-coat = fontSize <. Clay.rem
-
-fontRoot :: Text
-fontRoot = Pack.cdnEdge <> "/old-assets/fonts/eurostile/Eurostile"
-
--- | font faces
-fonts :: Css
-fonts =
- mconcat
- <| mkEuro
- </ [ ("-Reg.otf", OpenType, fontWeight normal <> fontStyle normal),
- ("LTStd-Bold.otf", OpenType, thicc <> norm),
- ("LTStd-Cn.otf", OpenType, slim <> norm),
- ("LTStd-Ex2.otf", OpenType, wide <> norm),
- ("LTStd-BoldCn.otf", OpenType, slim <> thicc),
- ("LTStd-BoldEx2.otf", OpenType, wide <> thicc)
- ]
- where
- mkEuro :: (Text, FontFaceFormat, Css) -> Css
- mkEuro (sufx, fmt, extra) =
- fontFace <| do
- fontFamily ["Eurostile"] []
- fontFaceSrc [FontFaceSrcUrl (fontRoot <> sufx) <| Just fmt]
- extra
-
--- TODO: add the below to Clay.Font upstream
-
-newtype FontStretch = FontStretch Value
- deriving (Val, Inherit, Normal, Other)
-
-expanded :: FontStretch
-expanded = FontStretch "expanded"
-
-condensed :: FontStretch
-condensed = FontStretch "condensed"
-
-fontStretch :: FontStretch -> Css
-fontStretch = key "font-stretch"
diff --git a/Hero/Node.hs b/Hero/Node.hs
deleted file mode 100644
index 11190e7..0000000
--- a/Hero/Node.hs
+++ /dev/null
@@ -1,248 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
--- | Hero app frontend
---
--- : out mmc.js
-module Hero.Node where
-
-import Alpha
-import Biz.Auth as Auth
-import qualified Data.Aeson as Aeson
-import qualified Data.Set as Set
-import qualified GHC.Show as Legacy
-import GHCJS.Types (JSVal)
-import Hero.Core
- ( AudioState (..),
- Comic (..),
- ComicReaderState (..),
- ComicReaderView (..),
- Form (..),
- LoginForm (..),
- Move (..),
- User (..),
- audioId,
- chooseExperienceLink,
- comicReaderFullLink,
- comicReaderSpreadLink,
- comicVideoLink,
- discoverLink,
- handlers,
- initForm,
- routes,
- the404,
- )
-import JavaScript.Web.XMLHttpRequest as Ajax
-import Miso
-import Miso.Effect.DOM (scrollIntoView)
-import qualified Miso.FFI.Audio as Audio
-import qualified Miso.FFI.Document as Document
-import qualified Miso.FFI.Fullscreen as Fullscreen
-import Miso.String
-import qualified Network.RemoteData as Network
-
--- | Entry point for a miso application
-main :: IO ()
-main = miso <| \currentURI -> App {model = initForm currentURI, ..}
- where
- update = move
- view = see
- subs =
- [ uriSub HandleURI,
- keyboardSub keynav
- ]
- events = defaultEvents
- initialAction = NoOp
- mountPoint = Nothing
-
-(∈) :: Ord a => a -> Set a -> Bool
-(∈) = Set.member
-
--- | Keyboard navigation - maps keys to actions.
-keynav :: Set Int -> Move
-keynav ks
- | 37 ∈ ks = PrevPage -- ←
- | 39 ∈ ks = NextPage -- →
- | 191 ∈ ks = Dumpform -- ?
- | 32 ∈ ks = ToggleAudio audioId -- SPC
- | otherwise = NoOp
-
-see :: Form -> View Move
-see form =
- case runRoute routes handlers uri form of
- Left _ -> the404 form
- Right v -> v
-
--- | Console-logging
-foreign import javascript unsafe "console.log($1);"
- jslog :: MisoString -> IO ()
-
-foreign import javascript unsafe "$1.value"
- getValue :: JSVal -> IO MisoString
-
--- | Updates form, optionally introduces side effects
-move :: Move -> Form -> Effect Move Form
-move NoOp form = noEff form
-move Dumpform form =
- form <# do
- jslog <| ms <| Legacy.show form
- pure NoOp
-move (SelectExperience comic) form =
- form {cpState = ChooseExperience (comicId comic) 1}
- <# do pure <| ChangeURI <| chooseExperienceLink (comicId comic) 1
-move (StartReading comic) form =
- form {cpState = Reading Spread (comicId comic) 1}
- <# do pure <| ChangeURI <| comicReaderSpreadLink (comicId comic) 1
-move (StartWatching comic) form =
- form {cpState = Watching (comicId comic)}
- <# do pure <| ChangeURI <| comicVideoLink (comicId comic) 1
-move NextPage form = case cpState form of
- Reading Spread id pg ->
- form {cpState = Reading Spread id (pg + 2)} <# do
- pure <| ChangeURI <| comicReaderSpreadLink id (pg + 2)
- Reading Full id pg ->
- form {cpState = Reading Full id (pg + 1)} <# do
- pure <| ChangeURI <| comicReaderFullLink id (pg + 1)
- Cover id ->
- form {cpState = Reading Spread id 1} <# do
- pure <| ChangeURI <| comicReaderSpreadLink id 1
- _ -> noEff form
-move PrevPage form = case cpState form of
- Reading Spread id pg ->
- form {cpState = Reading Spread id (pg -2)} <# do
- pure <| ChangeURI <| comicReaderSpreadLink id (pg -2)
- Reading Full id pg ->
- form {cpState = Reading Full id (pg -1)} <# do
- pure <| ChangeURI <| comicReaderFullLink id (pg -1)
- Cover _ -> noEff form
- _ -> noEff form
-move (ToggleZoom c pg) m = m {cpState = newState} <# pure act
- where
- goto lnk = ChangeURI <| lnk (comicId c) pg
- reading v = Reading v (comicId c) pg
- (newState, act) = case cpState m of
- Reading Full _ _ -> (reading Spread, goto comicReaderSpreadLink)
- Reading Spread _ _ -> (reading Full, goto comicReaderFullLink)
- x -> (x, NoOp)
-move (ToggleInLibrary c) form = form {user = newUser} <# pure NoOp
- where
- newUser = (user form) {userLibrary = newLib}
- newLib
- | c `elem` (userLibrary <| user form) =
- Alpha.filter (/= c) <| userLibrary <| user form
- | otherwise = c : (userLibrary <| user form)
-move (HandleURI u) form = form {uri = u} <# pure NoOp
-move (ChangeURI u) form =
- form <# do
- pushURI u
- pure NoOp
-move FetchComics form = form <# (SetComics <$> fetchComics)
-move (SetComics cs) form = noEff form {appComics = cs}
-move (ToggleAudio i) form =
- form {cpAudioState = newState} <# do
- el <- Document.getElementById i
- toggle el
- pure NoOp
- where
- (newState, toggle) = case cpAudioState form of
- Playing -> (Paused, Audio.pause)
- Paused -> (Playing, Audio.play)
-move ToggleFullscreen form =
- form {cpState = newState} <# do
- el <- Document.querySelector "body"
- -- TODO: check Document.fullscreenEnabled
- -- https://developer.mozilla.org/en-US/docs/Web/API/Document/fullscreenEnabled
- _ <- toggle el
- pure NoOp
- where
- (toggle, newState) = case cpState form of
- Reading Full c n -> (const Fullscreen.exit, Reading Full c n)
- Reading Spread c n -> (Fullscreen.request, Reading Spread c n)
- -- otherwise, do nothing:
- x -> (pure, x)
-move (SetMediaInfo x) form =
- form {dMediaInfo = x}
- <# case x of
- Just Comic {comicId = id} ->
- pure <| ScrollIntoView <| "comic-" <> ms id
- Nothing ->
- pure NoOp
-move (ScrollIntoView id) form =
- form <# do
- jslog <| ms <| Legacy.show id
- scrollIntoView id
- pure NoOp
-move ValidateUserPassword form =
- batchEff
- form
- [doLogin, pure FetchComics, pure <| ChangeURI discoverLink]
- where
- doLogin = do
- user <- getValue =<< Document.getElementById "user"
- pass <- getValue =<< Document.getElementById "pass"
- sendLogin (ms user) (ms pass) +> \case
- Network.Success _ -> pure NoOp
- -- TODO: handle these error cases
- Network.Loading -> pure NoOp
- Network.Failure _ -> pure NoOp
- Network.NotAsked -> pure NoOp
-
-fetchComics :: IO (Network.RemoteData MisoString [Comic])
-fetchComics =
- Ajax.xhrByteString req /> Ajax.contents +> \case
- Nothing ->
- pure <| Network.Failure "Could not fetch comics from server."
- Just json ->
- json
- |> Aeson.eitherDecodeStrict
- |> either (Left <. ms) pure
- |> Network.fromEither
- |> pure
- where
- req =
- Ajax.Request
- { Ajax.reqMethod = Ajax.GET,
- Ajax.reqURI = "/api/comic", -- FIXME: can we replace this hardcoding?
- Ajax.reqLogin = Nothing,
- Ajax.reqHeaders = [],
- Ajax.reqWithCredentials = True,
- Ajax.reqData = Ajax.NoData
- }
-
-sendLogin ::
- -- | User
- MisoString ->
- -- | Password
- MisoString ->
- IO
- ( Network.RemoteData
- MisoString
- User
- )
-sendLogin u p =
- Ajax.xhrByteString req /> Ajax.contents +> \case
- Nothing ->
- pure <| Network.Failure "Could not send login request."
- Just json ->
- pure <| Network.fromEither
- <| either (Left <. ms) pure
- <| Aeson.eitherDecodeStrict json
- where
- req =
- Ajax.Request
- { Ajax.reqMethod = Ajax.POST,
- Ajax.reqURI = "/auth",
- Ajax.reqLogin = Nothing, -- FIXME?
- Ajax.reqHeaders =
- [ ("Accept", "application/json"),
- ("Content-Type", "application/json")
- ],
- Ajax.reqWithCredentials = True,
- Ajax.reqData =
- LoginForm (fromMisoString u) (fromMisoString p)
- |> Aeson.encode
- |> ms
- |> Ajax.StringData
- }
diff --git a/Hero/Pack.hs b/Hero/Pack.hs
deleted file mode 100644
index d5c3a35..0000000
--- a/Hero/Pack.hs
+++ /dev/null
@@ -1,16 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
--- | A module to wrap the CDN and provide convient helper functions to assets.
-module Hero.Pack where
-
-import Protolude
-
-cdnEdge :: Text
-cdnEdge = "https://heroverse.sfo2.cdn.digitaloceanspaces.com"
-
-demo :: Text
-demo = cdnEdge <> "/old-assets/demo/"
-
-icon :: Text
-icon = cdnEdge <> "/icons/"
diff --git a/Hero/Prod.nix b/Hero/Prod.nix
deleted file mode 100644
index 3f2ced7..0000000
--- a/Hero/Prod.nix
+++ /dev/null
@@ -1,57 +0,0 @@
-{ bild ? import ../Biz/Bild.nix {}
-, nixpkgs ? import ../Biz/Bild/Nixpkgs.nix
-}:
-
-# Production server for herocomics.app
-
-bild.os {
- imports = [
- ../Biz/OsBase.nix
- ../Biz/Packages.nix
- ../Biz/Users.nix
- ./Service.nix
- ];
- networking.hostName = "prod-herocomics";
- networking.domain = "herocomics.app";
- boot.loader.grub.device = "/dev/vda";
- fileSystems."/" = { device = "/dev/vda1"; fsType = "ext4"; };
- networking = {
- firewall.allowedTCPPorts = [ 22 80 443 ];
- nameservers = [
- "67.207.67.2"
- "67.207.67.3"
- ];
- defaultGateway = "138.68.40.1";
- defaultGateway6 = "";
- dhcpcd.enable = false;
- usePredictableInterfaceNames = nixpkgs.lib.mkForce true;
- interfaces = {
- eth0 = {
- ipv4.addresses = [
- { address="138.68.40.97"; prefixLength=21; }
- { address="10.46.0.5"; prefixLength=16; }
- ];
- ipv6.addresses = [
- { address="fe80::b063:c4ff:fee5:d636"; prefixLength=64; }
- ];
- ipv4.routes = [ { address = "138.68.40.1"; prefixLength = 32; } ];
- ipv6.routes = [ { address = ""; prefixLength = 32; } ];
- };
-
- };
- };
-
- services = {
- herocomics = {
- enable = true;
- port = 3000;
- host = bild.ghc ./Host.hs;
- node = bild.ghcjs ./Node.hs;
- keep = "/var/lib/hero";
- };
-
- udev.extraRules = ''
- ATTR{address}=="b2:63:c4:e5:d6:36", NAME="eth0"
- '';
- };
-}
diff --git a/Hero/Service.nix b/Hero/Service.nix
deleted file mode 100644
index 906d98e..0000000
--- a/Hero/Service.nix
+++ /dev/null
@@ -1,88 +0,0 @@
-{ options
-, lib
-, config
-, pkgs
-, ...
-}:
-
-let
- cfg = config.services.herocomics;
-in
-{
- options.services.herocomics = {
- enable = lib.mkEnableOption "Enable the herocomics service";
- port = lib.mkOption {
- type = lib.types.int;
- default = 3000;
- description = ''
- The port on which herocomics-server will listen for incoming HTTP traffic.
- '';
- };
- keep = lib.mkOption {
- type = lib.types.path;
- default = "/var/lib/hero";
- description = "herocomics-server database directory";
- };
- host = lib.mkOption {
- type = lib.types.package;
- description = "herocomics-server package to use";
- };
- node = lib.mkOption {
- type = lib.types.package;
- description = "herocomics-client package to use";
- };
- skey = lib.mkOption {
- type = lib.types.path;
- default = "/run/hero/skey";
- description = "where to store the signing key";
- };
- domain = lib.mkOption {
- type = lib.types.str;
- default = "herocomics.app";
- description = ''
- Domain on which to bind herocomics-server. This is passed
- to services.nginx.virtualHosts.<name> directly.
- '';
- };
- };
- config = lib.mkIf cfg.enable {
- systemd.services.herocomics = {
- path = [ cfg.host ];
- wantedBy = [ "multi-user.target" ];
- script = ''
- ${cfg.host}/bin/mmc
- '';
- description = ''
- Hero Comics app server
- '';
- serviceConfig = {
- KillSignal = "INT";
- Environment = [
- "HERO_NODE=${cfg.node}/static"
- "HERO_PORT=${toString cfg.port}"
- "HERO_KEEP=${cfg.keep}"
- "HERO_SKEY=/run/hero/skey"
- ];
- Type = "simple";
- Restart = "on-abort";
- RestartSec = "1";
- };
- };
- services.nginx = {
- enable = cfg.enable;
- recommendedGzipSettings = true;
- recommendedOptimisation = true;
- recommendedProxySettings = true;
- recommendedTlsSettings = true;
- virtualHosts = {
- "${cfg.domain}" = {
- forceSSL = true;
- enableACME = true;
- locations."/" = {
- proxyPass = "http://localhost:${toString cfg.port}";
- };
- };
- };
- };
- };
-}
diff --git a/Miso/Extend.hs b/Miso/Extend.hs
deleted file mode 100644
index 9ebdd08..0000000
--- a/Miso/Extend.hs
+++ /dev/null
@@ -1,28 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module Miso.Extend
- ( crossorigin_,
- onPreventClick,
- )
-where
-
-import Alpha
-import Miso
-import Miso.String
-
--- | HTML crossorigin attribute
---
--- https://developer.mozilla.org/en-US/docs/Web/HTML/Attributes/crossorigin
-crossorigin_ :: MisoString -> Attribute action
-crossorigin_ = textProp "crossorigin"
-
--- | Like 'onClick' but prevents the default action from triggering. Use this to
--- overide 'a_' links, for example.
-onPreventClick :: action -> Attribute action
-onPreventClick action =
- onWithOptions
- Miso.defaultOptions {preventDefault = True}
- "click"
- emptyDecoder
- (\() -> action)
diff --git a/Miso/FFI/Audio.hs b/Miso/FFI/Audio.hs
deleted file mode 100644
index b34960b..0000000
--- a/Miso/FFI/Audio.hs
+++ /dev/null
@@ -1,21 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module Miso.FFI.Audio where
-
-import GHCJS.Types
-import Protolude
-
-{-
-Usage:
-
-obj <- Miso.FFI.Document.getElementById "myAudioPlayer"
-play obj
-pause obj
-
--}
-
-foreign import javascript unsafe "$1.play();"
- play :: JSVal -> IO ()
-
-foreign import javascript unsafe "$1.pause();"
- pause :: JSVal -> IO ()
diff --git a/Miso/FFI/Document.hs b/Miso/FFI/Document.hs
deleted file mode 100644
index b4fe44f..0000000
--- a/Miso/FFI/Document.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module Miso.FFI.Document where
-
-import GHCJS.Types
-import Protolude
-
-foreign import javascript unsafe "$r = document.getElementById($1);"
- getElementById :: JSString -> IO JSVal
-
-foreign import javascript unsafe "$r = document.querySelector($1);"
- querySelector :: JSString -> IO JSVal
diff --git a/Miso/FFI/Fullscreen.hs b/Miso/FFI/Fullscreen.hs
deleted file mode 100644
index 4e70da6..0000000
--- a/Miso/FFI/Fullscreen.hs
+++ /dev/null
@@ -1,29 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module Miso.FFI.Fullscreen where
-
-import GHCJS.Types
-import Protolude
-
--- | Requests that the user agent switch from full-screen mode back to windowed
--- mode. Returns a Promise which is resolved once full-screen mode has been
--- completely shut off.
---
--- https://developer.mozilla.org/en-US/docs/Web/API/Document/exitFullscreen
-foreign import javascript unsafe "$r = document.exitFullscreen();"
- exitFullscreen :: IO JSVal
-
-exit :: IO JSVal
-exit = exitFullscreen
-
--- | Asks the user agent to place the specified element (and, by extension, its
--- descendants) into full-screen mode, removing all of the browser's UI elements
--- as well as all other applications from the screen. Returns a Promise which is
--- resolved once full-screen mode has been activated.
---
--- https://developer.mozilla.org/en-US/docs/Web/API/Element/requestFullscreen
-foreign import javascript unsafe "$r = $1.requestFullscreen();"
- requestFullscreen :: JSVal -> IO JSVal
-
-request :: JSVal -> IO JSVal
-request = requestFullscreen
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-01 04:32:29 +0000