client and sever both exist but don't talk to each other

2023-03-13 20:23:17 -07:00 · 2023-03-13 20:23:17 -07:00 · b3782d5287
commit b3782d5287
parent e6a0c0de72
12 changed files with 196 additions and 5381 deletions
--- a/.gitignore
+++ b/.gitignore
@ -4,3 +4,4 @@
 server/db
 **/elm-stuff
 /client/index.html
+/server/state/
--- a/client/src/Main.elm
+++ b/client/src/Main.elm
@ -1,65 +1,164 @@
 module Main exposing (..)
+
+import Array as A
 import Browser
 import Html exposing (..)
 import Html.Attributes as HA
 import Html.Events as HE
+import List as L
+

 main =
-  Browser.sandbox { init = startPoll, update = update, view = view }
+    Browser.sandbox { init = startPoll, update = update, view = view }
+

 startPoll : Model
-startPoll = Creating (CreatePollInfo { title = Nothing, question = "", options = [] })
+startPoll =
+    Creating (CreatePollInfo { title = Nothing, question = "favorite color?", options = A.fromList [ "blue", "green", "leaf" ] })
+
+

 -- testPoll = CreatePollInfo { title = , question = "what's your favorite color?", options = ["green", "blue", "red"] }

-type Model = Loading | Voting CreatePollInfo | ViewingResults Poll | Creating CreatePollInfo

-type OptionHash = Int
+type Model
+    = Loading
+    | Voting CreatePollInfo
+    | ViewingResults Poll
+    | Creating CreatePollInfo

-type Msg = Increment | Decrement

-type CreatePollInfo = CreatePollInfo
-    {
-        title : Maybe String,
-        question : String,
-        options : List String
-    }
-type Poll = Poll
-    {
-        createInfo : CreatePollInfo,
-        votes : List Ballot
-    }
+type OptionHash
+    = Int

-type Ballot = Ballot
-    {
-        votes : OptionHash
-    }

-update msg model = model
-  -- case msg of
-  --   Increment ->
-  --     model + 1
+type Msg
+    = NewCreatePollInfo CreatePollInfo
+
+
+type CreatePollInfo
+    = CreatePollInfo
+        { title : Maybe String
+        , question : String
+        , options : A.Array String
+        }
+
+
+type Poll
+    = Poll
+        { createInfo : CreatePollInfo
+        , votes : List Ballot
+        }
+
+
+type Ballot
+    = Ballot
+        { votes : OptionHash
+        }
+
+
+update : Msg -> Model -> Model
+update msg model =
+    case msg of
+        NewCreatePollInfo newCreateInfo ->
+            Creating newCreateInfo
+

-  --   Decrement ->
-  --     model - 1
-  --
 viewInput : String -> String -> String -> (String -> msg) -> Html msg
 viewInput t p v toMsg =
-  input [ HA.type_ t, HA.placeholder p, HA.value v-- , HE.onInput toMsg
-        ] []
-
-
-view model = case model of
-    (Creating (CreatePollInfo createInfo )) -> div []
-        [
-         input [HA.type_ "text", HA.value (Maybe.withDefault "" createInfo.title)] []
-         -- input [HA.type_ "text", HA.value (Maybe.withDefault "" createInfo.title)] []
+    input
+        [ HA.type_ t
+        , HA.placeholder p
+        , HA.value v -- , HE.onInput toMsg
        ]
-    Loading -> text "loading..."
-    _ -> text "uhhh"
+        []
+
+
+remove : Int -> A.Array a -> A.Array a
+remove n arr =
+    A.append (A.slice 0 n arr) (A.slice (n + 1) (A.length arr) arr)
+
+
+
+-- remove : Int -> List a -> List a
+-- remove 0 (_ :: xs) = xs
+-- remove n (x :: xs) = x :: remove (n - 1) xs
+-- remove _ [] = []
+-- set : Int -> a -> List a -> (List a)
+-- set 0 newElem (_ :: xs) = newElem :: xs
+-- set n newElem (x :: xs) = x :: set (n - 1) newElem xs
+-- set _ _ [] = Nothing
+
+
+inputWithLabel name attributes =
+    [ label [ HA.for name ] [ text name ]
+    , input (HA.name name :: attributes) []
+    ]
+
+
+view model =
+    case model of
+        Creating (CreatePollInfo createInfo) ->
+            let
+                toOption index option =
+                    [ input
+                        [ HA.type_ "text"
+                        , HA.value option
+                        , HE.onInput (\new -> NewCreatePollInfo (CreatePollInfo { createInfo | options = A.set index new createInfo.options }))
+                        ]
+                        []
+                    , button
+                        [ HE.onClick (NewCreatePollInfo (CreatePollInfo { createInfo | options = remove index createInfo.options })), HA.class "btn-warning-outline" ]
+                        [ text "remove" ]
+                    ]
+            in
+            div
+                [ HA.style "display" "flex", HA.style "justify-content" "center" ]
+            <|
+                L.singleton <|
+                    div
+                        [ HA.style "display" "flex", HA.style "flex-direction" "column", HA.style "max-width" "400px" ]
+                    <|
+                        L.concat <|
+                            [ inputWithLabel "title"
+                                [ HA.type_ "text"
+                                , HA.value (Maybe.withDefault "" createInfo.title)
+                                , HE.onInput (\change -> NewCreatePollInfo (CreatePollInfo { createInfo | title = Just change }))
+                                ]
+                            , inputWithLabel "question"
+                                [ HA.type_ "text"
+                                , HA.value createInfo.question
+                                , HE.onInput (\change -> NewCreatePollInfo (CreatePollInfo { createInfo | question = change }))
+                                ]
+                            , L.singleton <|
+                                div [ HA.style "display" "flex", HA.style "flex-direction" "column" ]
+                                    [ text "options"
+                                    , div
+                                        [ HA.style "display" "grid", HA.style "grid-template-columns" "auto 80px" ]
+                                      <|
+                                        L.concat <|
+                                            A.toList <|
+                                                A.indexedMap toOption createInfo.options
+                                    , button
+                                        [ HA.style "align-self" "start"
+                                        , HA.class "paper-btn btn-primary-outline"
+                                        , HE.onClick (NewCreatePollInfo (CreatePollInfo { createInfo | options = A.push "" createInfo.options }))
+                                        ]
+                                        [ text "add new option" ]
+                                    ]
+                            ]
+
+        Loading ->
+            text "loading..."
+
+        _ ->
+            text "uhhh"
+
+
+
 -- view (CreatePollInfo {options}) =
 --   div [HA.style "display" "flex", HA.style "flex-direction" "column", HA.style "max-width" "300px"]
--       (List.map (button [] << List.singleton << text) options)
+--       (L.map (button [] << L.singleton << text) options)
 --     -- [ div [] [ text (text model.tile) ]
 --     -- , div [] [ text (String.fromInt model) ]
 --     -- , button [ onClick Increment ] [ text "+" ]
--- a/client/src/index.html
+++ b/client/src/index.html
--- a/server/API.hs
+++ b/server/API.hs
@ -1,15 +0,0 @@
-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
--- a/server/rcv-site.cabal
+++ b/server/rcv-site.cabal
@ -34,29 +34,24 @@ executable server
    TypeSynonymInstances,
    UndecidableInstances,
  hs-source-dirs:
-    src,
-    shared-src
+    src
  build-depends:
    aeson,
    uuid,
    base,
    acid-state,
    safecopy,
+    random,
+    splitmix,
    containers,
    blaze-html,
    http-types,
-    -- lucid,
-    -- servant-lucid,
-    -- servant-blaze,
-    -- miso,
    bytestring,
    hashable,
    mtl,
    network-uri,
-    -- postgresql-simple,
    servant,
    deepseq,
-    -- servant-lucid,
    servant-server,
    text,
    vector,
--- a/server/src/API.hs
+++ b/server/src/API.hs
@ -10,7 +10,8 @@ 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
+  "poll" :> "create" :> ReqBody '[JSON] P.CreatePollInfo :> Post '[JSON] P.PollId
+  :<|> "poll" :> Capture "pollId" P.PollId :> "vote" :> Get '[JSON] P.CreatePollInfo
+  :<|> "poll" :> Capture "pollId" P.PollId :> "vote" :> ReqBody '[JSON] B.Ballot :> Post '[JSON] ()
+  :<|> "poll" :> Capture "pollId" P.PollId :> "result" :> Get '[JSON] PollResult
+  :<|> "static" :> Raw
--- a/server/src/AppM.hs
+++ b/server/src/AppM.hs
@ -1,8 +1,8 @@
 module AppM where
 import qualified Control.Monad.Reader as Rd
-import qualified Data.Acid as Ac
 import qualified Database as DB
 import Servant.Server
+import qualified Data.Acid as Ac

 -- presumably this will become more complex as we need other things in scope
 newtype Env = Env
--- a/server/src/Ballot.hs
+++ b/server/src/Ballot.hs
@ -3,10 +3,10 @@ module Ballot where
 import GHC.Generics
 import Data.Aeson
 import qualified Control.DeepSeq as DS
+import qualified Data.Text as T

 type OptionHash = Int

-
 -- done as newtype because i'll inevitably add to this
 newtype Ballot = Ballot
  {
--- a/server/src/Database.hs
+++ b/server/src/Database.hs
@ -1,36 +1,30 @@
-{-#LANGUAGE TemplateHaskell#-}
 module Database where

-import GHC.Generics (Generic)
 import qualified Data.Acid as Ac
 import qualified Data.Map.Strict as M
-import qualified Data.Text as T
-import qualified Data.UUID as ID
-import qualified Data.UUID.V4 as IDV
 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 Data.Hashable as H
-import qualified Data.ByteString as BS
-import qualified API as A
-import qualified Data.List.NonEmpty as LN
 import qualified Poll as P
 import qualified Ballot as B
+import qualified System.Random as R
+import qualified System.Random.SplitMix as SM

-newtype DB = DB {
-  polls :: M.Map ID.UUID P.Poll
+data DB = DB {
+  gen :: R.StdGen,
+  polls :: M.Map P.PollId P.Poll
                } deriving (Show, Ty.Typeable)

-
-deriving instance Ty.Typeable ID.UUID
 deriving instance Ty.Typeable P.Poll
 deriving instance Ty.Typeable B.Ballot

-createPoll :: ID.UUID -> P.CreatePollInfo  -> Ac.Update DB ()
-createPoll uuid createInfo = MS.modify $ go uuid
+createPoll :: MS.MonadState DB m => P.CreatePollInfo -> m P.PollId
+createPoll createInfo = MS.state go
  where
-    go uuid DB {..} = DB {polls = M.insert uuid insertedPoll polls, ..}
+    go DB {..} = (pollId, DB {polls = M.insert pollId insertedPoll polls, gen = gen'})
+      where
+        (pollId, gen') = R.genWord64 gen

    insertedPoll = P.Poll
      {
@ -38,28 +32,28 @@ createPoll uuid createInfo = MS.modify $ go uuid
        votes = []
      }

-getPollForBallot :: ID.UUID -> Ac.Query DB (Maybe P.CreatePollInfo)
+getPollForBallot :: P.PollId -> Ac.Query DB (Maybe P.CreatePollInfo)
 getPollForBallot pollId = MR.asks (fmap P.createInfo . M.lookup pollId . polls)

-getPoll :: ID.UUID -> Ac.Query DB (Maybe P.Poll)
+getPoll :: P.PollId -> Ac.Query DB (Maybe P.Poll)
 getPoll pollId = MR.asks $ M.lookup pollId . polls

-postBallot :: ID.UUID -> B.Ballot -> Ac.Update DB ()
+postBallot :: P.PollId -> B.Ballot -> Ac.Update DB ()
 postBallot pollId ballot = MS.modify go
  where
-    go DB{..} = DB {polls  = M.adjust prependVote pollId polls}
+    go DB{..} = DB {polls  = M.adjust prependVote pollId polls, ..}
      where
        prependVote P.Poll{..} = P.Poll {votes = ballot : votes, ..}

-$(SC.deriveSafeCopy 0 'SC.base ''ID.UUID)
 $(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 ''SM.SMGen)
+$(SC.deriveSafeCopy 0 'SC.base ''R.StdGen)
 $(SC.deriveSafeCopy 0 'SC.base ''DB)
-
 Ac.makeAcidic ''DB['createPoll, 'getPollForBallot, 'getPoll, 'postBallot]

 openLocalDB :: IO (Ac.AcidState DB)
-openLocalDB = Ac.openLocalState $ DB M.empty
-
-
+openLocalDB = do
+  gen <- R.getStdGen
+  Ac.openLocalState $ DB gen M.empty
--- a/server/src/Error.hs
+++ b/server/src/Error.hs
@ -3,15 +3,16 @@ import qualified Data.Text as T
 import Servant.Server.Internal.ServerError
 import Servant
 import AppM
+import qualified Poll as P

 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: "
+badPollId :: P.PollId -> AppM a
+badPollId = throwError . withReason err400 . T.append "not a valid id: " . T.pack . show

-noPollFound :: T.Text -> AppM a
-noPollFound = throwError . withReason err404 . T.append "valid id, no poll with id: "
+noPollFound :: P.PollId -> AppM a
+noPollFound = throwError . withReason err404 . T.append "invalid id, no poll with id: " . T.pack . show

 noVotes :: AppM a
 noVotes = throwError . withReason err400 $ "poll has no votes, or only empty ballots"
--- a/server/src/Main.hs
+++ b/server/src/Main.hs
@ -13,16 +13,11 @@ 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 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
@ -30,31 +25,26 @@ import qualified Network.Wai.Handler.Warp as W
 import qualified Poll as P
 import Servant

-- import qualified Miso.Svg as DB
-- staticDir = "./static"
+staticFolderLoc = "../client/static"

-getPollForBallot :: T.Text -> AppM P.CreatePollInfo
+getPollForBallot :: P.PollId -> AppM P.CreatePollInfo
 getPollForBallot pollId = do
  db <- Rd.asks db
-  getFromUuid pollId (liftIO . Ac.query db . DB.GetPollForBallot)
+  getFromPollId pollId (liftIO . Ac.query db . DB.GetPollForBallot)

 throwOrLift :: AppM a -> Maybe a -> AppM a
 throwOrLift err = My.maybe err pure

-toUuid pollId = maybe (Er.badPollId pollId) pure . ID.fromText $ pollId
-
-- I didn't want to grab the whole poll (with votes) from the database so instead I pass a function
-- realistically, this function one of liftIO . Ac.query db . DB.GetPoll/DB.GetPollForBallot
-getFromUuid :: T.Text -> (ID.UUID -> AppM (Maybe a)) -> AppM a
-getFromUuid pollId query = do
-  pollUuid <- toUuid pollId
-  pollResult <- query pollUuid
+-- I didn't want to grab the whole poll (with votes) from the database so instead I pass a function.
+getFromPollId :: P.PollId -> (P.PollId -> AppM (Maybe a)) -> AppM a
+getFromPollId pollId query = do
+  pollResult <- query pollId
  throwOrLift (Er.noPollFound pollId) pollResult

-getResult :: T.Text -> AppM A.PollResult
+getResult :: P.PollId -> AppM A.PollResult
 getResult pollId = do
  db <- Rd.asks db
-  poll <- getFromUuid pollId $ liftIO . Ac.query db . DB.GetPoll
+  poll <- getFromPollId pollId $ liftIO . Ac.query db . DB.GetPoll
  votesList <- throwOrLift Er.noVotes $ maybeVotes poll
  pure $ solveAndUnHash poll votesList
  where
@ -69,22 +59,19 @@ getResult pollId = do
 mapFromHash :: [T.Text] -> M.Map B.OptionHash T.Text
 mapFromHash = M.fromList . map (\x -> (H.hash x, x))

-makePoll :: P.CreatePollInfo -> AppM T.Text
+makePoll :: P.CreatePollInfo -> AppM P.PollId
 makePoll pollReq = do
  db <- Rd.asks db
-  newId <- liftIO IDV.nextRandom
-  liftIO $ Ac.update db (DB.CreatePoll newId pollReq)
-  pure $ ID.toText newId
+  liftIO $ Ac.update db (DB.CreatePoll pollReq)

-vote :: T.Text -> B.Ballot -> AppM ()
+vote :: P.PollId -> B.Ballot -> AppM ()
 vote pollId ballot = do
  db <- Rd.asks db
-  uuid <- toUuid pollId
-  liftIO $ Ac.update db (DB.PostBallot uuid ballot)
+  liftIO $ Ac.update db (DB.PostBallot pollId ballot)
  pure ()

 server :: ServerT A.RCVAPI AppM
-server = makePoll :<|> getPollForBallot :<|> vote :<|> getResult
+server = makePoll :<|> getPollForBallot :<|> vote :<|> getResult :<|> serveDirectoryWebApp staticFolderLoc

 api :: Proxy A.RCVAPI
 api = Proxy
@ -94,8 +81,7 @@ getEnv = Env <$> DB.openLocalDB
 runWithEnv :: Env -> AppM a -> Handler a
 runWithEnv = flip Rd.runReaderT

-- main :: IO ()
+main :: IO ()
 main = do
-  BS.putStr $ encode . toJSON $ P.CreatePollInfo (Just "hello") "sup" ["option 1"]
  env <- getEnv
-  W.run 8080 $ serve api $ hoistServer api (runWithEnv env) server
+  W.run 8080 . serve api . hoistServer api (runWithEnv env) $ server
--- a/server/src/Poll.hs
+++ b/server/src/Poll.hs
@ -6,18 +6,23 @@ import qualified Data.Text as T
 import GHC.Generics
 import qualified Control.DeepSeq as DS
 import qualified Data.List.NonEmpty as LN
+import Data.Word

 maximumTextLength :: Int
 maximumTextLength = 280

+type PollId = Word64
+
 data Poll = Poll
-  { createInfo :: CreatePollInfo,
+  {
+    createInfo :: CreatePollInfo,
    votes :: [B.Ballot]
  }
  deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON, DS.NFData)

 data CreatePollInfo = CreatePollInfo
-  { title :: Maybe T.Text,
+  {
+    title :: Maybe T.Text,
    question :: T.Text,
    options :: LN.NonEmpty T.Text
  }