added client, added nix setup neither working yet

README.md

@@ -1 +1,4 @@
 Allows someone to setup a quick poll decided by [ranked voting](https://en.wikipedia.org/wiki/Ranked_voting) (currently just [instant runoff](https://en.wikipedia.org/wiki/Instant-runoff_voting)). Currently just the algorithm itself is implemented.
+
+
+Be sure to setup [miso cachix](https://app.cachix.org/cache/miso-haskell) and [haskell.nix binary cache](https://input-output-hk.github.io/haskell.nix/tutorials/getting-started-flakes.html#setting-up-the-binary-cache) to avoid compiling too much stuff.

cabal.config

@@ -1 +0,0 @@
-compiler: ghcjs

cabal.project

@@ -1,3 +0,0 @@
-ignore-project: False
-package zlib
-  flags: -pkg-config +bundled-c-zlib

client/Main.hs

@@ -4,8 +4,14 @@
 module Main where
 
 -- | Miso framework import
+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
@@ -41,8 +47,36 @@ updateModel SayHelloWorld m = m <# do
 
 -- | Constructs a virtual DOM from a model
 viewModel :: Model -> View Action
-viewModel x = div_ [] [
-   button_ [ onClick AddOne ] [ text "+" ]
- , text (ms x)
- , button_ [ onClick SubtractOne ] [ text "-" ]
- ]
+viewModel m =  div_ [] [text "it worked"]
+
+
+-- tempURI _ = URI "http://" Nothing "" "" ""
+
+-- 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

default.nix

@@ -1,10 +1,16 @@
-with (import
-(
-builtins.fetchGit {
-        url = "https://github.com/dmjio/miso";
-        ref = "master";
-    }
-)
-{});
-
-pkgs.haskell.packages.ghcjs.callCabal2nix "rcv-site" ./. {}
+with (import (builtins.fetchGit {
+  url = "https://github.com/dmjio/miso";
+  ref = "master";
+}) {});
+let
+  inherit (pkgs) runCommand;
+  haskellNix = (import (builtins.fetchTarball https://github.com/input-output-hk/haskell.nix/archive/master.tar.gz) {});
+  client = haskellNix.pkgs-unstable.pkgsCross.ghcjs.buildPackages.haskell-nix.callCabalToNix {name = "client"; src = ./.;};
+  server = haskellNix.pkgs-unstable.pkgs.haskell-nix.callCabalToNix {name = "server"; src = ./.;};
+in
+  runCommand "rcv-site-deploy" { inherit client server; } ''
+    mkdir -p $out/{bin,static}
+    cp ${server}/bin/* $out/bin
+    cp ${client}/bin/* $out/static
+    echo "donezo"
+  ''

rcv-site.cabal

@@ -35,8 +35,9 @@ executable server
       server,
       shared
     build-depends:
-      base < 5,
+      acid-state,
       aeson,
+      base < 5,
       containers,
       http-types,
       lucid,
@@ -53,6 +54,9 @@ executable server
       warp
     default-language:
       Haskell2010
+    other-modules:
+      API
+      InstantRunoff
 
 
 executable client
@@ -65,6 +69,8 @@ executable client
       ScopedTypeVariables,
       OverloadedStrings,
       OverloadedLists,
+      DataKinds,
+      TypeOperators,
       RecordWildCards,
       DuplicateRecordFields,
       DeriveGeneric
@@ -78,6 +84,8 @@ executable client
       base < 5,
       containers,
       miso,
-      servant
+      servant,
+      -- servant-client-ghcjs,
+      text
     default-language:
       Haskell2010

server/InstantRunoff.hs

@@ -1,39 +1,43 @@
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
 module InstantRunoff where
 import qualified Data.List as L
 import qualified Data.List.NonEmpty as LN
 import qualified Data.Map.Strict as M
 import qualified Data.Maybe as My
 import qualified Data.Set as S
+import qualified Data.Foldable as F
 import Data.Ord
-import Data.Maybe
+import Data.Maybe hiding (catMaybes)
 import Data.Ratio
+import qualified Data.Maybe as L
 
+solve :: Ord a => LN.NonEmpty (LN.NonEmpty a) -> S.Set a
+solve votes
+  -- only one option left
+  | (==) 1 . length . L.nub . LN.toList . LN.map LN.toList $ votes = S.singleton . LN.head . LN.head $ votes
+  | otherwise = S.empty
+    where
 
-solve :: Ord a => LN.NonEmpty (LN.NonEmpty a) -> LN.NonEmpty a
-solve votes =
-  case (L.find (\(_, share) -> share > (1 % 2)) . assocs) of
-    Just (winner, share) -> return winner -- singleton not introduced until base 4.15
-    Nothing -> solve . remove $ S.insert noFirstChoice firstChoiceLoser
-  where
+    -- fromList is partial, but inputs that would cause a failure are caught by the case statement
+    -- remove :: Ord a => S.Set a -> LN.NonEmpty (LN.NonEmpty a) -> Maybe (LN.NonEmpty (LN.NonEmpty a))
+    remove toRemove = catMaybes . LN.map (LN.nonEmpty . LN.filter (`S.member` toRemove)) $ votes
 
-    -- fromList is partial, but inputs that would cause a faliure are caught by the case statement
-    remove :: S.Set a -> LN.NonEmpty (LN.NonEmpty a)
-    remove toRemove = LN.fromList . LN.filter null . LN.map (`elem` toRemove) $ votes
+    -- firstChoiceLosers :: S.Set a
+    firstChoiceLosers = fst . foldl minCollect (S.empty , maxBound) . L.sortBy (comparing snd) . M.toList $ voteCounts
 
-    firstChoiceLoser :: a
-    firstChoiceLoser = L.minimumBy (\(_, a0) (_, a1) -> compare a0 a1) . LN.map LN.head $ voteShares'
+    minCollect :: Ord a => Ord b => (S.Set a, b) -> (a, b) -> (S.Set a, b)
+    minCollect (currTops, a0) (topCandidate, a1)
+      | a0 == a1 = (S.insert topCandidate currTops, a0)
+      | a0 > a1 = (S.singleton topCandidate, a1)
+      | otherwise = (currTops, a0)
 
-    firstChoices :: LN.NonEmpty a
-    firstChoices = LN.map LN.head $ votes
+    -- firstChoices :: LN.NonEmpty a
+    firstChoices = LN.map LN.head votes
 
-    voteShares' :: LN.NonEmpty a -> M.Map a (Ratio Int)
-    voteShares' = voteShares firstChoices
+    -- voteCounts :: M.Map a Word
+    voteCounts = M.unionsWith (+) . map (`M.singleton` (1 :: Word)) . LN.toList $ firstChoices
 
-    noFirstChoice :: S.Set a
-    noFirstChoice = (S.fromList LN.toList . mconcat $ votes) S.\\ (S.fromList . LN.toList $ firstChoices)
-
-allSame :: Eq a => [a] -> Bool
-allSame = (== 1) . LN.length . LN.nub
-
-voteShares :: Ord a => LN.NonEmpty a -> M.Map a (Ratio Int)
-voteShares l = M.map (% (LN.length l)) . M.fromListWith (+) . map (, 1) . LN.toList $ l
+catMaybes :: LN.NonEmpty (Maybe a) -> Maybe (LN.NonEmpty a)
+catMaybes = LN.nonEmpty . L.catMaybes . LN.toList

server/Main.hs

@@ -1,6 +1,69 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
 module Main where
 import qualified InstantRunoff as IR
 import qualified API as A
+import qualified Data.Text as T
+import Servant.API
+import Servant.Server
+import qualified Control.Concurrent.MVar as MV
+import qualified Data.List.NonEmpty as LN
+import Control.Concurrent (takeMVar)
+import Control.Monad.IO.Class (MonadIO(liftIO))
+import Servant
+import qualified Network.Wai.Handler.Warp as W
+import qualified Servant.Server.StaticFiles as SSF
+
+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 = []
+                     }
+
+getPoll :: Int -> Handler A.Poll
+getPoll id = do
+  mvdb <- liftIO db
+  db' <- liftIO $ MV.readMVar mvdb
+  return $ poll db'
+
+makePoll :: A.Poll -> Handler Int
+makePoll poll = return (-1)
+
+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 :<|> SSF.serveDirectoryWebApp staticDir
+
+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
 
 main :: IO ()
-main = putStrLn "todo"
+main = W.run 8080 app

shared/API.hs

@@ -1,6 +1,9 @@
+
 module API where
 
+import GHC.Generics
 import Servant.API
+
 import Data.Text (Text)
 import Data.Aeson
 import qualified Data.List.NonEmpty as LN
@@ -15,10 +18,8 @@ data Poll = Poll {
 instance FromJSON Poll
 instance ToJSON Poll
 
-instance FromJSON Ballot
-instance ToJSON Ballot
-
 type RCVAPI =
-  "poll" :> Capture "pollId" :> "vote" :> ReqBody '[JSON] Ballot :> Post '[JSON] ()
-  <|> "poll" :> "create" :> ReqBody '[JSON] Poll :> Post '[JSON] Int
-  <|> "poll" :> Capture "pollId" :> Get '[JSON] Poll
+  "poll" :> Capture "pollId" Int :> "vote" :> ReqBody '[JSON] Ballot :> Post '[JSON] ()
+  :<|> "poll" :> "create" :> ReqBody '[JSON] Poll :> Post '[JSON] Int
+  :<|> "poll" :> Capture "pollId" Int :> Get '[JSON] Poll
+  :<|> Raw