single setup server working (with MVar as DB)

default.nix

@@ -1,16 +0,0 @@
-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

@@ -58,34 +58,32 @@ executable server
       API
       InstantRunoff
 
-
+-- this has to be built with ghcjs to be useful,
+-- but ghc should still be able build it
 executable client
   main-is:
     Main.hs
-  if !impl(ghcjs)
-    buildable: False
-  else
-    default-extensions:
-      ScopedTypeVariables,
-      OverloadedStrings,
-      OverloadedLists,
-      DataKinds,
-      TypeOperators,
-      RecordWildCards,
-      DuplicateRecordFields,
-      DeriveGeneric
-    ghcjs-options:
-      -dedupe -DGHCJS_GC_INTERVAL=5000
-    hs-source-dirs:
-      client,
-      shared
-    build-depends:
-      aeson,
-      base < 5,
-      containers,
-      miso,
-      servant,
-      -- servant-client-ghcjs,
-      text
-    default-language:
-      Haskell2010
+  default-extensions:
+    ScopedTypeVariables,
+    OverloadedStrings,
+    OverloadedLists,
+    DataKinds,
+    TypeOperators,
+    RecordWildCards,
+    DuplicateRecordFields,
+    DeriveGeneric
+  ghcjs-options:
+    -dedupe -DGHCJS_GC_INTERVAL=5000
+  hs-source-dirs:
+    client,
+    shared
+  build-depends:
+    aeson,
+    base < 5,
+    containers,
+    miso,
+    servant,
+    -- servant-client-ghcjs,
+    text
+  default-language:
+    Haskell2010

server/InstantRunoff.hs

@@ -1,6 +1,3 @@
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
 module InstantRunoff where
 import qualified Data.List as L
 import qualified Data.List.NonEmpty as LN
@@ -13,25 +10,16 @@ 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
+solve :: Ord a => Show a => LN.NonEmpty (LN.NonEmpty a) -> S.Set a
+solve votes = maybe (M.keysSet voteCounts) solve . remove $ firstChoiceLosers
     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
+    -- if Nothing, then all options in votes are valued equally
+    -- remove :: S.Set a -> LN.NonEmpty (LN.NonEmpty a) -> Maybe (LN.NonEmpty (LN.NonEmpty a))
+    remove toRemove = catMaybes . LN.map (LN.nonEmpty . LN.filter (`S.notMember` toRemove)) $ votes
 
     -- firstChoiceLosers :: S.Set a
-    firstChoiceLosers = fst . foldl minCollect (S.empty , maxBound) . L.sortBy (comparing snd) . M.toList $ voteCounts
-
-    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)
+    firstChoiceLosers = M.keysSet . M.filter ((==) . L.minimum . M.elems $ voteCounts) $ voteCounts
 
     -- firstChoices :: LN.NonEmpty a
     firstChoices = LN.map LN.head votes

server/Main.hs

@@ -1,18 +1,21 @@
 {-# 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 Servant.API
+import Servant.Server
+import qualified API as A
+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 T
 
 staticDir = "./static"
 
@@ -24,17 +27,22 @@ data DB = DB {
 
 db :: IO (MV.MVar DB)
 db = MV.newMVar $ DB {
-  poll = A.Poll {
+  poll = A.Poll
+    {
       question = "What's your favorite color?",
-      options = LN.fromList [
+      options = LN.fromList
+        [
           "blue",
           "red",
           "green",
           "yellow"
-                                     ]
-              },
-    votes = []
-                     }
+        ]
+    },
+    votes = mockVotes
+  }
+
+mockVotes :: [A.Ballot]
+mockVotes = [["blue", "red", "green", "yellow"], ["red", "blue", "green", "yellow"], ["red"]]
 
 getPoll :: Int -> Handler A.Poll
 getPoll id = do
@@ -42,6 +50,13 @@ getPoll id = do
   db' <- liftIO $ MV.readMVar mvdb
   return $ poll db'
 
+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)
 
@@ -54,7 +69,7 @@ vote pollId ballot = do
   return ()
 
 server :: Server A.RCVAPI
-server = vote :<|> makePoll :<|> getPoll :<|> SSF.serveDirectoryWebApp staticDir
+server = vote :<|> makePoll :<|> getPoll :<|> getResult :<|> SSF.serveDirectoryWebApp staticDir
 
 rcpAPI :: Proxy A.RCVAPI
 rcpAPI = Proxy

shared/API.hs

@@ -10,10 +10,21 @@ import qualified Data.List.NonEmpty as LN
 
 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, Ord, Eq)
+} 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
@@ -21,5 +32,6 @@ 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 :> Get '[JSON] Poll
+  :<|> "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