pesky changing ids bug squashed & added js libraries

Now that the bug is squashed, I no longer need to pin acid-state to a
specific version (I previously thought it was a bad version, it was
actually storing the StdGen in the DB). Also you can now get a
ballot (though not submit it).

public/static/script.js

@@ -0,0 +1,10 @@
+htmx.onLoad(function(content) {
+    var sortables = content.querySelectorAll(".sortable");
+    for (var i = 0; i < sortables.length; i++) {
+      var sortable = sortables[i];
+      new Sortable(sortable, {
+          animation: 150,
+          ghostClass: 'blue-background-class'
+      });
+    }
+})

public/static/style.css

@@ -5,7 +5,7 @@ body
     align-items: center;
 }
 
-#inputs, #options-create
+#inputs, .options
 {
     display: flex;
     flex-direction: column;
@@ -13,13 +13,19 @@ body
     gap: 10px;
 }
 
+.options
+{
+    padding: 10px
+}
+
 #permenant-input
 {
     display: flex;
     flex-direction: column;
 }
 
-#options-create > * {
+.options > * {
   flex-direction: row;
   display: flex;
+  background-color: white;
 }

rcv-site.cabal

@@ -37,7 +37,7 @@ executable server
   hs-source-dirs:
     src
   build-depends:
-    acid-state == 0.16.1.2,
+    acid-state,
     aeson,
     base,
     bytestring,

src/API.hs

@@ -11,7 +11,7 @@ type RCVAPI =
   :<|> "create" :> ReqBody '[JSON] P.CreatePollInfo :> Post '[SL.HTML] (L.Html ())
   :<|> "create" :> "newInput" :> Get '[SL.HTML] (L.Html ())
   :<|> "create" :> "removeInput" :> Get '[SL.HTML] (L.Html ())
-  -- :<|> "api" :> "poll" :> Capture "pollId" P.PollId :> "vote" :> Get '[JSON] P.CreatePollInfo
+  :<|> "poll" :> Capture "pollId" P.PollId :> Get '[SL.HTML] (L.Html ())
   -- :<|> "api" :> "poll" :> Capture "pollId" P.PollId :> "vote" :> ReqBody '[JSON] B.Ballot :> Post '[JSON] ()
   -- :<|> "api" :> "poll" :> Capture "pollId" P.PollId :> "results" :> Get '[JSON] P.Result
   :<|> StaticAPI

src/AppM.hs

@@ -3,11 +3,15 @@ import qualified Control.Monad.Reader as Rd
 import qualified Database as DB
 import Servant.Server
 import qualified Data.Acid as Ac
+import qualified Data.Text as T
+import qualified System.Random.Stateful as R
 
 -- presumably this will become more complex as we need other things in scope
-newtype Env = Env
+data Env = Env
   {
-    db :: Ac.AcidState DB.DB
+    db :: Ac.AcidState DB.DB,
+    script :: T.Text,
+    gen :: R.AtomicGenM R.StdGen
   }
 
 type AppM = Rd.ReaderT Env Handler

src/Database.hs

@@ -2,31 +2,24 @@ module Database where
 
 import qualified Data.Acid as Ac
 import qualified Data.Map.Strict as M
-import qualified Data.Set as S
 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 Poll as P
 import qualified Ballot as B
-import qualified System.Random as R
-import qualified System.Random.SplitMix as SM
-import qualified Data.Bifunctor as Bi
 
 data DB = DB {
-  gen :: R.StdGen,
   polls :: M.Map P.PollId P.Poll
                 } deriving (Show, Ty.Typeable)
 
 deriving instance Ty.Typeable P.Poll
 deriving instance Ty.Typeable B.Ballot
 
-createPoll :: MS.MonadState DB m => P.CreatePollInfo -> m P.PollId
-createPoll createInfo = MS.state go
+createPoll :: MS.MonadState DB m => P.CreatePollInfo -> P.PollId -> m ()
+createPoll createInfo pollId = MS.modify go
   where
