start of the frontend!

README.md

@@ -1,3 +1 @@
-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) to avoid compiling too much stuff.
+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)). At the moment, there's a fully-functional backend and the beginnings of a new poll page on the frontend.

client/Setup.hs

@@ -0,0 +1,2 @@
+import           Distribution.Simple
+main = defaultMain

client/client.cabal

@@ -0,0 +1,61 @@
+cabal-version:       2.4
+name:                client
+version:             0.1.0.0
+
+executable client
+  main-is:             Main.hs
+  build-depends:
+    base ^>=4.12.0.0,
+    Shpadoinkle,
+    Shpadoinkle-backend-snabbdom,
+    Shpadoinkle-html,
+    text,
+    servant,
+    servant-client-js,
+    aeson,
+    containers,
+    deepseq
+
+  default-extensions:
+    DeriveGeneric,
+    DuplicateRecordFields,
+    OverloadedLabels,
+    OverloadedLists,
+    OverloadedStrings,
+    RecursiveDo,
+    ScopedTypeVariables,
+    StandaloneDeriving,
+    TemplateHaskell,
+    DeriveAnyClass,
+    DataKinds,
+    TypeOperators,
+    RecordWildCards
+
+  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
+    API
+    Poll
+    Ballot

client/default.nix

@@ -0,0 +1 @@
+(import ./nix/base.nix).build

client/nix/base.nix

@@ -0,0 +1,125 @@
+let
+  f =
+    build-or-shell:
+    { chan ? "5272327b81ed355bbed5659b8d303cf2979b6953"
+    , compiler ? "ghc865"
+    , withHoogle ? false
+    , doHoogle ? false
+    , doHaddock ? false
+    , enableLibraryProfiling ? false
+    , enableExecutableProfiling ? false
+    , strictDeps ? false
+    , isJS ? false
+    , system ? builtins.currentSystem
+    , optimize ? true
+    , shpadoinkle-path ? null
+    }:
+    let
+
+
+      # It's a shpadoinkle day
+      shpadoinkle = if shpadoinkle-path != null then shpadoinkle-path else builtins.fetchGit {
+        url    = https://gitlab.com/platonic/shpadoinkle.git;
+        ref    = "master";
+        rev    = "a107da66dca476ed5b5ee68981bc235d46107574";
+      };
+
+
+      # Get some utilities
+      inherit (import (shpadoinkle + "/nix/util.nix") { inherit compiler isJS pkgs; }) compilerjs doCannibalize;
+
+
+      # Build faster by doing less
+      chill = p: (pkgs.haskell.lib.overrideCabal p {
+        inherit enableLibraryProfiling enableExecutableProfiling;
+      }).overrideAttrs (_: {
+        inherit doHoogle doHaddock strictDeps;
+      });
+
+
+      # Overlay containing Shpadoinkle packages, and needed alterations for those packages
+      # as well as optimizations from Reflex Platform
+      shpadoinkle-overlay =
+        import (shpadoinkle + "/nix/overlay.nix") { inherit compiler chan isJS enableLibraryProfiling enableExecutableProfiling; };
+
+
+      # Haskell specific overlay (for you to extend)
+      haskell-overlay = hself: hsuper: {
+        "happy" = pkgs.haskell.lib.dontCheck hsuper.happy;
+      };
+
+
+      # Top level overlay (for you to extend)
+      client-app-overlay = self: super: {
+        haskell = super.haskell //
+          { packages = super.haskell.packages //
+            { ${compilerjs} = super.haskell.packages.${compilerjs}.override (old: {
+                overrides = super.lib.composeExtensions (old.overrides or (_: _: {})) haskell-overlay;
+              });
+            };
+          };
+        };
+
+
+      # Complete package set with overlays applied
+      pkgs = import
+        (builtins.fetchTarball {
+          url = "https://github.com/NixOS/nixpkgs/archive/${chan}.tar.gz";
+        }) {
+        inherit system;
+        overlays = [
+          shpadoinkle-overlay
+          client-app-overlay
+        ];
+      };
+
+
+      ghcTools = with pkgs.haskell.packages.${compiler};
+        [ cabal-install
+          ghcid
+        ] ++ (if isJS then [] else [ stylish-haskell ]);
+
+
+      # We can name him George
+      client =
+        with builtins;
+        let
+          l = pkgs.lib;
+          source = ../.;
+        in
+        pkgs.haskell.packages.${compilerjs}.callCabal2nix "client"
+          (filterSource
+             (path: type:
+                let
+                  relative = replaceStrings [(toString source + "/")] [""] path;
+                in
+                  (l.hasPrefix "src" relative || l.hasPrefix "shared-src" relative) && type == "directory"
+                || l.hasSuffix ".hs" path
+                || l.hasSuffix ".cabal" path
+             )
+             source
+          )
+          {};
+
+
+    in with pkgs; with lib;
+
+      { build =
+          (if isJS && optimize then doCannibalize else x: x) (chill client);
+
+        shell =
+          pkgs.haskell.packages.${compilerjs}.shellFor {
+            inherit withHoogle;
+            packages    = _: [ client ];
+            COMPILER    = compilerjs;
+            buildInputs = ghcTools;
+            shellHook   = ''
+              ${lolcat}/bin/lolcat ${../figlet}
+              cat ${../intro}
+            '';
+          };
+      }.${build-or-shell};
+in
+  { build = f "build";
+    shell = f "shell";
+  }

