working nix setup and a working database setup
This commit is contained in:
parent
2b82da81f8
commit
b61dc2d4fc
7 changed files with 556 additions and 139 deletions
|
|
@ -1,9 +1,5 @@
|
|||
-- | Haskell language pragma
|
||||
|
||||
-- | Haskell module declaration
|
||||
module Main where
|
||||
|
||||
-- | Miso framework import
|
||||
import Data.Proxy
|
||||
import Miso
|
||||
import Miso.Router
|
||||
|
|
@ -50,8 +46,6 @@ viewModel :: Model -> View Action
|
|||
viewModel m = div_ [] [text "it worked"]
|
||||
|
||||
|
||||
-- tempURI _ = URI "http://" Nothing "" "" ""
|
||||
|
||||
-- currPoll = runRoute (Proxy :: Proxy A.RCVAPI) handlers uri m of
|
||||
|
||||
|
||||
|
|
|
|||
328
flake.lock
generated
Normal file
328
flake.lock
generated
Normal file
|
|
@ -0,0 +1,328 @@
|
|||
{
|
||||
"nodes": {
|
||||
"HTTP": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1451647621,
|
||||
"narHash": "sha256-oHIyw3x0iKBexEo49YeUDV1k74ZtyYKGR2gNJXXRxts=",
|
||||
"owner": "phadej",
|
||||
"repo": "HTTP",
|
||||
"rev": "9bc0996d412fef1787449d841277ef663ad9a915",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "phadej",
|
||||
"repo": "HTTP",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"cabal-32": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1603716527,
|
||||
"narHash": "sha256-sDbrmur9Zfp4mPKohCD8IDZfXJ0Tjxpmr2R+kg5PpSY=",
|
||||
"owner": "haskell",
|
||||
"repo": "cabal",
|
||||
"rev": "94aaa8e4720081f9c75497e2735b90f6a819b08e",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "haskell",
|
||||
"ref": "3.2",
|
||||
"repo": "cabal",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"cabal-34": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1622475795,
|
||||
"narHash": "sha256-chwTL304Cav+7p38d9mcb+egABWmxo2Aq+xgVBgEb/U=",
|
||||
"owner": "haskell",
|
||||
"repo": "cabal",
|
||||
"rev": "b086c1995cdd616fc8d91f46a21e905cc50a1049",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "haskell",
|
||||
"ref": "3.4",
|
||||
"repo": "cabal",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"cabal-36": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1640163203,
|
||||
"narHash": "sha256-TwDWP2CffT0j40W6zr0J1Qbu+oh3nsF1lUx9446qxZM=",
|
||||
"owner": "haskell",
|
||||
"repo": "cabal",
|
||||
"rev": "ecf418050c1821f25e2e218f1be94c31e0465df1",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "haskell",
|
||||
"ref": "3.6",
|
||||
"repo": "cabal",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"cardano-shell": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1608537748,
|
||||
"narHash": "sha256-PulY1GfiMgKVnBci3ex4ptk2UNYMXqGjJOxcPy2KYT4=",
|
||||
"owner": "input-output-hk",
|
||||
"repo": "cardano-shell",
|
||||
"rev": "9392c75087cb9a3d453998f4230930dea3a95725",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "input-output-hk",
|
||||
"repo": "cardano-shell",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"flake-utils": {
|
||||
"locked": {
|
||||
"lastModified": 1642700792,
|
||||
"narHash": "sha256-XqHrk7hFb+zBvRg6Ghl+AZDq03ov6OshJLiSWOoX5es=",
|
||||
"owner": "numtide",
|
||||
"repo": "flake-utils",
|
||||
"rev": "846b2ae0fc4cc943637d3d1def4454213e203cba",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "numtide",
|
||||
"repo": "flake-utils",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"flake-utils_2": {
|
||||
"locked": {
|
||||
"lastModified": 1623875721,
|
||||
"narHash": "sha256-A8BU7bjS5GirpAUv4QA+QnJ4CceLHkcXdRp4xITDB0s=",
|
||||
"owner": "numtide",
|
||||
"repo": "flake-utils",
|
||||
"rev": "f7e004a55b120c02ecb6219596820fcd32ca8772",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "numtide",
|
||||
"repo": "flake-utils",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"ghc-8.6.5-iohk": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1600920045,
|
||||
"narHash": "sha256-DO6kxJz248djebZLpSzTGD6s8WRpNI9BTwUeOf5RwY8=",
|
||||
"owner": "input-output-hk",
|
||||
"repo": "ghc",
|
||||
"rev": "95713a6ecce4551240da7c96b6176f980af75cae",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "input-output-hk",
|
||||
"ref": "release/8.6.5-iohk",
|
||||
"repo": "ghc",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"hackage": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1642813925,
|
||||
"narHash": "sha256-YC6tY9mz1nbHONQugv6/20Tn8eJLHK0ijx3NUU+6/Cw=",
|
||||
"owner": "input-output-hk",
|
||||
"repo": "hackage.nix",
|
||||
"rev": "a10b0a43b4672fc919c23a9c65002811c3da35ee",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "input-output-hk",
|
||||
"repo": "hackage.nix",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"haskellNix": {
|
||||
"inputs": {
|
||||
"HTTP": "HTTP",
|
||||
"cabal-32": "cabal-32",
|
||||
"cabal-34": "cabal-34",
|
||||
"cabal-36": "cabal-36",
|
||||
"cardano-shell": "cardano-shell",
|
||||
"flake-utils": "flake-utils_2",
|
||||
"ghc-8.6.5-iohk": "ghc-8.6.5-iohk",
|
||||
"hackage": "hackage",
|
||||
"hpc-coveralls": "hpc-coveralls",
|
||||
"nix-tools": "nix-tools",
|
||||
"nixpkgs": [
|
||||
"haskellNix",
|
||||
"nixpkgs-2111"
|
||||
],
|
||||
"nixpkgs-2003": "nixpkgs-2003",
|
||||
"nixpkgs-2105": "nixpkgs-2105",
|
||||
"nixpkgs-2111": "nixpkgs-2111",
|
||||
"nixpkgs-unstable": "nixpkgs-unstable",
|
||||
"old-ghc-nix": "old-ghc-nix",
|
||||
"stackage": "stackage"
|
||||
},
|
||||
"locked": {
|
||||
"lastModified": 1642814073,
|
||||
"narHash": "sha256-dTG11aKY5N3vnq3jX9AqfvE4+ub/TaoAH8VyDwDprlw=",
|
||||
"owner": "input-output-hk",
|
||||
"repo": "haskell.nix",
|
||||
"rev": "c11e9ee499a674ef236a6972a0081d920361faae",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "input-output-hk",
|
||||
"repo": "haskell.nix",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"hpc-coveralls": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1607498076,
|
||||
"narHash": "sha256-8uqsEtivphgZWYeUo5RDUhp6bO9j2vaaProQxHBltQk=",
|
||||
"owner": "sevanspowell",
|
||||
"repo": "hpc-coveralls",
|
||||
"rev": "14df0f7d229f4cd2e79f8eabb1a740097fdfa430",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "sevanspowell",
|
||||
"repo": "hpc-coveralls",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"nix-tools": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1636018067,
|
||||
"narHash": "sha256-ng306fkuwr6V/malWtt3979iAC4yMVDDH2ViwYB6sQE=",
|
||||
"owner": "input-output-hk",
|
||||
"repo": "nix-tools",
|
||||
"rev": "ed5bd7215292deba55d6ab7a4e8c21f8b1564dda",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "input-output-hk",
|
||||
"repo": "nix-tools",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"nixpkgs-2003": {
|
||||
"locked": {
|
||||
"lastModified": 1620055814,
|
||||
"narHash": "sha256-8LEHoYSJiL901bTMVatq+rf8y7QtWuZhwwpKE2fyaRY=",
|
||||
"owner": "NixOS",
|
||||
"repo": "nixpkgs",
|
||||
"rev": "1db42b7fe3878f3f5f7a4f2dc210772fd080e205",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "NixOS",
|
||||
"ref": "nixpkgs-20.03-darwin",
|
||||
"repo": "nixpkgs",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"nixpkgs-2105": {
|
||||
"locked": {
|
||||
"lastModified": 1640283157,
|
||||
"narHash": "sha256-6Ddfop+rKE+Gl9Tjp9YIrkfoYPzb8F80ergdjcq3/MY=",
|
||||
"owner": "NixOS",
|
||||
"repo": "nixpkgs",
|
||||
"rev": "dde1557825c5644c869c5efc7448dc03722a8f09",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "NixOS",
|
||||
"ref": "nixpkgs-21.05-darwin",
|
||||
"repo": "nixpkgs",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"nixpkgs-2111": {
|
||||
"locked": {
|
||||
"lastModified": 1640283207,
|
||||
"narHash": "sha256-SCwl7ZnCfMDsuSYvwIroiAlk7n33bW8HFfY8NvKhcPA=",
|
||||
"owner": "NixOS",
|
||||
"repo": "nixpkgs",
|
||||
"rev": "64c7e3388bbd9206e437713351e814366e0c3284",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "NixOS",
|
||||
"ref": "nixpkgs-21.11-darwin",
|
||||
"repo": "nixpkgs",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"nixpkgs-unstable": {
|
||||
"locked": {
|
||||
"lastModified": 1641285291,
|
||||
"narHash": "sha256-KYaOBNGar3XWTxTsYPr9P6u74KAqNq0wobEC236U+0c=",
|
||||
"owner": "NixOS",
|
||||
"repo": "nixpkgs",
|
||||
"rev": "0432195a4b8d68faaa7d3d4b355260a3120aeeae",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "NixOS",
|
||||
"ref": "nixpkgs-unstable",
|
||||
"repo": "nixpkgs",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"old-ghc-nix": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1631092763,
|
||||
"narHash": "sha256-sIKgO+z7tj4lw3u6oBZxqIhDrzSkvpHtv0Kki+lh9Fg=",
|
||||
"owner": "angerman",
|
||||
"repo": "old-ghc-nix",
|
||||
"rev": "af48a7a7353e418119b6dfe3cd1463a657f342b8",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "angerman",
|
||||
"ref": "master",
|
||||
"repo": "old-ghc-nix",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"root": {
|
||||
"inputs": {
|
||||
"flake-utils": "flake-utils",
|
||||
"haskellNix": "haskellNix",
|
||||
"nixpkgs": [
|
||||
"haskellNix",
|
||||
"nixpkgs-unstable"
|
||||
]
|
||||
}
|
||||
},
|
||||
"stackage": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1642727755,
|
||||
"narHash": "sha256-30kMVckFauVEyzn+k32/0ugvSwK9w8H/Z/+KkJpRuAM=",
|
||||
"owner": "input-output-hk",
|
||||
"repo": "stackage.nix",
|
||||
"rev": "c430e00491da7502bf8812719ee7ab61dd035fab",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "input-output-hk",
|
||||
"repo": "stackage.nix",
|
||||
"type": "github"
|
||||
}
|
||||
}
|
||||
},
|
||||
"root": "root",
|
||||
"version": 7
|
||||
}
|
||||
41
flake.nix
Normal file
41
flake.nix
Normal file
|
|
@ -0,0 +1,41 @@
|
|||
{
|
||||
description = "A very basic flake";
|
||||
inputs.haskellNix.url = "github:input-output-hk/haskell.nix";
|
||||
inputs.nixpkgs.follows = "haskellNix/nixpkgs-unstable";
|
||||
inputs.flake-utils.url = "github:numtide/flake-utils";
|
||||
outputs = { self, nixpkgs, flake-utils, haskellNix }:
|
||||
flake-utils.lib.eachSystem [ "x86_64-linux" "x86_64-darwin" ] (system:
|
||||
let
|
||||
overlays = [ haskellNix.overlay
|
||||
(final: prev: {
|
||||
# This overlay adds our project to pkgs
|
||||
helloProject =
|
||||
final.haskell-nix.project' {
|
||||
src = ./.;
|
||||
compiler-nix-name = "ghc8107";
|
||||
# This is used by `nix develop .` to open a shell for use with
|
||||
# `cabal`, `hlint` and `haskell-language-server`
|
||||
shell.tools = {
|
||||
cabal = {};
|
||||
hlint = {};
|
||||
haskell-language-server = {};
|
||||
};
|
||||
# Non-Haskell shell tools go here
|
||||
shell.buildInputs = with pkgs; [
|
||||
nixpkgs-fmt
|
||||
];
|
||||
# This adds `js-unknown-ghcjs-cabal` to the shell.
|
||||
shell.crossPlatform = p: [p.ghcjs];
|
||||
};
|
||||
})
|
||||
];
|
||||
pkgs = (import nixpkgs { inherit system overlays; inherit (haskellNix) config; }).pkgsCross.ghcjs;
|
||||
flake = pkgs.helloProject.flake {
|
||||
# This adds support for `nix build .#js-unknown-ghcjs-cabal:hello:exe:hello`
|
||||
crossPlatforms = p: [p.ghcjs];
|
||||
};
|
||||
in flake // {
|
||||
# Built by `nix build .`
|
||||
defaultPackage = flake.packages."rcv-site:exe:client";
|
||||
});
|
||||
}
|
||||
120
rcv-site.cabal
120
rcv-site.cabal
|
|
@ -1,62 +1,65 @@
|
|||
cabal-version: 3.0
|
||||
name: rcv-site
|
||||
version: 0.1.0.0
|
||||
category: Web
|
||||
build-type: Simple
|
||||
cabal-version: >=1.10
|
||||
|
||||
executable server
|
||||
main-is:
|
||||
Main.hs
|
||||
if impl(ghcjs)
|
||||
buildable: False
|
||||
else
|
||||
default-language:
|
||||
Haskell2010
|
||||
default-extensions:
|
||||
ScopedTypeVariables,
|
||||
OverloadedStrings,
|
||||
OverloadedLists,
|
||||
TemplateHaskell,
|
||||
DataKinds,
|
||||
FlexibleContexts,
|
||||
FlexibleInstances,
|
||||
MultiParamTypeClasses,
|
||||
OverloadedLabels
|
||||
TypeFamilies,
|
||||
UndecidableInstances,
|
||||
RecursiveDo,
|
||||
RecordWildCards,
|
||||
RankNTypes,
|
||||
DuplicateRecordFields,
|
||||
TupleSections,
|
||||
TypeOperators,
|
||||
DeriveGeneric
|
||||
hs-source-dirs:
|
||||
server,
|
||||
shared
|
||||
build-depends:
|
||||
acid-state,
|
||||
aeson,
|
||||
base < 5,
|
||||
containers,
|
||||
http-types,
|
||||
lucid,
|
||||
miso,
|
||||
mtl,
|
||||
network-uri,
|
||||
servant,
|
||||
servant-lucid,
|
||||
servant-server,
|
||||
text,
|
||||
wai,
|
||||
wai-app-static,
|
||||
wai-extra,
|
||||
warp
|
||||
default-language:
|
||||
Haskell2010
|
||||
other-modules:
|
||||
API
|
||||
InstantRunoff
|
||||
default-extensions:
|
||||
DataKinds,
|
||||
DeriveAnyClass,
|
||||
DeriveGeneric,
|
||||
DuplicateRecordFields,
|
||||
FlexibleContexts,
|
||||
FlexibleInstances,
|
||||
MultiParamTypeClasses,
|
||||
OverloadedLabels,
|
||||
OverloadedLists,
|
||||
OverloadedStrings,
|
||||
RankNTypes,
|
||||
RecordWildCards,
|
||||
RecursiveDo,
|
||||
ScopedTypeVariables,
|
||||
TemplateHaskell,
|
||||
TupleSections,
|
||||
TypeFamilies,
|
||||
TypeOperators,
|
||||
UndecidableInstances,
|
||||
StandaloneDeriving
|
||||
hs-source-dirs:
|
||||
server,
|
||||
shared
|
||||
build-depends:
|
||||
aeson,
|
||||
base,
|
||||
beam-core,
|
||||
beam-sqlite,
|
||||
beam-migrate,
|
||||
containers,
|
||||
http-types,
|
||||
lucid,
|
||||
miso,
|
||||
mtl,
|
||||
network-uri,
|
||||
servant,
|
||||
servant-lucid,
|
||||
servant-server,
|
||||
sqlite-simple,
|
||||
text,
|
||||
wai,
|
||||
wai-app-static,
|
||||
wai-extra,
|
||||
warp
|
||||
default-language:
|
||||
Haskell2010
|
||||
other-modules:
|
||||
API
|
||||
Database
|
||||
InstantRunoff
|
||||
|
||||
|
||||
|
||||
-- this has to be built with ghcjs to be useful,
|
||||
-- but ghc should still be able build it
|
||||
|
|
@ -64,14 +67,14 @@ executable client
|
|||
main-is:
|
||||
Main.hs
|
||||
default-extensions:
|
||||
ScopedTypeVariables,
|
||||
OverloadedStrings,
|
||||
OverloadedLists,
|
||||
DataKinds,
|
||||
TypeOperators,
|
||||
RecordWildCards,
|
||||
DeriveGeneric,
|
||||
DuplicateRecordFields,
|
||||
DeriveGeneric
|
||||
OverloadedLists,
|
||||
OverloadedStrings,
|
||||
RecordWildCards,
|
||||
ScopedTypeVariables,
|
||||
TypeOperators
|
||||
ghcjs-options:
|
||||
-dedupe -DGHCJS_GC_INTERVAL=5000
|
||||
hs-source-dirs:
|
||||
|
|
@ -83,7 +86,8 @@ executable client
|
|||
containers,
|
||||
miso,
|
||||
servant,
|
||||
-- servant-client-ghcjs,
|
||||
-- beam-core,
|
||||
text
|
||||
-- servant-client-ghcjs
|
||||
default-language:
|
||||
Haskell2010
|
||||
|
|
|
|||
83
server/Database.hs
Normal file
83
server/Database.hs
Normal file
|
|
@ -0,0 +1,83 @@
|
|||
module Database where
|
||||
|
||||
import qualified Database.Beam as B
|
||||
|
||||
import qualified Database.SQLite.Simple as SQLS
|
||||
import qualified Database.Beam.Sqlite as BS
|
||||
import qualified Database.Beam.Sqlite.Migrate as BSM
|
||||
import GHC.Generics (Generic)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.List.NonEmpty as LN
|
||||
import Data.Aeson
|
||||
import qualified Database.Beam.Migrate as BM
|
||||
import qualified Database.Beam.Migrate.Simple as BMS
|
||||
import Data.Word
|
||||
import Database.Beam.Sqlite (runBeamSqlite)
|
||||
import qualified Database.Beam.Sqlite.Migrate as BSM
|
||||
-- import qualified Database.Beam.Postgres as BP
|
||||
|
||||
data PollT f = PollT {
|
||||
identity :: B.C f Word32,
|
||||
question :: B.C f T.Text
|
||||
} deriving (Generic, B.Beamable)
|
||||
|
||||
data OptionT f = OptionT {
|
||||
identity:: B.C f Word32,
|
||||
name :: B.C f T.Text,
|
||||
forPoll :: B.PrimaryKey PollT f
|
||||
} deriving (Generic, B.Beamable)
|
||||
|
||||
newtype BallotT f = BallotT {
|
||||
identity:: B.C f Word32
|
||||
} deriving (Generic, B.Beamable)
|
||||
|
||||
data VoteT f = VoteT {
|
||||
order :: B.C f Word32,
|
||||
option :: B.PrimaryKey PollT f,
|
||||
ballot :: B.PrimaryKey BallotT f
|
||||
} deriving (Generic, B.Beamable)
|
||||
|
||||
instance B.Table PollT where
|
||||
data PrimaryKey PollT f = PollId (B.Columnar f Word32) deriving (Generic, B.Beamable)
|
||||
primaryKey = PollId . (identity :: PollT f -> B.C f Word32)
|
||||
|
||||
instance B.Table OptionT where
|
||||
data PrimaryKey OptionT f = OptionId (B.Columnar f Word32) deriving (Generic, B.Beamable)
|
||||
primaryKey = OptionId . (identity :: OptionT f -> B.Columnar f Word32)
|
||||
|
||||
instance B.Table BallotT where
|
||||
data PrimaryKey BallotT f = BallotId (B.Columnar f Word32) deriving (Generic, B.Beamable)
|
||||
primaryKey = BallotId . (identity :: BallotT f -> B.Columnar f Word32)
|
||||
|
||||
instance B.Table VoteT where
|
||||
data PrimaryKey VoteT f = VoteId (B.C f Word32) (B.PrimaryKey PollT f) (B.PrimaryKey BallotT f) deriving (Generic, B.Beamable)
|
||||
primaryKey = VoteId <$> order <*> option <*> ballot
|
||||
|
||||
type PollId = B.PrimaryKey PollT B.Identity
|
||||
|
||||
-- the actual database
|
||||
data PollDatabase f = PollDatabase {
|
||||
polls :: f (B.TableEntity PollT),
|
||||
options :: f (B.TableEntity PollT),
|
||||
ballots :: f (B.TableEntity BallotT),
|
||||
votes :: f (B.TableEntity VoteT)
|
||||
} deriving (Generic, B.Database e)
|
||||
|
||||
|
||||
-- settings :: B.DatabaseSettings be PollDatabase
|
||||
-- settings = B.defaultDbSettings
|
||||
|
||||
migrateSettings :: BM.CheckedDatabaseSettings BS.Sqlite PollDatabase
|
||||
migrateSettings = BM.defaultMigratableDbSettings
|
||||
|
||||
connection :: IO SQLS.Connection
|
||||
connection = SQLS.open "rcv-site.db"
|
||||
|
||||
-- beamConnection = BS.runBeamSqliteDebug
|
||||
-- makeDB :: BS.Sqlite
|
||||
makeDB = do
|
||||
BMS.createSchema BSM.migrationBackend migrateSettings
|
||||
-- connection' <- connection
|
||||
-- BS.runBeamSqlite putStrLn connection
|
||||
|
||||
-- createdschema :: BMS.createSchema
|
||||
|
|
@ -16,69 +16,51 @@ import qualified Servant.Server.StaticFiles as SSF
|
|||
import qualified Data.Maybe as M
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.Text.IO as T
|
||||
import qualified Database as DB
|
||||
import Database.Beam.Sqlite (runBeamSqlite)
|
||||
|
||||
staticDir = "./static"
|
||||
|
||||
-- this is good enough for now
|
||||
data DB = DB {
|
||||
poll :: A.Poll,
|
||||
votes :: [A.Ballot]
|
||||
}
|
||||
|
||||
db :: IO (MV.MVar DB)
|
||||
db = MV.newMVar $ DB {
|
||||
poll = A.Poll
|
||||
{
|
||||
question = "What's your favorite color?",
|
||||
options = LN.fromList
|
||||
[
|
||||
"blue",
|
||||
"red",
|
||||
"green",
|
||||
"yellow"
|
||||
]
|
||||
},
|
||||
votes = mockVotes
|
||||
}
|
||||
|
||||
mockVotes :: [A.Ballot]
|
||||
mockVotes = [["blue", "red", "green", "yellow"], ["red", "blue", "green", "yellow"], ["red"]]
|
||||
-- getPoll :: Int -> Handler A.Poll
|
||||
-- getPoll id = do
|
||||
-- mvdb <- liftIO DB.db
|
||||
-- db' <- liftIO $ MV.readMVar mvdb
|
||||
-- return $ poll db'
|
||||
|
||||
getPoll :: Int -> Handler A.Poll
|
||||
getPoll id = do
|
||||
mvdb <- liftIO db
|
||||
db' <- liftIO $ MV.readMVar mvdb
|
||||
return $ poll db'
|
||||
-- getResult :: Int -> Handler [T.Text]
|
||||
-- getResult id = do
|
||||
-- mvdb <- liftIO DB.db
|
||||
-- db' <- liftIO $ MV.readMVar mvdb
|
||||
-- let result = fmap (S.toList . IR.solve) . LN.nonEmpty . votes $ db'
|
||||
-- return $ M.fromMaybe ["heck"] result
|
||||
|
||||
getResult :: Int -> Handler [T.Text]
|
||||
getResult id = do
|
||||
mvdb <- liftIO db
|
||||
db' <- liftIO $ MV.readMVar mvdb
|
||||
let result = fmap (S.toList . IR.solve) . LN.nonEmpty . votes $ db'
|
||||
return $ M.fromMaybe ["heck"] result
|
||||
-- makePoll :: A.Poll -> Handler Int
|
||||
-- makePoll poll = return (-1)
|
||||
|
||||
makePoll :: A.Poll -> Handler Int
|
||||
makePoll poll = return (-1)
|
||||
-- vote :: Int -> A.Ballot -> Handler ()
|
||||
-- vote pollId ballot = do
|
||||
-- mvdb <- liftIO D.db
|
||||
-- db' <- liftIO $ MV.takeMVar mvdb
|
||||
-- let newDB = db' {votes = ballot : votes db'}
|
||||
-- liftIO $ MV.putMVar mvdb newDB
|
||||
-- return ()
|
||||
|
||||
vote :: Int -> A.Ballot -> Handler ()
|
||||
vote pollId ballot = do
|
||||
mvdb <- liftIO db
|
||||
db' <- liftIO $ MV.takeMVar mvdb
|
||||
let newDB = db' {votes = ballot : votes db'}
|
||||
liftIO $ MV.putMVar mvdb newDB
|
||||
return ()
|
||||
-- server :: Server A.RCVAPI
|
||||
-- server = vote :<|> makePoll :<|> getPoll :<|> getResult
|
||||
|
||||
server :: Server A.RCVAPI
|
||||
server = vote :<|> makePoll :<|> getPoll :<|> getResult :<|> SSF.serveDirectoryWebApp staticDir
|
||||
-- rcpAPI :: Proxy A.RCVAPI
|
||||
-- rcpAPI = Proxy
|
||||
|
||||
rcpAPI :: Proxy A.RCVAPI
|
||||
rcpAPI = Proxy
|
||||
-- -- 'serve' comes from servant and hands you a WAI Application,
|
||||
-- -- which you can think of as an "abstract" web application,
|
||||
-- -- not yet a webserver.
|
||||
-- app :: Application
|
||||
-- app = serve rcpAPI server
|
||||
|
||||
-- 'serve' comes from servant and hands you a WAI Application,
|
||||
-- which you can think of as an "abstract" web application,
|
||||
-- not yet a webserver.
|
||||
app :: Application
|
||||
app = serve rcpAPI server
|
||||
|
||||
main :: IO ()
|
||||
main = W.run 8080 app
|
||||
-- main :: IO ()
|
||||
main = do
|
||||
connection <- DB.connection
|
||||
runBeamSqlite connection DB.makeDB
|
||||
-- main = W.run 8080 app
|
||||
|
|
|
|||
|
|
@ -7,31 +7,16 @@ import Servant.API
|
|||
import Data.Text (Text)
|
||||
import Data.Aeson
|
||||
import qualified Data.List.NonEmpty as LN
|
||||
-- import qualified Database.Beam as B
|
||||
|
||||
type Ballot = LN.NonEmpty Text
|
||||
|
||||
-- this is difficult, MisoString is more performant on front-end (and is a Text alias under GHC)
|
||||
-- but Text is so well supported that it's a large loss on back-end
|
||||
-- or we paramaterize all of our types on their text format
|
||||
data Poll = Poll {
|
||||
question :: Text,
|
||||
options :: Ballot
|
||||
} deriving (Generic, Show, Ord, Eq)
|
||||
|
||||
-- data PollResult = PollResult {
|
||||
-- result :: [Text]
|
||||
-- } deriving (Generic, Ord, Eq)
|
||||
|
||||
|
||||
-- instance FromJSON PollResult
|
||||
-- instance ToJSON PollResult
|
||||
|
||||
instance FromJSON Poll
|
||||
instance ToJSON Poll
|
||||
|
||||
type RCVAPI =
|
||||
"poll" :> Capture "pollId" Int :> "vote" :> ReqBody '[JSON] Ballot :> Post '[JSON] ()
|
||||
:<|> "poll" :> "create" :> ReqBody '[JSON] Poll :> Post '[JSON] Int
|
||||
:<|> "poll" :> Capture "pollId" Int :> "options" :> Get '[JSON] Poll -- not sure about the name for this endpoint
|
||||
:<|> "poll" :> Capture "pollId" Int :> "result" :> Get '[JSON] [Text]
|
||||
:<|> Raw
|
||||
-- type RCVAPI =
|
||||
-- "poll" :> Capture "pollId" Int :> "vote" :> ReqBody '[JSON] Ballot :> Post '[JSON] ()
|
||||
-- :<|> "poll" :> "create" :> ReqBody '[JSON] Poll :> Post '[JSON] Int
|
||||
-- :<|> "poll" :> Capture "pollId" Int :> "options" :> Get '[JSON] Poll -- not sure about the name for this endpoint
|
||||
-- :<|> "poll" :> Capture "pollId" Int :> "result" :> Get '[JSON] [Text]
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue