backend works!
This commit is contained in:
parent
8488b15fef
commit
e59e949770
11 changed files with 144 additions and 1027 deletions
328
client/flake.lock
generated
328
client/flake.lock
generated
|
|
@ -1,328 +0,0 @@
|
|||
{
|
||||
"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-X0TFfdD4KZpwl0Zr6x+PLxUt/VyKQfX7ylXHdmZIL+w=",
|
||||
"owner": "haskell",
|
||||
"repo": "cabal",
|
||||
"rev": "48bf10787e27364730dd37a42b603cee8d6af7ee",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "haskell",
|
||||
"ref": "3.2",
|
||||
"repo": "cabal",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"cabal-34": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1640353650,
|
||||
"narHash": "sha256-N1t6M3/wqj90AEdRkeC8i923gQYUpzSr8b40qVOZ1Rk=",
|
||||
"owner": "haskell",
|
||||
"repo": "cabal",
|
||||
"rev": "942639c18c0cd8ec53e0a6f8d120091af35312cd",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "haskell",
|
||||
"ref": "3.4",
|
||||
"repo": "cabal",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"cabal-36": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1641652457,
|
||||
"narHash": "sha256-BlFPKP4C4HRUJeAbdembX1Rms1LD380q9s0qVDeoAak=",
|
||||
"owner": "haskell",
|
||||
"repo": "cabal",
|
||||
"rev": "f27667f8ec360c475027dcaee0138c937477b070",
|
||||
"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": 1644229661,
|
||||
"narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=",
|
||||
"owner": "numtide",
|
||||
"repo": "flake-utils",
|
||||
"rev": "3cecb5b042f7f209c56ffd8371b2711a290ec797",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "numtide",
|
||||
"repo": "flake-utils",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"flake-utils_2": {
|
||||
"locked": {
|
||||
"lastModified": 1644229661,
|
||||
"narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=",
|
||||
"owner": "numtide",
|
||||
"repo": "flake-utils",
|
||||
"rev": "3cecb5b042f7f209c56ffd8371b2711a290ec797",
|
||||
"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": 1646097829,
|
||||
"narHash": "sha256-PcHDDV8NuUxZhPV/p++IkZC+SDZ1Db7m7K+9HN4/0S4=",
|
||||
"owner": "input-output-hk",
|
||||
"repo": "hackage.nix",
|
||||
"rev": "283f096976b48e54183905e7bdde7f213c6ee5cd",
|
||||
"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-unstable"
|
||||
],
|
||||
"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": 1646097976,
|
||||
"narHash": "sha256-EiyrBqayw67dw8pr1XCVU9tIZ+/jzXCQycW1S9a+KFA=",
|
||||
"owner": "input-output-hk",
|
||||
"repo": "haskell.nix",
|
||||
"rev": "f0308ed1df3ce9f10f9da1a7c0c8591921d0b4e5",
|
||||
"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": 1644395812,
|
||||
"narHash": "sha256-BVFk/BEsTLq5MMZvdy3ZYHKfaS3dHrsKh4+tb5t5b58=",
|
||||
"owner": "input-output-hk",
|
||||
"repo": "nix-tools",
|
||||
"rev": "d847c63b99bbec78bf83be2a61dc9f09b8a9ccc1",
|
||||
"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": 1642244250,
|
||||
"narHash": "sha256-vWpUEqQdVP4srj+/YLJRTN9vjpTs4je0cdWKXPbDItc=",
|
||||
"owner": "NixOS",
|
||||
"repo": "nixpkgs",
|
||||
"rev": "0fd9ee1aa36ce865ad273f4f07fdc093adeb5c00",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "NixOS",
|
||||
"ref": "nixpkgs-21.05-darwin",
|
||||
"repo": "nixpkgs",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"nixpkgs-2111": {
|
||||
"locked": {
|
||||
"lastModified": 1644510859,
|
||||
"narHash": "sha256-xjpVvL5ecbyi0vxtVl/Fh9bwGlMbw3S06zE5nUzFB8A=",
|
||||
"owner": "NixOS",
|
||||
"repo": "nixpkgs",
|
||||
"rev": "0d1d5d7e3679fec9d07f2eb804d9f9fdb98378d3",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "NixOS",
|
||||
"ref": "nixpkgs-21.11-darwin",
|
||||
"repo": "nixpkgs",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"nixpkgs-unstable": {
|
||||
"locked": {
|
||||
"lastModified": 1644486793,
|
||||
"narHash": "sha256-EeijR4guVHgVv+JpOX3cQO+1XdrkJfGmiJ9XVsVU530=",
|
||||
"owner": "NixOS",
|
||||
"repo": "nixpkgs",
|
||||
"rev": "1882c6b7368fd284ad01b0a5b5601ef136321292",
|
||||
"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": 1646010978,
|
||||
"narHash": "sha256-NpioQiTXyYm+Gm111kcDEE/ghflmnTNwPhWff54GYA4=",
|
||||
"owner": "input-output-hk",
|
||||
"repo": "stackage.nix",
|
||||
"rev": "9cce3e0d420f6c38cdbbe1c5e5bbc07fd2adfc3a",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "input-output-hk",
|
||||
"repo": "stackage.nix",
|
||||
"type": "github"
|
||||
}
|
||||
}
|
||||
},
|
||||
"root": "root",
|
||||
"version": 7
|
||||
}
|
||||
|
|
@ -1,36 +0,0 @@
|
|||
cabal-version: 3.0
|
||||
name: rcv-site-client
|
||||
version: 0.1.0.0
|
||||
category: Web
|
||||
build-type: Simple
|
||||
|
||||
-- this has to be built with ghcjs to be useful,
|
||||
-- but ghc should still be able build it
|
||||
executable client
|
||||
main-is:
|
||||
Main.hs
|
||||
default-extensions:
|
||||
DataKinds,
|
||||
DeriveGeneric,
|
||||
DuplicateRecordFields,
|
||||
OverloadedLists,
|
||||
OverloadedStrings,
|
||||
RecordWildCards,
|
||||
ScopedTypeVariables,
|
||||
TypeOperators
|
||||
ghcjs-options:
|
||||
-dedupe -DGHCJS_GC_INTERVAL=5000
|
||||
hs-source-dirs:
|
||||
src,
|
||||
shared-src
|
||||
build-depends:
|
||||
aeson,
|
||||
base < 5,
|
||||
containers,
|
||||
miso,
|
||||
servant,
|
||||
beam-core,
|
||||
text,
|
||||
servant-client-ghcjs
|
||||
default-language:
|
||||
Haskell2010
|
||||
|
|
@ -1 +0,0 @@
|
|||
../shared-src
|
||||
|
|
@ -1,76 +0,0 @@
|
|||
module Main where
|
||||
|
||||
import Data.Proxy
|
||||
import Miso
|
||||
import Miso.Router
|
||||
import Miso.String
|
||||
import GHC.TypeLits
|
||||
import Miso.Html
|
||||
import qualified API as A
|
||||
|
||||
|
||||
-- | Type synonym for an application model
|
||||
type Model = Int
|
||||
|
||||
-- | Sum type for application events
|
||||
data Action
|
||||
= AddOne
|
||||
| SubtractOne
|
||||
| NoOp
|
||||
| SayHelloWorld
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- | Entry point for a miso application
|
||||
main :: IO ()
|
||||
main = startApp App {..}
|
||||
where
|
||||
initialAction = SayHelloWorld -- initial action to be executed on application load
|
||||
model = 0 -- initial model
|
||||
update = updateModel -- update function
|
||||
view = viewModel -- view function
|
||||
events = defaultEvents -- default delegated events
|
||||
subs = [] -- empty subscription list
|
||||
mountPoint = Nothing -- mount point for application (Nothing defaults to 'body')
|
||||
logLevel = Off -- used during prerendering to see if the VDOM and DOM are in sync (only used with `miso` function)
|
||||
|
||||
-- | Updates model, optionally introduces side effects
|
||||
updateModel :: Action -> Model -> Effect Action Model
|
||||
updateModel AddOne m = noEff (m + 1)
|
||||
updateModel SubtractOne m = noEff (m - 1)
|
||||
updateModel NoOp m = noEff m
|
||||
updateModel SayHelloWorld m = m <# do
|
||||
putStrLn "Hello World" >> pure NoOp
|
||||
|
||||
-- | Constructs a virtual DOM from a model
|
||||
viewModel :: Model -> View Action
|
||||
viewModel m = div_ [] [text "it worked"]
|
||||
|
||||
|
||||
-- currPoll = runRoute (Proxy :: Proxy A.RCVAPI) handlers uri m of
|
||||
|
||||
|
||||
-- vote :: Int -> A.Ballot -> ClientM ()
|
||||
-- createPoll :: A.Poll -> ClientM Int
|
||||
-- getPoll :: Int -> ClientM A.Poll
|
||||
|
||||
-- View, dispatches to fields in 'Route'
|
||||
-- viewModel :: Model -> View Action
|
||||
-- viewModel m =
|
||||
-- case runRoute clientApi clientRoutes getUri m of
|
||||
-- Left _ -> div_ [] [ "404" ]
|
||||
-- Right v -> v
|
||||
|
||||
-- api :: Proxy A.API
|
||||
-- api = genericApi (Proxy A.RCVAPI)
|
||||
|
||||
-- clientRoutes :: ToServant A.API AsView
|
||||
-- clientRoutes = toServant routeViews
|
||||
|
||||
|
||||
-- vote :: Int -> A.Ballot -> ClientM ()
|
||||
|
||||
-- create :: Poll -> ClientM Int
|
||||
|
||||
-- poll :: Int -> ClientM Poll
|
||||
|
||||
-- vote :<|> create :<|> poll = client api
|
||||
328
flake.lock
generated
328
flake.lock
generated
|
|
@ -1,328 +0,0 @@
|
|||
{
|
||||
"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-X0TFfdD4KZpwl0Zr6x+PLxUt/VyKQfX7ylXHdmZIL+w=",
|
||||
"owner": "haskell",
|
||||
"repo": "cabal",
|
||||
"rev": "48bf10787e27364730dd37a42b603cee8d6af7ee",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "haskell",
|
||||
"ref": "3.2",
|
||||
"repo": "cabal",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"cabal-34": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1640353650,
|
||||
"narHash": "sha256-N1t6M3/wqj90AEdRkeC8i923gQYUpzSr8b40qVOZ1Rk=",
|
||||
"owner": "haskell",
|
||||
"repo": "cabal",
|
||||
"rev": "942639c18c0cd8ec53e0a6f8d120091af35312cd",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "haskell",
|
||||
"ref": "3.4",
|
||||
"repo": "cabal",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"cabal-36": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1641652457,
|
||||
"narHash": "sha256-BlFPKP4C4HRUJeAbdembX1Rms1LD380q9s0qVDeoAak=",
|
||||
"owner": "haskell",
|
||||
"repo": "cabal",
|
||||
"rev": "f27667f8ec360c475027dcaee0138c937477b070",
|
||||
"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": 1644229661,
|
||||
"narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=",
|
||||
"owner": "numtide",
|
||||
"repo": "flake-utils",
|
||||
"rev": "3cecb5b042f7f209c56ffd8371b2711a290ec797",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "numtide",
|
||||
"repo": "flake-utils",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"flake-utils_2": {
|
||||
"locked": {
|
||||
"lastModified": 1644229661,
|
||||
"narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=",
|
||||
"owner": "numtide",
|
||||
"repo": "flake-utils",
|
||||
"rev": "3cecb5b042f7f209c56ffd8371b2711a290ec797",
|
||||
"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": 1646961339,
|
||||
"narHash": "sha256-hsXNxSugSyOALfOt0I+mXrKioJ/nWX49/RhF/88N6D0=",
|
||||
"owner": "input-output-hk",
|
||||
"repo": "hackage.nix",
|
||||
"rev": "5dea95d408c29b56a14faae378ae4e39d63126f4",
|
||||
"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-unstable"
|
||||
],
|
||||
"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": 1646961517,
|
||||
"narHash": "sha256-D9xRMBhsjHi5Ox2SsnzlwgcMXZlAXWP5c/AqFY0kxl4=",
|
||||
"owner": "input-output-hk",
|
||||
"repo": "haskell.nix",
|
||||
"rev": "4cda3aeea8acd0837f6ad4a18a793d3d5901862a",
|
||||
"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": 1644395812,
|
||||
"narHash": "sha256-BVFk/BEsTLq5MMZvdy3ZYHKfaS3dHrsKh4+tb5t5b58=",
|
||||
"owner": "input-output-hk",
|
||||
"repo": "nix-tools",
|
||||
"rev": "d847c63b99bbec78bf83be2a61dc9f09b8a9ccc1",
|
||||
"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": 1642244250,
|
||||
"narHash": "sha256-vWpUEqQdVP4srj+/YLJRTN9vjpTs4je0cdWKXPbDItc=",
|
||||
"owner": "NixOS",
|
||||
"repo": "nixpkgs",
|
||||
"rev": "0fd9ee1aa36ce865ad273f4f07fdc093adeb5c00",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "NixOS",
|
||||
"ref": "nixpkgs-21.05-darwin",
|
||||
"repo": "nixpkgs",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"nixpkgs-2111": {
|
||||
"locked": {
|
||||
"lastModified": 1644510859,
|
||||
"narHash": "sha256-xjpVvL5ecbyi0vxtVl/Fh9bwGlMbw3S06zE5nUzFB8A=",
|
||||
"owner": "NixOS",
|
||||
"repo": "nixpkgs",
|
||||
"rev": "0d1d5d7e3679fec9d07f2eb804d9f9fdb98378d3",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "NixOS",
|
||||
"ref": "nixpkgs-21.11-darwin",
|
||||
"repo": "nixpkgs",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"nixpkgs-unstable": {
|
||||
"locked": {
|
||||
"lastModified": 1644486793,
|
||||
"narHash": "sha256-EeijR4guVHgVv+JpOX3cQO+1XdrkJfGmiJ9XVsVU530=",
|
||||
"owner": "NixOS",
|
||||
"repo": "nixpkgs",
|
||||
"rev": "1882c6b7368fd284ad01b0a5b5601ef136321292",
|
||||
"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": 1646961451,
|
||||
"narHash": "sha256-fs3+CsqzgNVT2mJSJOc+MnhbRoIoB/L1ZEhiJn0nXHQ=",
|
||||
"owner": "input-output-hk",
|
||||
"repo": "stackage.nix",
|
||||
"rev": "02b9e7ea7304027b5d473233c2465d04a21a17e3",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "input-output-hk",
|
||||
"repo": "stackage.nix",
|
||||
"type": "github"
|
||||
}
|
||||
}
|
||||
},
|
||||
"root": "root",
|
||||
"version": 7
|
||||
}
|
||||
53
flake.nix
53
flake.nix
|
|
@ -1,53 +0,0 @@
|
|||
{
|
||||
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-template = (src-input: [ haskellNix.overlay
|
||||
(final: prev: {
|
||||
# This overlay adds our project to pkgs
|
||||
rcv-proj =
|
||||
final.haskell-nix.project' {
|
||||
src = src-input;
|
||||
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 = {};
|
||||
};
|
||||
# This adds `js-unknown-ghcjs-cabal` to the shell.
|
||||
# shell.crossPlatform = p: [p.ghcjs];
|
||||
};
|
||||
})
|
||||
]);
|
||||
|
||||
|
||||
ghcjs-overlays = overlays-template ./client;
|
||||
ghc-overlays = overlays-template ./server;
|
||||
|
||||
ghcjs-pkgs = (import nixpkgs { inherit system; overlays = ghcjs-overlays; inherit (haskellNix) config; }).pkgsCross.ghcjs;
|
||||
|
||||
ghc-pkgs = import nixpkgs { inherit system; overlays = ghc-overlays; inherit (haskellNix) config; };
|
||||
|
||||
ghcjs-flake = ghcjs-pkgs.rcv-proj.flake {
|
||||
# This adds support for `nix build .#js-unknown-ghcjs-cabal:hello:exe:hello`
|
||||
crossPlatforms = p: [p.ghcjs];
|
||||
};
|
||||
|
||||
ghc-flake = ghc-pkgs.rcv-proj.flake {};
|
||||
client = ghcjs-flake.packages."rcv-site-client:exe:client";
|
||||
server = ghc-flake.packages."rcv-site-server:exe:server";
|
||||
|
||||
in ghcjs-flake // {
|
||||
packages.server = server;
|
||||
packages.client = client;
|
||||
# Built by `nix build .`
|
||||
defaultPackage = client;
|
||||
});
|
||||
}
|
||||
|
|
@ -16,6 +16,7 @@ executable server
|
|||
FlexibleInstances,
|
||||
ImpredicativeTypes,
|
||||
MultiParamTypeClasses,
|
||||
NamedFieldPuns,
|
||||
OverloadedLabels,
|
||||
OverloadedLists,
|
||||
OverloadedStrings,
|
||||
|
|
@ -37,14 +38,16 @@ executable server
|
|||
shared-src
|
||||
build-depends:
|
||||
aeson,
|
||||
uuid,
|
||||
base,
|
||||
beam-core ^>= 0.9.2.0,
|
||||
beam-migrate,
|
||||
beam-postgres ^>= 0.5.2.0,
|
||||
acid-state,
|
||||
safecopy,
|
||||
containers,
|
||||
http-types,
|
||||
lucid,
|
||||
miso,
|
||||
bytestring,
|
||||
hashable,
|
||||
mtl,
|
||||
network-uri,
|
||||
postgresql-simple,
|
||||
|
|
@ -63,3 +66,7 @@ executable server
|
|||
API
|
||||
Database
|
||||
InstantRunoff
|
||||
Error
|
||||
Poll
|
||||
Ballot
|
||||
AppM
|
||||
|
|
|
|||
|
|
@ -8,26 +8,17 @@ import qualified Data.Text as T
|
|||
import Data.Aeson
|
||||
import Data.Word
|
||||
import qualified Data.List.NonEmpty as LN
|
||||
import qualified Database.Beam as B
|
||||
import qualified Data.UUID as UI
|
||||
import qualified Data.ByteString.Lazy as BS
|
||||
import qualified Data.Set as S
|
||||
import qualified Poll as P
|
||||
import qualified Ballot as B
|
||||
|
||||
|
||||
data CreatePollReq =
|
||||
CreatePollReq {
|
||||
question :: T.Text,
|
||||
optionNames :: [T.Text]
|
||||
} deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON)
|
||||
|
||||
type PollResult = [T.Text]
|
||||
|
||||
type RCVAPI =
|
||||
-- "poll" :> Capture "pollId" Int :> "vote" :> ReqBody '[JSON] Ballot :> Post '[JSON] ()
|
||||
"poll" :> "create" :> ReqBody '[JSON] CreatePollReq :> Post '[JSON] Int
|
||||
:<|> "poll" :> Capture "pollId" Int :> "options" :> Get '[JSON] [T.Text]
|
||||
-- :<|> "poll" :> Capture "pollId" Int :> "result" :> Get '[JSON] [Text]
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
-- deriving instance Show Vote
|
||||
-- deriving instance Eq Vote
|
||||
-- deriving instance Ord Vote
|
||||
"poll" :> "create" :> ReqBody '[JSON] P.CreatePollInfo :> Post '[JSON] T.Text
|
||||
:<|> "poll" :> Capture "pollId" T.Text :> "vote" :> Get '[JSON] P.CreatePollInfo
|
||||
:<|> "poll" :> Capture "pollId" T.Text :> "vote" :> ReqBody '[JSON] B.Ballot :> Post '[JSON] ()
|
||||
:<|> "poll" :> Capture "pollId" T.Text :> "result" :> Get '[JSON] PollResult
|
||||
|
|
|
|||
|
|
@ -1,118 +1,62 @@
|
|||
module Database where
|
||||
|
||||
import Data.Word
|
||||
import Data.Int
|
||||
import GHC.Generics (Generic)
|
||||
import qualified Data.List as L
|
||||
import qualified Data.Vector as V
|
||||
import qualified Data.List.NonEmpty as LN
|
||||
import qualified Data.Acid as Ac
|
||||
import qualified Data.Map.Strict as M
|
||||
import qualified Data.Text as T
|
||||
import qualified Database.Beam as B
|
||||
import qualified Database.Beam.Migrate as BM
|
||||
import qualified Database.Beam.Migrate.Simple as BMS
|
||||
import qualified Data.UUID as ID
|
||||
import qualified Data.UUID.V4 as IDV
|
||||
import qualified Control.Monad.Reader as MR
|
||||
import qualified Control.Monad.State as MS
|
||||
import qualified Data.SafeCopy as SC
|
||||
import qualified Data.Typeable as Ty
|
||||
import qualified Data.Hashable as H
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified API as A
|
||||
import qualified Database.Beam.Postgres as BP
|
||||
import qualified Database.Beam.Postgres.Migrate as BPM
|
||||
import qualified Database.PostgreSQL.Simple as PS
|
||||
import qualified Data.String as S
|
||||
import Database.Beam.Backend.SQL (SqlSerial, IsSql92DataTypeSyntax (domainType))
|
||||
import Database.Beam.Postgres as B ( connect )
|
||||
import qualified Database.Beam as BM
|
||||
import Database.Beam.Backend.SQL.BeamExtensions as BQSLE
|
||||
import qualified Database.Beam.Backend.SQL.BeamExtensions as BSQLE
|
||||
import qualified Database.Beam.Postgres.Conduit as BC
|
||||
import qualified Database.Beam.Backend.SQL.BeamExtensions as B
|
||||
import qualified Data.List.NonEmpty as LN
|
||||
import qualified Poll as P
|
||||
import qualified Ballot as B
|
||||
|
||||
type SerialInt = SqlSerial Int32
|
||||
|
||||
data PollT f = PollT {
|
||||
identity :: B.C f SerialInt,
|
||||
question :: B.C f T.Text
|
||||
} deriving (Generic, B.Beamable)
|
||||
|
||||
type Poll = PollT B.Identity
|
||||
newtype DB = DB {
|
||||
polls :: M.Map ID.UUID P.Poll
|
||||
} deriving (Show, Ty.Typeable)
|
||||
|
||||
|
||||
-- deriving instance Show Poll
|
||||
-- deriving instance Eq Poll
|
||||
-- deriving instance Ord Poll
|
||||
deriving instance Ty.Typeable ID.UUID
|
||||
deriving instance Ty.Typeable P.Poll
|
||||
deriving instance Ty.Typeable B.Ballot
|
||||
|
||||
data OptionT f = OptionT {
|
||||
identity:: B.C f SerialInt,
|
||||
forPoll :: B.PrimaryKey PollT f,
|
||||
name :: B.C f T.Text
|
||||
} deriving (Generic, B.Beamable)
|
||||
|
||||
type Option = OptionT B.Identity
|
||||
|
||||
|
||||
data BallotT f = BallotT {
|
||||
identity:: B.C f SerialInt,
|
||||
forPoll :: B.PrimaryKey PollT f,
|
||||
votes :: B.C f (V.Vector Int32)
|
||||
} deriving (Generic, B.Beamable)
|
||||
|
||||
type Ballot = BallotT B.Identity
|
||||
|
||||
-- deriving instance Show Ballot
|
||||
-- deriving instance Eq Ballot
|
||||
-- deriving instance Ord Ballot
|
||||
|
||||
instance B.Table PollT where
|
||||
data PrimaryKey PollT f = PollId (B.C f SerialInt) deriving (Generic, B.Beamable)
|
||||
primaryKey = PollId . (identity :: PollT f -> B.C f SerialInt)
|
||||
|
||||
instance B.Table OptionT where
|
||||
data PrimaryKey OptionT f = OptionId (B.Columnar f SerialInt) deriving (Generic, B.Beamable)
|
||||
primaryKey = OptionId . (identity :: OptionT f -> B.Columnar f SerialInt)
|
||||
|
||||
instance B.Table BallotT where
|
||||
data PrimaryKey BallotT f = BallotId (B.Columnar f SerialInt) deriving (Generic, B.Beamable)
|
||||
primaryKey = BallotId . (identity :: BallotT f -> B.Columnar f SerialInt)
|
||||
|
||||
type PollId = B.PrimaryKey PollT B.Identity
|
||||
|
||||
-- the actual database
|
||||
data PollDatabase f = PollDatabase {
|
||||
polls :: f (B.TableEntity PollT),
|
||||
options :: f (B.TableEntity OptionT),
|
||||
ballots :: f (B.TableEntity BallotT)
|
||||
} deriving (Generic, B.Database be)
|
||||
|
||||
|
||||
getPoll :: Int32 -> BM.Q BP.Postgres PollDatabase s (PollT (BM.QExpr BP.Postgres s))
|
||||
getPoll id = do
|
||||
poll' <- B.all_ $ polls pollDb
|
||||
B.guard_ (B.primaryKey poll' B.==. (PollId . fromIntegral $ id))
|
||||
pure poll'
|
||||
|
||||
-- getOptionsForPoll :: BM.MonadBeam BP.Postgres m => Int32 -> m [Option]
|
||||
-- getOptionsForPoll = B.runSelectReturningList . B.select . getOptionsForPoll'
|
||||
|
||||
-- getOptionsForPoll' :: Int32 -> BM.Q BP.Postgres PollDatabase s (OptionT (BM.QExpr BP.Postgres s))
|
||||
-- getOptionsForPoll' id = do
|
||||
-- options' <- B.all_ $ options pollDb
|
||||
-- B.guard_ ((forPoll :: OptionT f -> B.PrimaryKey PollT f) options' B.==. (PollId . fromIntegral $ id))
|
||||
-- pure options'
|
||||
|
||||
-- insertPoll :: MonadBeamInsertReturning BP.Postgres m => A.CreatePollReq -> m (PollT BM.Identity, [OptionT BM.Identity])
|
||||
insertPoll :: MonadBeamInsertReturning BP.Postgres m => A.CreatePollReq -> m [PollT BM.Identity]
|
||||
insertPoll A.CreatePollReq{..} = BSQLE.runInsertReturningList . B.insert (polls pollDb) $ B.insertExpressions [PollT B.default_ (B.val_ question)]
|
||||
-- insertOptions :: MonadBeamInsertReturning BP.Postgres m => m [OptionT BM.Identity]
|
||||
insertOptions pollId' optionNames = BSQLE.runInsertReturningList . B.insert (options pollDb) $ B.insertExpressions $ map toOption optionNames
|
||||
createPoll :: ID.UUID -> P.CreatePollInfo -> Ac.Update DB ()
|
||||
createPoll uuid createInfo = MS.modify $ go uuid
|
||||
where
|
||||
toOption optionName = OptionT B.default_ (B.val_ $ B.SqlSerial $ pollId') (B.val_ optionName)
|
||||
go uuid DB {..} = DB {polls = M.insert uuid insertedPoll polls, ..}
|
||||
|
||||
insertedPoll = P.Poll
|
||||
{
|
||||
createInfo = createInfo,
|
||||
votes = []
|
||||
}
|
||||
|
||||
-- postBallot :: MonadBeamInsertReturning BP.Postgres m => Int32 -> [Int32] -> m ()
|
||||
postBallot pollKey optionKeys = BSQLE.runInsertReturningList . B.insert (ballots pollDb) $ B.insertExpressions [BallotT B.default_ (B.val_ pollKey) (B.val_ optionKeys)]
|
||||
getPollForBallot :: ID.UUID -> Ac.Query DB (Maybe P.CreatePollInfo)
|
||||
getPollForBallot pollId = MR.asks (fmap P.createInfo . M.lookup pollId . polls)
|
||||
|
||||
pollDb :: B.DatabaseSettings BP.Postgres PollDatabase
|
||||
pollDb = BM.unCheckDatabase checkedSettings
|
||||
getPoll :: ID.UUID -> Ac.Query DB (Maybe P.Poll)
|
||||
getPoll pollId = MR.asks $ M.lookup pollId . polls
|
||||
|
||||
checkedSettings :: BM.CheckedDatabaseSettings BP.Postgres PollDatabase
|
||||
checkedSettings = BM.defaultMigratableDbSettings
|
||||
postBallot :: ID.UUID -> B.Ballot -> Ac.Update DB ()
|
||||
postBallot pollId ballot = MS.modify go
|
||||
where
|
||||
go DB{..} = DB {polls = M.adjust prependVote pollId polls}
|
||||
where
|
||||
prependVote P.Poll{..} = P.Poll {votes = ballot : votes, ..}
|
||||
|
||||
connection = PS.connect $ PS.defaultConnectInfo {PS.connectUser = "jackoe", PS.connectDatabase = "postgres"}
|
||||
openLocalDB :: IO (Ac.AcidState DB)
|
||||
openLocalDB = Ac.openLocalState $ DB []
|
||||
|
||||
makeDB = BMS.createSchema BPM.migrationBackend checkedSettings
|
||||
$(SC.deriveSafeCopy 0 'SC.base ''DB)
|
||||
$(SC.deriveSafeCopy 0 'SC.base ''ID.UUID)
|
||||
$(SC.deriveSafeCopy 0 'SC.base ''P.CreatePollInfo)
|
||||
$(SC.deriveSafeCopy 0 'SC.base ''P.Poll)
|
||||
$(SC.deriveSafeCopy 0 'SC.base ''B.Ballot)
|
||||
|
||||
Ac.makeAcidic ''DB['createPoll, 'getPollForBallot, 'getPoll, 'postBallot]
|
||||
|
|
|
|||
|
|
@ -1,87 +1,108 @@
|
|||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Main where
|
||||
import Control.Concurrent (takeMVar)
|
||||
import Control.Monad.IO.Class (MonadIO(liftIO))
|
||||
import Servant
|
||||
import Servant.Server
|
||||
import Data.Int
|
||||
import qualified API as A
|
||||
import AppM
|
||||
import qualified Control.Concurrent.MVar as MV
|
||||
import qualified Data.List.NonEmpty as LN
|
||||
import qualified Data.Text as T
|
||||
import qualified InstantRunoff as IR
|
||||
import qualified Network.Wai.Handler.Warp as W
|
||||
-- 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 TIO
|
||||
import qualified Database as DB
|
||||
import Servant.API
|
||||
import Database.Beam.Postgres (runBeamPostgres, runBeamPostgresDebug)
|
||||
import Database (connection)
|
||||
import qualified Database.Beam.Postgres as PS
|
||||
import Data.Aeson (ToJSON(toJSON), encode)
|
||||
import qualified Data.Acid as Ac
|
||||
import qualified Database as DB
|
||||
import qualified Data.IORef as IOR
|
||||
import qualified Data.UUID as ID
|
||||
import qualified Data.ByteString.Lazy as BS
|
||||
import qualified Control.Monad as CM
|
||||
import qualified Data.Map.Strict as M
|
||||
import qualified Data.Hashable as H
|
||||
import qualified Data.Maybe as My
|
||||
import qualified Data.UUID.V4 as IDV
|
||||
import qualified API as A
|
||||
import qualified Data.Maybe as Mb
|
||||
import qualified Data.List.NonEmpty as LN
|
||||
import qualified Error as Er
|
||||
import qualified Poll as P
|
||||
import qualified Ballot as B
|
||||
import qualified Control.Monad.Reader as Rd
|
||||
import qualified Control.Monad.Except as Ex
|
||||
import qualified Poll as P
|
||||
-- import qualified Miso.Svg as DB
|
||||
-- staticDir = "./static"
|
||||
|
||||
staticDir = "./static"
|
||||
|
||||
-- getPoll :: Int -> Handler A.Poll
|
||||
-- getPoll id = do
|
||||
-- mvdb <- liftIO DB.db
|
||||
-- db' <- liftIO $ MV.readMVar mvdb
|
||||
-- return $ poll db'
|
||||
getPollForBallot :: T.Text -> AppM P.CreatePollInfo
|
||||
getPollForBallot pollId = do
|
||||
db <- Rd.asks db
|
||||
getFromUuid pollId (liftIO . Ac.query db . DB.GetPollForBallot)
|
||||
|
||||
-- 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
|
||||
throwOrLift :: AppM a -> Maybe a -> AppM a
|
||||
throwOrLift err = Mb.maybe err pure
|
||||
|
||||
makePoll :: A.CreatePollReq -> Handler Int
|
||||
toUuid pollId = maybe (Er.badPollId pollId) pure . ID.fromText $ pollId
|
||||
|
||||
-- I didn't want to grab the whole poll (with votes) from the database so instead I pass a function
|
||||
-- realistically, this function one of liftIO . Ac.query db . DB.GetPoll/DB.GetPollForBallot
|
||||
getFromUuid :: T.Text -> (ID.UUID -> AppM (Maybe a)) -> AppM a
|
||||
getFromUuid pollId query = do
|
||||
pollUuid <- toUuid pollId
|
||||
pollResult <- query pollUuid
|
||||
throwOrLift (Er.noPollFound pollId) pollResult
|
||||
|
||||
getResult :: T.Text -> AppM A.PollResult
|
||||
getResult pollId = do
|
||||
db <- Rd.asks db
|
||||
poll <- getFromUuid pollId $ liftIO . Ac.query db . DB.GetPoll
|
||||
votesList <- throwOrLift Er.noVotes $ maybeVotes poll
|
||||
pure $ solveAndUnHash poll votesList
|
||||
where
|
||||
|
||||
-- discarding empty ballots
|
||||
maybeVotes :: P.Poll -> Maybe (LN.NonEmpty (LN.NonEmpty B.OptionHash))
|
||||
maybeVotes = LN.nonEmpty . Mb.mapMaybe (LN.nonEmpty . B.votes) . P.votes
|
||||
|
||||
unHashedMap = mapFromHash . P.options . P.createInfo
|
||||
|
||||
solveAndUnHash poll = My.mapMaybe (`M.lookup` unHashedMap poll) . S.toList . IR.solve
|
||||
|
||||
|
||||
mapFromHash :: [T.Text] -> M.Map B.OptionHash T.Text
|
||||
mapFromHash = M.fromList . map (\x -> (H.hash x, x))
|
||||
|
||||
makePoll :: P.CreatePollInfo -> AppM T.Text
|
||||
makePoll pollReq = do
|
||||
connection <- liftIO grabConnection
|
||||
[poll] <- liftIO . runBeamPostgresDebug putStrLn connection $ DB.insertPoll pollReq
|
||||
liftIO . runBeamPostgresDebug putStrLn connection . DB.insertOptions . A.optionNames $ pollReq
|
||||
pure . fromIntegral . (DB.identity :: DB.Poll -> DB.SerialInt) $ poll
|
||||
db <- Rd.asks db
|
||||
newId <- liftIO IDV.nextRandom
|
||||
liftIO $ Ac.update db (DB.CreatePoll newId pollReq)
|
||||
pure $ ID.toText newId
|
||||
|
||||
getOptions :: Int -> Handler [T.Text]
|
||||
getOptions id = do
|
||||
connection <- liftIO grabConnection
|
||||
options <- liftIO . runBeamPostgresDebug putStrLn connection . DB.getOptionsForPoll . fromIntegral $ id
|
||||
pure $ map DB.name options
|
||||
vote :: T.Text -> B.Ballot -> AppM ()
|
||||
vote pollId ballot = do
|
||||
db <- Rd.asks db
|
||||
uuid <- toUuid pollId
|
||||
liftIO $ Ac.update db (DB.PostBallot uuid ballot)
|
||||
pure ()
|
||||
|
||||
-- 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 ()
|
||||
server :: ServerT A.RCVAPI AppM
|
||||
server = makePoll :<|> getPollForBallot :<|> vote :<|> getResult
|
||||
|
||||
server :: Server A.RCVAPI
|
||||
-- server = vote :<|> makePoll :<|> getPoll :<|> getResult
|
||||
server = makePoll :<|> getOptions
|
||||
|
||||
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
|
||||
|
||||
|
||||
-- in the future this won't remake the connection every time
|
||||
grabConnection :: IO PS.Connection
|
||||
grabConnection = DB.connection
|
||||
api :: Proxy A.RCVAPI
|
||||
api = Proxy
|
||||
|
||||
getEnv = Env <$> DB.openLocalDB
|
||||
|
||||
runWithEnv :: Env -> AppM a -> Handler a
|
||||
runWithEnv = flip Rd.runReaderT
|
||||
|
||||
-- main :: IO ()
|
||||
main = do
|
||||
connection <- DB.connection
|
||||
W.run 8080 app
|
||||
-- runBeamPostgres connection DB.makeDB
|
||||
BS.putStrLn $ encode . toJSON $ P.CreatePollInfo (Just "hello") "sup" []
|
||||
env <- getEnv
|
||||
W.run 8080 $ serve api $ hoistServer api (runWithEnv env) server
|
||||
|
|
|
|||
|
|
@ -1,24 +0,0 @@
|
|||
|
||||
module API where
|
||||
|
||||
import GHC.Generics
|
||||
import Servant.API
|
||||
|
||||
import qualified Data.Text as T
|
||||
import Data.Aeson
|
||||
import Data.Word
|
||||
import qualified Data.List.NonEmpty as LN
|
||||
import qualified Database.Beam as B
|
||||
|
||||
|
||||
-- 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]
|
||||
|
||||
|
||||
|
||||
-- deriving instance Show Vote
|
||||
-- deriving instance Eq Vote
|
||||
-- deriving instance Ord Vote
|
||||
Loading…
Add table
Add a link
Reference in a new issue