-    go DB {..} = (pollId, DB {polls = M.insert pollId insertedPoll polls, gen = gen'})
-      where
-        (pollId, gen') = Bi.first P.PollId . R.genWord32 $ gen
+    go DB {..} = DB {polls = M.insert pollId insertedPoll polls}
 
     insertedPoll = P.Poll
       {
@@ -57,12 +50,9 @@ $(SC.deriveSafeCopy 0 'SC.base ''P.CreatePollInfo)
 $(SC.deriveSafeCopy 0 'SC.base ''B.Ballot)
 $(SC.deriveSafeCopy 0 'SC.base ''P.Poll)
 $(SC.deriveSafeCopy 0 'SC.base ''P.PollId)
-$(SC.deriveSafeCopy 0 'SC.base ''SM.SMGen)
-$(SC.deriveSafeCopy 0 'SC.base ''R.StdGen)
 $(SC.deriveSafeCopy 0 'SC.base ''DB)
 Ac.makeAcidic ''DB['createPoll, 'getPollForBallot, 'getPoll, 'postBallot, 'getPollIds, 'getDB]
 
 openLocalDB :: IO (Ac.AcidState DB)
 openLocalDB = do
-  gen <- R.getStdGen
-  Ac.openLocalStateFrom "state" $ DB gen M.empty
+  Ac.openLocalStateFrom "./state" $ DB  M.empty

src/Main.hs

@@ -16,22 +16,17 @@ import qualified Data.List.NonEmpty as LN
 import qualified Data.List.NonEmpty as NE
 import qualified Data.Map.Strict as M
 import qualified Data.Maybe as My
-import qualified Data.Set as S
-import Lucid.Htmx as L
 import qualified Data.Text as T
 import qualified Database as DB
 import qualified Error as Er
 import qualified InstantRunoff as IR
-import qualified Network.Wai as W
 import qualified Network.Wai.Handler.Warp as W
 import qualified Network.Wai.Handler.WarpTLS as WTLS
 import qualified Poll as P
 import qualified System.Environment as S
+import qualified Data.Text.IO as TIO
+import qualified System.Random.Stateful as R
 
-getPollForBallot :: P.PollId -> AppM P.CreatePollInfo
-getPollForBallot pollId = do
-  db <- Rd.asks db
-  getFromPollId pollId (liftIO . Ac.query db . DB.GetPollForBallot)
 
 throwOrLift :: AppM a -> Maybe a -> AppM a
 throwOrLift err = My.maybe err pure
@@ -59,13 +54,14 @@ mapFromHash = M.fromList . map (\x -> (H.hash x, x))
 makePoll :: P.CreatePollInfo -> AppM (L.Html ())
 makePoll pollReq = do
   db <- Rd.asks db
-  (P.PollId pollId) <- liftIO $ Ac.update db (DB.CreatePoll pollReq)
+  gen <- Rd.asks gen
+  pollId <- P.PollId <$> R.uniformWord64 gen
+  liftIO $ Ac.update db (DB.CreatePoll pollReq pollId)
   let fillOutLink = T.append "https://rankedchoice.net/poll/" (T.pack . show $ pollId)
   pure $ do
     "done! people can fill out your poll at "
     with a_ [href_ fillOutLink] (toHtml fillOutLink)
 
-
 vote :: P.PollId -> B.Ballot -> AppM ()
 vote pollId ballot = do
   db <- Rd.asks db
@@ -73,30 +69,63 @@ vote pollId ballot = do
   pure ()
 
 server :: ServerT A.RCVAPI AppM
-server = createPage :<|> makePoll :<|> pure optionInput :<|> (pure . pure $ ()) :<|> serveDirectoryWith ((defaultWebAppSettings "public"))
+server = createPage
+  :<|> makePoll
+  :<|> pure optionInput
+  :<|> (pure . pure $ ())
+  :<|> getPollForBallot
+  :<|> serveDirectoryWith ((defaultWebAppSettings "public"))
 
-pageHead :: L.Html ()
-pageHead = head_ $ do
+
+
+getPollForBallot :: P.PollId -> AppM (L.Html ())
+getPollForBallot pollId = do
+  db <- Rd.asks db
+  createInfo <- getFromPollId pollId (liftIO . Ac.query db . DB.GetPollForBallot)
+  fullPage $ do
+      My.maybe (pure ()) (h3_ . toHtml) (P.title createInfo)
+      h3_ . toHtml . P.question $ createInfo
+      with form_  [hxPost_ ""] $ do
+        with div_ [classes_ ["sortable", "options", "child-borders", "border-primary", "background-primary"]] . mconcat . map toFormInput . LN.toList . P.options $ createInfo
+        input_ [type_ "submit", classes_ ["paper-btn", "btn-primary"], value_ "submit"]
+  where
+    toFormInput :: T.Text -> L.Html ()
+    toFormInput option = with div_ [classes_ []] $ input_ [type_ "hidden", value_ option, name_ "options"] <> toHtml option
+
+fullPage rest = do
+  customHead <- pageHead
+  pure $ doctypehtml_ $ do
+    customHead
+    pageBody rest
+
+pageHead :: AppM (L.Html ())
+pageHead = do
+  script <- Rd.asks script
+  pure . head_ $ do
     link_ [href_ "/static/style.css", rel_ "stylesheet"]
     link_ [href_ "/static/paper.min.css", rel_ "stylesheet"]
     link_ [href_ "/static/fonts.css", rel_ "stylesheet"]
+    with (script_ "") [src_ "/static/Sortable.min.js"]
     with (script_ "") [src_ "/static/htmx.min.js"]
     with (script_ "") [src_ "/static/json-enc.js"]
+    script_ script
+
+pageBody :: L.Html () -> L.Html ()
+pageBody = with body_ [classes_ ["container", "container-sm", "paper"], hxExt_ "json-enc"]
 
 optionInput :: L.Html ()
 optionInput = div_ $
   input_ [required_ "true", name_ "options", maxlength_ "100"] <>
-  with button_ [classes_ ["btn", "btn-warning-outline"], hxGet_ "create/removeInput", hxSwap_ "delete", hxTarget_ "closest #options-create > *"] "remove"
+  with button_ [classes_ ["btn", "btn-warning-outline"], hxGet_ "create/removeInput", hxSwap_ "delete", hxTarget_ "closest .options > *"] "remove"
 
 createPage :: AppM (L.Html ())
-createPage = pure $ do
-  pageHead
-  with body_ [classes_ ["container", "container-sm", "paper"], hxExt_ "json-enc"] $ do
+createPage = do
+  fullPage $ do
     h2_ "create a poll"
     with form_ [id_ "inputs", hxPost_ "/create", hxTarget_ "body"] $ do
       with label_ [for_ "title"] "title (optional)" <> input_ [name_ "title", type_ "text", maxlength_ "100"]
       with label_ [for_ "question"] "question" <> input_ [name_ "question", type_ "text", required_ "true", maxlength_ "100"]
-      with fieldset_ [name_ "options", id_ "options-create"] $ do
+      with fieldset_ [name_ "options", class_ "options"] $ do
         legend_ "options"
         optionInput
         optionInput
@@ -106,18 +135,37 @@ createPage = pure $ do
 api :: Proxy A.RCVAPI
 api = Proxy
 
-getEnv = Env <$> DB.openLocalDB
+getEnv :: IO Env
+getEnv = do
+ db <- DB.openLocalDB
+ script <- TIO.readFile "public/static/script.js"
+ let gen = R.globalStdGen
+ pure $ Env {..}
 
 runWithEnv :: Env -> AppM a -> Handler a
 runWithEnv = flip Rd.runReaderT
 
+tlsSettings :: WTLS.TLSSettings
 tlsSettings = WTLS.tlsSettings "/etc/letsencrypt/live/rankedchoice.net/cert.pem" "/etc/letsencrypt/live/rankedchoice.net/privkey.pem"
+
+warpSettings :: W.Settings
 warpSettings = W.setPort 443 W.defaultSettings
 
+examplePoll = P.CreatePollInfo {
+  title = Nothing,
+  question = "what's your favorite color?",
+  options = "red" LN.:| ["blue", "green", "yellow"]
+                     }
+
 main :: IO ()
 main = do
   env <- getEnv
   opts <- S.getArgs
+  -- let gen = R.globalStdGen
+  -- pollId <- P.PollId <$> R.uniformWord64 gen
+  -- _ <- liftIO $ Ac.update (db env) (DB.CreatePoll examplePoll (pollId))
+  pollids <- liftIO . Ac.query (db env) $ DB.GetPollIds
+  print pollids
   let application = serve api . hoistServer api (runWithEnv env) $ server
   case opts of
     ["--with-tls"] -> WTLS.runTLS tlsSettings warpSettings application

src/Poll.hs

@@ -20,7 +20,7 @@ newtype Result = Result
   }
   deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON, DS.NFData)
 
-newtype PollId = PollId Word32 deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON, DS.NFData)
+newtype PollId = PollId Word64 deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON, DS.NFData)
 
 instance FromHttpApiData PollId where
   parseUrlPiece = Bi.second PollId . parseUrlPiece