client/shared-src/API.hs

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

client/shared-src/Ballot.hs

@@ -0,0 +1,14 @@
+module Ballot where
+
+import GHC.Generics
+import Data.Aeson
+import qualified Control.DeepSeq as DS
+
+type OptionHash = Int
+
+
+-- done as newtype because i'll inevitably add to this
+newtype Ballot = Ballot
+  {
+    votes :: [OptionHash]
+  } deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON, DS.NFData)

client/shared-src/Poll.hs

@@ -0,0 +1,24 @@
+module Poll where
+
+import qualified Ballot as B
+import Data.Aeson
+import qualified Data.Text as T
+import GHC.Generics
+import qualified Control.DeepSeq as DS
+import qualified Data.List.NonEmpty as LN
+
+maximumTextLength :: Int
+maximumTextLength = 280
+
+data Poll = Poll
+  { createInfo :: CreatePollInfo,
+    votes :: [B.Ballot]
+  }
+  deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON, DS.NFData)
+
+data CreatePollInfo = CreatePollInfo
+  { title :: Maybe T.Text,
+    question :: T.Text,
+    options :: LN.NonEmpty T.Text
+  }
+  deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON, DS.NFData)

client/shell.nix

@@ -0,0 +1 @@
+(import ./nix/base.nix).shell

client/src/InProgressPoll.hs

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

client/src/Main.hs

@@ -0,0 +1,89 @@
+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 Data.List as L
+
+headHtml = head_ [link' [rel "stylesheet", type' "text/css", href "https://unpkg.com/papercss@1.8.3/dist/paper.css"]]
+
+view :: Functor m => Model -> Html m Model
+view model = html_ [headHtml,
+  SHtml.body []
+    [ input'
+        [value . IP.title . creatingPoll $ model,
+         onInput (\x model -> model {creatingPoll = IP.modTitle x (creatingPoll model)})
+        ],
+      input'
+        [value . IP.question . creatingPoll $ model,
+         onInput (\x model -> model {creatingPoll = IP.modQuestion x (creatingPoll model)})
+        ],
+      liftedOptions
+    ]]
+  where
+    liftedOptions :: Functor m =>  Html m Model
+    liftedOptions = Sh.liftC modifyModelOptions (IP.options . creatingPoll) optionsHtml'
+
+    optionsHtml' :: 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}}
+
+optionsHtml :: [T.Text] -> Html m [T.Text]
+optionsHtml options = SHtml.div [id' "options"] [inputFields, addOptionButton]
+  where
+    inputFields = SHtml.div [id' "optionInputs"] $ zipWith (\x y -> input' $ doubleton x y) optionsMods values
+
+    addOptionButton = button [id' "addOption", onClick (\xs -> T.empty : xs)] ["add option"]
+
+    optionsMods :: [(T.Text, Prop m [T.Text])]
+    optionsMods = map (onInput . toOnInput) . mods $ options
+
+    values :: [(T.Text, Prop m [T.Text])]
+    values = map value options
+
+    toOnInput fn a _ = fn a
+
+    doubleton x y = [x, y]
+
+mods :: [a] -> [(a -> [a])]
+mods xs = zipWith toModFn (L.inits xs) (init $ L.tails xs)
+  where
+    toModFn :: [a] -> [a] -> a -> [a]
+    toModFn xs (y:ys) newY = xs ++ newY : ys
+
+
+app :: JSM ()
+app = fullPageJSM runSnabbdom (Model startingPoll) view stage
+
+startingPoll :: IP.InProgressPoll
+startingPoll =
+  IP.InProgressPoll
+    { title = "title goes here",
+      question = "question goes here",
+      options = ["option1", "option2"]
+    }
+
+data Model = Model
+  { 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

server/server.cabal

@@ -1,5 +1,5 @@
 cabal-version: 3.0
-name:                rcv-site-server
+name:                server
 version:             0.1.0.0
 category:            Web
 build-type:          Simple
@@ -52,6 +52,7 @@ executable server
     network-uri,
     postgresql-simple,
     servant,
+    deepseq,
     servant-lucid,
     servant-server,
     text,
@@ -70,3 +71,11 @@ executable server
     Poll
     Ballot
     AppM
+  ghc-options:
+    -Wall
+    -Wcompat
+    -fwarn-redundant-constraints
+    -fwarn-incomplete-uni-patterns
+    -fwarn-tabs
+    -fwarn-incomplete-record-updates
+    -fwarn-identities

server/shared-src

@@ -0,0 +1 @@
+../client/shared-src

server/src/AppM.hs

@@ -0,0 +1,13 @@
+module AppM where
+import qualified Control.Monad.Reader as Rd
+import qualified Data.Acid as Ac
+import qualified Database as DB
+import Servant.Server
+
+-- presumably this will become more complex as we need other things in scope
+newtype Env = Env
+  {
+    db :: Ac.AcidState DB.DB
+  }
+
+type AppM = Rd.ReaderT Env Handler

server/src/Error.hs

@@ -0,0 +1,17 @@
+module Error where
+import qualified Data.Text as T
+import Servant.Server.Internal.ServerError
+import Servant
+import AppM
+
+withReason :: ServerError -> T.Text -> ServerError
+withReason err errText = err {errReasonPhrase = T.unpack errText}
+
+badPollId :: T.Text -> AppM a
+badPollId = throwError . withReason err400 . T.append "not a valid id: "
+
+noPollFound :: T.Text -> AppM a
+noPollFound = throwError . withReason err404 . T.append "valid id, no poll with id: "
+
+noVotes :: AppM a
+noVotes = throwError . withReason err400 $ "poll has no votes, or only empty ballots"

server/src/Main.hs

@@ -1,43 +1,39 @@
 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 Ballot as B
+import Control.Concurrent (takeMVar)
 import qualified Control.Concurrent.MVar as MV
+import qualified Control.Monad as CM
+import qualified Control.Monad.Except as Ex
+import Control.Monad.IO.Class (MonadIO (liftIO))
+import qualified Control.Monad.Reader as Rd
+import qualified Data.Acid as Ac
+import Data.Aeson (ToJSON (toJSON), encode)
+import qualified Data.ByteString.Lazy as BS
+import qualified Data.Hashable as H
+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
+import qualified Data.Text.IO as TIO
+import qualified Data.UUID as ID
+import qualified Data.UUID.V4 as IDV
+import qualified Database as DB
+import qualified Error as Er
 import qualified InstantRunoff as IR
 import qualified Network.Wai.Handler.Warp as W
--- import qualified Servant.Server.StaticFiles as SSF
-import qualified Data.Set as S
-import qualified Data.Text.IO as TIO
-import Servant.API
-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 Servant
+
 -- import qualified Miso.Svg as DB
 -- staticDir = "./static"
 
-
 getPollForBallot :: T.Text -> AppM P.CreatePollInfo
 getPollForBallot pollId = do
   db <- Rd.asks db
@@ -63,7 +59,6 @@ getResult pollId = do
   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
@@ -72,7 +67,6 @@ getResult pollId = do
 
     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))