server works, back to json api
This commit is contained in:
parent
9551a3f25d
commit
fd83d22fd8
16 changed files with 31 additions and 558 deletions
|
|
@ -1,2 +0,0 @@
|
|||
import Distribution.Simple
|
||||
main = defaultMain
|
||||
|
|
@ -1,72 +0,0 @@
|
|||
cabal-version: 2.4
|
||||
name: client
|
||||
version: 0.1.0.0
|
||||
|
||||
executable client
|
||||
main-is: Main.hs
|
||||
build-depends:
|
||||
base,
|
||||
Shpadoinkle,
|
||||
Shpadoinkle-backend-snabbdom,
|
||||
Shpadoinkle-html,
|
||||
Shpadoinkle-router,
|
||||
text,
|
||||
servant,
|
||||
aeson,
|
||||
containers,
|
||||
deepseq
|
||||
|
||||
default-extensions:
|
||||
CPP,
|
||||
DataKinds,
|
||||
DeriveAnyClass,
|
||||
DeriveGeneric,
|
||||
DerivingStrategies,
|
||||
DuplicateRecordFields,
|
||||
FlexibleInstances,
|
||||
GeneralizedNewtypeDeriving,
|
||||
LambdaCase,
|
||||
MultiParamTypeClasses,
|
||||
OverloadedLabels,
|
||||
OverloadedLists,
|
||||
OverloadedStrings,
|
||||
RecordWildCards,
|
||||
RecursiveDo,
|
||||
ScopedTypeVariables,
|
||||
StandaloneDeriving,
|
||||
TemplateHaskell,
|
||||
TypeApplications,
|
||||
TypeOperators,
|
||||
TypeSynonymInstances
|
||||
|
||||
|
||||
|
||||
hs-source-dirs: src, shared-src
|
||||
default-language: Haskell2010
|
||||
|
||||
ghc-options:
|
||||
-Wall
|
||||
-Wcompat
|
||||
-fwarn-redundant-constraints
|
||||
-fwarn-incomplete-uni-patterns
|
||||
-fwarn-tabs
|
||||
-fwarn-incomplete-record-updates
|
||||
-fwarn-identities
|
||||
|
||||
ghcjs-options:
|
||||
-Wall
|
||||
-Wcompat
|
||||
-fno-warn-missing-home-modules
|
||||
-fwarn-redundant-constraints
|
||||
-fwarn-incomplete-uni-patterns
|
||||
-fwarn-tabs
|
||||
-fwarn-incomplete-record-updates
|
||||
-fwarn-identities
|
||||
-O2
|
||||
|
||||
other-modules:
|
||||
InProgressPoll
|
||||
Client
|
||||
API
|
||||
Poll
|
||||
Ballot
|
||||
|
|
@ -1 +0,0 @@
|
|||
(import ./nix/base.nix).build
|
||||
|
|
@ -1 +0,0 @@
|
|||
(import ./nix/base.nix).shell
|
||||
|
|
@ -1,23 +0,0 @@
|
|||
module InProgressPoll where
|
||||
import qualified Data.Text as T
|
||||
import GHC.Generics
|
||||
import qualified Control.DeepSeq as DS
|
||||
import qualified Data.List.NonEmpty as LN
|
||||
import qualified Poll as P
|
||||
|
||||
data InProgressPoll = InProgressPoll
|
||||
{ title :: Maybe T.Text,
|
||||
question :: T.Text,
|
||||
options :: [T.Text]
|
||||
} deriving (Generic, Eq, Show, DS.NFData)
|
||||
|
||||
modTitle newTitle poll = poll {title = newTitle}
|
||||
modQuestion newQuestion poll = poll {question = newQuestion}
|
||||
|
||||
nonEmpty "" = Nothing
|
||||
nonEmpty xs = Just xs
|
||||
|
||||
-- toCreatePollInfo :: InProgressPoll -> Maybe P.CreatePollInfo
|
||||
-- toCreatePollInfo InProgressPoll{..} = case (not . T.null $ question, LN.nonEmpty =<< mapM nonEmpty options) of
|
||||
-- (True, Just options') -> Just $ P.CreatePollInfo (nonEmpty title) question options'
|
||||
-- _ -> Nothing
|
||||
|
|
@ -1,115 +0,0 @@
|
|||
module Main where
|
||||
|
||||
import qualified Control.DeepSeq as DS
|
||||
import qualified Data.Maybe as My
|
||||
import GHC.Generics
|
||||
import qualified InProgressPoll as IP
|
||||
import qualified Poll as P
|
||||
import Shpadoinkle (Html, JSM)
|
||||
import qualified Shpadoinkle as Sh
|
||||
import Shpadoinkle.Backend.Snabbdom (runSnabbdom, stage)
|
||||
import qualified Data.Text as T
|
||||
import Shpadoinkle.Html
|
||||
import qualified Shpadoinkle.Html as SHtml
|
||||
import Shpadoinkle.Run (live, runJSorWarp, simple, fullPageJSM)
|
||||
import qualified Shpadoinkle.Router as ShR
|
||||
import qualified Data.List as L
|
||||
import qualified Routes as R
|
||||
|
||||
headHtml = head_ [link' [rel "stylesheet", type' "text/css", href "https://unpkg.com/papercss@1.8.3/dist/paper.css"]]
|
||||
|
||||
withLabel name inputProps = div_ [label'', input'']
|
||||
where
|
||||
label'' = label [for' name] [text name]
|
||||
input'' = input' $ for' name : inputProps
|
||||
|
||||
view :: Functor m => Model -> Html m Model
|
||||
view model = html_ [headHtml,
|
||||
body []
|
||||
[ liftedTitle,
|
||||
question,
|
||||
liftedOptions
|
||||
]]
|
||||
where
|
||||
question = withLabel "question"
|
||||
[
|
||||
value . IP.question . creatingPoll $ model,
|
||||
onInput (\x model -> model {creatingPoll = IP.modQuestion x (creatingPoll model)})
|
||||
]
|
||||
|
||||
liftedTitle :: Functor m => Html m Model
|
||||
liftedTitle = Sh.liftC modifyModelTitle (IP.title . creatingPoll) . titleHtml . IP.title . creatingPoll $ model
|
||||
|
||||
liftedOptions :: Functor m => Html m Model
|
||||
liftedOptions = Sh.liftC modifyModelOptions (IP.options . creatingPoll) optionsHtml'
|
||||
|
||||
optionsHtml' :: Functor m => Html m [T.Text]
|
||||
optionsHtml' = optionsHtml . IP.options . creatingPoll $ model
|
||||
|
||||
modifyModelOptions :: [T.Text] -> Model -> Model
|
||||
modifyModelOptions newOptions model = model {creatingPoll = (creatingPoll model) {IP.options = newOptions}}
|
||||
|
||||
modifyModelTitle :: Maybe T.Text -> Model -> Model
|
||||
modifyModelTitle newTitle model = model {creatingPoll = (creatingPoll model) {IP.title = newTitle}}
|
||||
|
||||
titleHtml :: Functor m => Maybe T.Text -> Html m (Maybe T.Text)
|
||||
titleHtml Nothing = button [onClick (const $ Just T.empty)] ["add title"]
|
||||
titleHtml (Just title) = div_ [titleInput, addTitleButton]
|
||||
where
|
||||
titleInput = withLabel "title"
|
||||
[value title,
|
||||
onInput (const . Just)
|
||||
]
|
||||
|
||||
addTitleButton = button [onClick (const Nothing), removeButtonClass] ["remove"]
|
||||
|
||||
removeButtonClass = className "btn-danger paper-btn btn-small"
|
||||
|
||||
optionsHtml :: Functor m => [T.Text] -> Html m [T.Text]
|
||||
optionsHtml = div_ . (addOptionButton :) . zipWith toOptionHtml [0..]
|
||||
where
|
||||
addOptionButton :: Html m [T.Text]
|
||||
addOptionButton = button [onClick (T.empty :)] ["add option"]
|
||||
|
||||
toOptionHtml :: Functor m => Int -> T.Text -> Html m [T.Text]
|
||||
toOptionHtml loc option = Sh.liftC (modifyOption loc) (Just . (!! loc)) (optionHtml option)
|
||||
|
||||
modifyOption :: Int -> Maybe T.Text -> [T.Text] -> [T.Text]
|
||||
modifyOption loc newOption options = (mods options !! loc) newOption
|
||||
|
||||
optionHtml :: T.Text -> Html m (Maybe T.Text)
|
||||
optionHtml optionText = div_ [input' [onInput (const . Just), value optionText],
|
||||
button [onClick (const Nothing), removeButtonClass] ["remove"]]
|
||||
|
||||
mods :: [a] -> [Maybe a -> [a]]
|
||||
mods xs = zipWith toModFn (L.inits xs) (init $ L.tails xs)
|
||||
where
|
||||
toModFn :: [a] -> [a] -> Maybe a -> [a]
|
||||
toModFn xs (y:ys) (Just newY) = xs ++ newY : ys
|
||||
toModFn xs (y:ys) Nothing = xs ++ ys
|
||||
|
||||
app :: JSM ()
|
||||
app = ShR.fullPageSPA runSnabbdom dummyStart view stage dummyStart R.routes
|
||||
|
||||
dummyStart = const . pure $ Create startingPoll
|
||||
|
||||
startingPoll :: IP.InProgressPoll
|
||||
startingPoll =
|
||||
IP.InProgressPoll
|
||||
{ title = Nothing,
|
||||
question = "",
|
||||
options = ["option1", "option2"]
|
||||
}
|
||||
|
||||
|
||||
data Model = Create { creatingPoll :: IP.InProgressPoll }
|
||||
deriving (Generic, Eq, Show, DS.NFData)
|
||||
|
||||
dev :: IO ()
|
||||
dev = live 8080 app
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
putStrLn "\nhi, my name is client"
|
||||
putStrLn "happy point of view on http://localhost:8080\n"
|
||||
runJSorWarp 8080 app
|
||||
15
server/API.hs
Normal file
15
server/API.hs
Normal file
|
|
@ -0,0 +1,15 @@
|
|||
module API where
|
||||
|
||||
import Servant.API
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified Poll as P
|
||||
import qualified Ballot as B
|
||||
|
||||
type PollResult = [T.Text]
|
||||
|
||||
type RCVAPI =
|
||||
"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
|
||||
328
server/flake.lock
generated
328
server/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,5 +1,5 @@
|
|||
cabal-version: 3.0
|
||||
name: server
|
||||
name: rcv-site
|
||||
version: 0.1.0.0
|
||||
category: Web
|
||||
build-type: Simple
|
||||
|
|
@ -45,9 +45,9 @@ executable server
|
|||
containers,
|
||||
blaze-html,
|
||||
http-types,
|
||||
lucid,
|
||||
servant-lucid,
|
||||
servant-blaze,
|
||||
-- lucid,
|
||||
-- servant-lucid,
|
||||
-- servant-blaze,
|
||||
-- miso,
|
||||
bytestring,
|
||||
hashable,
|
||||
|
|
@ -56,7 +56,7 @@ executable server
|
|||
-- postgresql-simple,
|
||||
servant,
|
||||
deepseq,
|
||||
servant-lucid,
|
||||
-- servant-lucid,
|
||||
servant-server,
|
||||
text,
|
||||
vector,
|
||||
|
|
@ -1 +0,0 @@
|
|||
../client/shared-src
|
||||
|
|
@ -51,13 +51,15 @@ postBallot pollId ballot = MS.modify go
|
|||
where
|
||||
prependVote P.Poll{..} = P.Poll {votes = ballot : votes, ..}
|
||||
|
||||
openLocalDB :: IO (Ac.AcidState DB)
|
||||
openLocalDB = Ac.openLocalState $ DB []
|
||||
|
||||
$(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)
|
||||
$(SC.deriveSafeCopy 0 'SC.base ''P.Poll)
|
||||
$(SC.deriveSafeCopy 0 'SC.base ''DB)
|
||||
|
||||
Ac.makeAcidic ''DB['createPoll, 'getPollForBallot, 'getPoll, 'postBallot]
|
||||
|
||||
openLocalDB :: IO (Ac.AcidState DB)
|
||||
openLocalDB = Ac.openLocalState $ DB M.empty
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -17,7 +17,6 @@ import qualified Data.IORef as IOR
|
|||
import Data.Int
|
||||
import qualified Data.List.NonEmpty as LN
|
||||
import qualified Data.Map.Strict as M
|
||||
import qualified Data.Maybe as Mb
|
||||
import qualified Data.Maybe as My
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.Text as T
|
||||
|
|
@ -40,7 +39,7 @@ getPollForBallot pollId = do
|
|||
getFromUuid pollId (liftIO . Ac.query db . DB.GetPollForBallot)
|
||||
|
||||
throwOrLift :: AppM a -> Maybe a -> AppM a
|
||||
throwOrLift err = Mb.maybe err pure
|
||||
throwOrLift err = My.maybe err pure
|
||||
|
||||
toUuid pollId = maybe (Er.badPollId pollId) pure . ID.fromText $ pollId
|
||||
|
||||
|
|
@ -61,9 +60,9 @@ getResult pollId = do
|
|||
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
|
||||
maybeVotes = LN.nonEmpty . My.mapMaybe (LN.nonEmpty . B.votes) . P.votes
|
||||
|
||||
unHashedMap = mapFromHash . P.options . P.createInfo
|
||||
unHashedMap = mapFromHash . LN.toList . P.options . P.createInfo
|
||||
|
||||
solveAndUnHash poll = My.mapMaybe (`M.lookup` unHashedMap poll) . S.toList . IR.solve
|
||||
|
||||
|
|
@ -97,6 +96,6 @@ runWithEnv = flip Rd.runReaderT
|
|||
|
||||
-- main :: IO ()
|
||||
main = do
|
||||
BS.putStrLn $ encode . toJSON $ P.CreatePollInfo (Just "hello") "sup" []
|
||||
BS.putStr $ encode . toJSON $ P.CreatePollInfo (Just "hello") "sup" ["option 1"]
|
||||
env <- getEnv
|
||||
W.run 8080 $ serve api $ hoistServer api (runWithEnv env) server
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue