87 lines
2.7 KiB
Haskell
87 lines
2.7 KiB
Haskell
module Main where
|
|
|
|
import qualified API as A
|
|
import AppM
|
|
import qualified Ballot as B
|
|
import Control.Monad.IO.Class (MonadIO (liftIO))
|
|
import qualified Control.Monad.Reader as Rd
|
|
import qualified Data.Acid as Ac
|
|
import qualified Data.Hashable as H
|
|
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 Database as DB
|
|
import qualified Error as Er
|
|
import qualified InstantRunoff as IR
|
|
import qualified Network.Wai.Handler.Warp as W
|
|
import qualified Poll as P
|
|
import Servant
|
|
import Network.Wai.Application.Static (defaultWebAppSettings, StaticSettings (ss404Handler))
|
|
import qualified Network.Wai as W
|
|
import Network.HTTP.Types (status200, hContentType)
|
|
import qualified Data.List.NonEmpty as NE
|
|
|
|
staticFolderLoc = "../client/static"
|
|
|
|
|
|
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
|
|
|
|
-- 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 :: P.PollId -> AppM P.Result
|
|
getResult pollId = do
|
|
db <- Rd.asks db
|
|
poll :: (P.Poll) <- getFromPollId pollId (liftIO . Ac.query db . DB.GetPoll)
|
|
votesList <- throwOrLift Er.noVotes . maybeVotes $ poll
|
|
pure $ P.Result . reverse . IR.solve . NE.map B.votes $ votesList
|
|
where
|
|
-- discarding empty ballots
|
|
maybeVotes :: P.Poll -> Maybe (LN.NonEmpty (B.Ballot))
|
|
maybeVotes = LN.nonEmpty . P.votes
|
|
|
|
mapFromHash :: [T.Text] -> M.Map B.OptionHash T.Text
|
|
mapFromHash = M.fromList . map (\x -> (H.hash x, x))
|
|
|
|
makePoll :: P.CreatePollInfo -> AppM P.PollId
|
|
makePoll pollReq = do
|
|
db <- Rd.asks db
|
|
liftIO $ Ac.update db (DB.CreatePoll pollReq)
|
|
|
|
vote :: P.PollId -> B.Ballot -> AppM ()
|
|
vote pollId ballot = do
|
|
db <- Rd.asks db
|
|
liftIO $ Ac.update db (DB.PostBallot pollId ballot)
|
|
pure ()
|
|
|
|
|
|
server :: ServerT A.RCVAPI AppM
|
|
server = makePoll :<|> getPollForBallot :<|> vote :<|> getResult :<|> serveDirectoryWith ((defaultWebAppSettings "static") {ss404Handler = Just serveIndex})
|
|
|
|
|
|
serveIndex :: Application
|
|
serveIndex _ respond = respond $ W.responseFile status200 [(hContentType, "text/html")] ("static" <> "/index.html") Nothing
|
|
|
|
api :: Proxy A.RCVAPI
|
|
api = Proxy
|
|
|
|
getEnv = Env <$> DB.openLocalDB
|
|
|
|
runWithEnv :: Env -> AppM a -> Handler a
|
|
runWithEnv = flip Rd.runReaderT
|
|
|
|
main :: IO ()
|
|
main = do
|
|
env <- getEnv
|
|
W.run 8080 . serve api . hoistServer api (runWithEnv env) $ server
|