├── cabal.project ├── app └── Main.hs ├── shell.nix ├── src ├── Hp │ ├── Subscription.hs │ ├── IsEntity.hs │ ├── GitHub │ │ ├── Code.hs │ │ ├── ClientId.hs │ │ ├── User.hs │ │ ├── ErrorResponse.hs │ │ ├── ClientSecret.hs │ │ ├── PostLoginOauthAccessTokenResponse.hs │ │ ├── AccessToken.hs │ │ ├── Response.hs │ │ ├── UserName.hs │ │ └── API.hs │ ├── Event │ │ ├── PollCreated.hs │ │ └── PollAnswered.hs │ ├── Handler │ │ ├── GetMetrics.hs │ │ ├── GetRoot.hs │ │ ├── GetUserProfile.hs │ │ ├── Subscribe.hs │ │ ├── GetPoll.hs │ │ ├── GitHubOauthCallback.hs │ │ ├── CreatePoll.hs │ │ └── AnswerPoll.hs │ ├── Eff │ │ ├── SendEmail │ │ │ ├── Noop.hs │ │ │ └── AmazonSES.hs │ │ ├── GitHubAuth │ │ │ ├── AlwaysFail.hs │ │ │ └── Http.hs │ │ ├── Log.hs │ │ ├── Await.hs │ │ ├── SendEmail.hs │ │ ├── Yield.hs │ │ ├── GetCurrentTime.hs │ │ ├── GitHubAuth.hs │ │ ├── Log │ │ │ └── Stdout.hs │ │ ├── Yield │ │ │ ├── Print.hs │ │ │ └── Chan.hs │ │ ├── FirstOrder.hs │ │ ├── HttpSession.hs │ │ ├── Await │ │ │ └── Chan.hs │ │ ├── PersistPoll.hs │ │ ├── Throw.hs │ │ ├── HttpSession │ │ │ └── IO.hs │ │ ├── PersistPollAnswer.hs │ │ ├── DB.hs │ │ ├── PersistUser.hs │ │ ├── Catch.hs │ │ ├── HttpRequest.hs │ │ ├── HttpRequest │ │ │ └── IO.hs │ │ ├── PersistPoll │ │ │ └── DB.hs │ │ ├── PersistPollAnswer │ │ │ └── DB.hs │ │ └── PersistUser │ │ │ └── DB.hs │ ├── RequestBody │ │ ├── Subscribe.hs │ │ ├── AnswerPoll.hs │ │ └── CreatePoll.hs │ ├── UserProfile.hs │ ├── Entity.hs │ ├── Worker │ │ ├── SendEmail.hs │ │ └── SendPollCreatedEmail.hs │ ├── Metrics.hs │ ├── Hasql.hs │ ├── Email.hs │ ├── PostgresConfig.hs │ ├── ResponseBody │ │ └── GetPoll.hs │ ├── Entity │ │ ├── PollAnswer.hs │ │ ├── User.hs │ │ └── Poll.hs │ ├── PollQuestion.hs │ ├── TBroadcastChan.hs │ ├── PollQuestionAnswer.hs │ ├── API.hs │ ├── GitHub.hs │ ├── PollFormElement.hs │ ├── Config.hs │ └── Main.hs └── Prelude.hs ├── default.nix ├── make ├── nix ├── README.org ├── haskell-overlay.nix ├── world.nix ├── pkgs │ ├── hasql-pool.nix │ ├── fused-effects.nix │ └── hasql-cursor-query.nix ├── haskell-overrides.nix └── docker.nix ├── etc ├── prometheus.dhall └── config.dhall ├── .gitignore ├── frontend ├── src │ ├── App │ │ ├── Effect │ │ │ └── Navigate.purs │ │ ├── AppM.purs │ │ └── Prelude.purs │ ├── Data │ │ └── Route.purs │ ├── Main.purs │ └── Component │ │ └── Router.purs ├── static │ └── index.html ├── README.org ├── bower.json └── nginx.nix ├── README.md ├── docker-compose.dhall ├── .stylish-haskell.yaml ├── db └── schema.sql └── hspolls.cabal /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified Hp.Main 4 | 5 | main :: IO () 6 | main = 7 | Hp.Main.main 8 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | (import ./default.nix {}).ghc.shellFor 2 | { 3 | withHoogle = true; 4 | packages = hpkgs: with hpkgs; [ hspolls ]; 5 | } 6 | -------------------------------------------------------------------------------- /src/Hp/Subscription.hs: -------------------------------------------------------------------------------- 1 | module Hp.Subscription 2 | ( Subscription(..) 3 | ) where 4 | 5 | data Subscription 6 | = Subscription 7 | { pollCreated :: Bool 8 | } deriving stock (Generic) 9 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { compiler ? "ghc864" }: 2 | 3 | let pkgs = (import ./nix/world.nix { inherit compiler; }).pkgs; 4 | ghc = pkgs.haskell.packages."${compiler}"; 5 | in 6 | { 7 | ghc = ghc; 8 | } 9 | -------------------------------------------------------------------------------- /src/Hp/IsEntity.hs: -------------------------------------------------------------------------------- 1 | module Hp.IsEntity 2 | ( IsEntity(..) 3 | ) where 4 | 5 | -- | The class of types with a persistent identity. 6 | class IsEntity (a :: Type) where 7 | data EntityId a :: Type 8 | -------------------------------------------------------------------------------- /make: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # Crappy "makefile", replace with shake in due time... 4 | 5 | set -ex 6 | 7 | dhall-to-yaml --explain <<< ./docker-compose.dhall > ./docker-compose.yaml 8 | dhall-to-yaml --explain <<< ./etc/prometheus.dhall > ./etc/prometheus.yaml 9 | -------------------------------------------------------------------------------- /src/Hp/GitHub/Code.hs: -------------------------------------------------------------------------------- 1 | module Hp.GitHub.Code 2 | ( GitHubCode(..) 3 | ) where 4 | 5 | import Web.HttpApiData 6 | 7 | 8 | newtype GitHubCode 9 | = GitHubCode { unGitHubCode :: Text } 10 | deriving newtype (FromHttpApiData, ToHttpApiData) 11 | -------------------------------------------------------------------------------- /src/Hp/GitHub/ClientId.hs: -------------------------------------------------------------------------------- 1 | module Hp.GitHub.ClientId 2 | ( GitHubClientId(..) 3 | ) where 4 | 5 | import Web.HttpApiData 6 | 7 | 8 | newtype GitHubClientId 9 | = GitHubClientId { unGitHubClientId :: Text } 10 | deriving newtype (Show, ToHttpApiData) 11 | -------------------------------------------------------------------------------- /nix/README.org: -------------------------------------------------------------------------------- 1 | ** Building a postgresql docker image for development: 2 | 3 | #+begin_src bash 4 | nix-build -A postgres.dev ./docker.nix 5 | # now we can load the image 6 | cat ./result | docker load 7 | # and we can run the image 8 | docker run --rm -it -p 5432:5432 postgres:dev 9 | #+end_src 10 | -------------------------------------------------------------------------------- /etc/prometheus.dhall: -------------------------------------------------------------------------------- 1 | { global = 2 | { scrape_interval = "15s" 3 | } 4 | 5 | , scrape_configs = 6 | [ { job_name = "hspolls" 7 | , static_configs = 8 | [ { targets = 9 | [ "localhost:8000" 10 | ] 11 | } 12 | ] 13 | } 14 | ] 15 | } 16 | -------------------------------------------------------------------------------- /src/Hp/Event/PollCreated.hs: -------------------------------------------------------------------------------- 1 | module Hp.Event.PollCreated 2 | ( PollCreatedEvent(..) 3 | ) where 4 | 5 | import Hp.Entity (Entity) 6 | import Hp.Entity.Poll (Poll) 7 | 8 | 9 | -- | A poll was created. 10 | data PollCreatedEvent 11 | = PollCreatedEvent 12 | { poll :: Entity Poll 13 | } deriving stock (Generic, Show) 14 | -------------------------------------------------------------------------------- /src/Hp/GitHub/User.hs: -------------------------------------------------------------------------------- 1 | module Hp.GitHub.User 2 | ( GitHubUser(..) 3 | ) where 4 | 5 | import Hp.GitHub.UserName 6 | 7 | import Data.Aeson (FromJSON) 8 | 9 | 10 | data GitHubUser 11 | = GitHubUser 12 | { email :: Maybe Text 13 | , login :: GitHubUserName 14 | } deriving stock (Generic, Show) 15 | deriving anyclass (FromJSON) 16 | -------------------------------------------------------------------------------- /src/Hp/Handler/GetMetrics.hs: -------------------------------------------------------------------------------- 1 | module Hp.Handler.GetMetrics 2 | ( handleGetMetrics 3 | ) where 4 | 5 | import Control.Effect 6 | import Prometheus 7 | 8 | 9 | handleGetMetrics :: 10 | ( Carrier sig m 11 | , MonadIO m 12 | ) 13 | => m Text 14 | handleGetMetrics = do 15 | bytes <- exportMetricsAsText 16 | pure (bytes ^?! strict . utf8) 17 | -------------------------------------------------------------------------------- /src/Hp/Event/PollAnswered.hs: -------------------------------------------------------------------------------- 1 | module Hp.Event.PollAnswered 2 | ( PollAnsweredEvent(..) 3 | ) where 4 | 5 | import Hp.Entity (Entity) 6 | import Hp.Entity.PollAnswer (PollAnswer) 7 | 8 | 9 | -- | A poll was answered. 10 | newtype PollAnsweredEvent 11 | = PollAnsweredEvent 12 | { answer :: Entity PollAnswer 13 | } deriving stock (Generic, Show) 14 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .ghc.environment.* 2 | .ghci 3 | .ghcid 4 | 5 | # cabal build dirs 6 | dist/ 7 | dist-newstyle/ 8 | 9 | # Secrets 10 | etc/aws.dhall 11 | etc/github.dhall 12 | 13 | # Generated by dhall files (./make) 14 | etc/prometheus.yaml 15 | docker-compose.yaml 16 | 17 | **/*/app.js 18 | **/*/bower_components 19 | **/*/node_modules 20 | **/*/output 21 | **/*/result 22 | -------------------------------------------------------------------------------- /src/Hp/Eff/SendEmail/Noop.hs: -------------------------------------------------------------------------------- 1 | module Hp.Eff.SendEmail.Noop 2 | ( runSendEmailNoop 3 | ) where 4 | 5 | import Hp.Eff.SendEmail (SendEmailEffect(..)) 6 | 7 | import Control.Effect.Interpret 8 | 9 | runSendEmailNoop :: 10 | InterpretC SendEmailEffect m a 11 | -> m a 12 | runSendEmailNoop = 13 | runInterpret $ \case 14 | SendEmail _ next -> 15 | next 16 | -------------------------------------------------------------------------------- /src/Hp/RequestBody/Subscribe.hs: -------------------------------------------------------------------------------- 1 | module Hp.RequestBody.Subscribe 2 | ( SubscribeRequestBody(..) 3 | ) where 4 | 5 | import Data.Aeson (FromJSON) 6 | 7 | 8 | data SubscribeRequestBody 9 | = SubscribeRequestBody 10 | { -- | Receive an email when a poll is created? 11 | pollCreated :: Bool 12 | } deriving stock (Generic) 13 | deriving anyclass (FromJSON) 14 | -------------------------------------------------------------------------------- /src/Hp/UserProfile.hs: -------------------------------------------------------------------------------- 1 | module Hp.UserProfile 2 | ( UserProfile(..) 3 | ) where 4 | 5 | import Hp.GitHub.UserName (GitHubUserName) 6 | 7 | import Data.Aeson (ToJSON) 8 | 9 | 10 | data UserProfile 11 | = UserProfile 12 | { gitHub :: Maybe GitHubUserName 13 | , subscribedToPollCreated :: Bool 14 | } deriving stock (Generic) 15 | deriving anyclass (ToJSON) 16 | -------------------------------------------------------------------------------- /src/Hp/GitHub/ErrorResponse.hs: -------------------------------------------------------------------------------- 1 | module Hp.GitHub.ErrorResponse 2 | ( GitHubErrorResponse(..) 3 | ) where 4 | 5 | import Data.Aeson (FromJSON) 6 | 7 | 8 | data GitHubErrorResponse 9 | = GitHubErrorResponse 10 | { error :: Text 11 | , error_description :: Text 12 | , error_uri :: Text 13 | } deriving stock (Generic, Show) 14 | deriving anyclass (FromJSON) 15 | -------------------------------------------------------------------------------- /src/Hp/RequestBody/AnswerPoll.hs: -------------------------------------------------------------------------------- 1 | module Hp.RequestBody.AnswerPoll 2 | ( AnswerPollRequestBody(..) 3 | ) where 4 | 5 | import Hp.PollQuestionAnswer (PollQuestionAnswer) 6 | 7 | import Data.Aeson (FromJSON) 8 | 9 | 10 | data AnswerPollRequestBody 11 | = AnswerPollRequestBody 12 | { answers :: [PollQuestionAnswer] 13 | } deriving stock (Generic) 14 | deriving anyclass (FromJSON) 15 | -------------------------------------------------------------------------------- /frontend/src/App/Effect/Navigate.purs: -------------------------------------------------------------------------------- 1 | module App.Effect.Navigate where 2 | 3 | import Prelude 4 | 5 | import App.Data.Route (Route) 6 | import Control.Monad.Trans.Class (lift) 7 | import Halogen (HalogenM) 8 | 9 | class Monad m <= Navigate m where 10 | navigate :: Route -> m Unit 11 | 12 | instance navigateHalogenM :: Navigate m => Navigate (HalogenM s f g o m) where 13 | navigate = lift <<< navigate 14 | -------------------------------------------------------------------------------- /nix/haskell-overlay.nix: -------------------------------------------------------------------------------- 1 | { compiler }: 2 | 3 | self: super: 4 | { 5 | haskell = super.haskell // { 6 | packages = super.haskell.packages // { 7 | "${compiler}" = super.haskell.packages."${compiler}".override { 8 | overrides = super.callPackage ./haskell-overrides.nix 9 | { haskellLib = super.haskell.lib; 10 | }; 11 | }; 12 | }; 13 | }; 14 | } 15 | -------------------------------------------------------------------------------- /src/Hp/GitHub/ClientSecret.hs: -------------------------------------------------------------------------------- 1 | module Hp.GitHub.ClientSecret 2 | ( GitHubClientSecret(..) 3 | ) where 4 | 5 | import Web.HttpApiData 6 | 7 | 8 | newtype GitHubClientSecret 9 | = GitHubClientSecret { unGitHubClientSecret :: Text } 10 | deriving newtype (ToHttpApiData) 11 | 12 | instance Show GitHubClientSecret where 13 | show :: GitHubClientSecret -> [Char] 14 | show _ = 15 | "" 16 | -------------------------------------------------------------------------------- /nix/world.nix: -------------------------------------------------------------------------------- 1 | { compiler ? "ghc864" }: 2 | 3 | let 4 | haskellOverlay = import ./haskell-overlay.nix { inherit compiler; }; 5 | pkgs = builtins.fetchGit { 6 | url = "git@github.com:NixOS/nixpkgs-channels.git"; 7 | rev = "d956f2279b8ac02bd9e48cf2a09dcb66383ab6be"; 8 | }; 9 | 10 | 11 | in 12 | { 13 | src = pkgs; 14 | pkgs = import pkgs { overlays = [ haskellOverlay ]; 15 | }; 16 | } 17 | -------------------------------------------------------------------------------- /src/Hp/Entity.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | 3 | module Hp.Entity 4 | ( Entity(..) 5 | ) where 6 | 7 | import Hp.IsEntity (EntityId) 8 | 9 | -- | An entity is a value (value) paired with its persistent identity (key). 10 | data Entity a 11 | = Entity 12 | { key :: EntityId a 13 | , value :: a 14 | } deriving stock (Generic) 15 | 16 | deriving instance (Show a, Show (EntityId a)) => Show (Entity a) 17 | -------------------------------------------------------------------------------- /src/Hp/RequestBody/CreatePoll.hs: -------------------------------------------------------------------------------- 1 | module Hp.RequestBody.CreatePoll 2 | ( CreatePollRequestBody(..) 3 | ) where 4 | 5 | import Hp.PollFormElement 6 | 7 | import Data.Aeson (FromJSON) 8 | import Data.Time (DiffTime) 9 | 10 | 11 | data CreatePollRequestBody 12 | = PollRequestBody 13 | { duration :: DiffTime 14 | , elements :: [PollFormElement] 15 | } deriving stock (Generic, Show) 16 | deriving anyclass (FromJSON) 17 | -------------------------------------------------------------------------------- /frontend/static/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | hspolls 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | -------------------------------------------------------------------------------- /src/Hp/Eff/GitHubAuth/AlwaysFail.hs: -------------------------------------------------------------------------------- 1 | -- | GitHub auth carrier that always fails to authenticate. 2 | 3 | module Hp.Eff.GitHubAuth.AlwaysFail 4 | ( runGitHubAuthAlwaysFail 5 | ) where 6 | 7 | import Hp.Eff.GitHubAuth (GitHubAuthEffect(..)) 8 | 9 | import Control.Effect.Interpret 10 | 11 | runGitHubAuthAlwaysFail :: 12 | InterpretC GitHubAuthEffect m a 13 | -> m a 14 | runGitHubAuthAlwaysFail = 15 | runInterpret $ \case 16 | GitHubAuth _code next -> 17 | next Nothing 18 | -------------------------------------------------------------------------------- /src/Hp/Worker/SendEmail.hs: -------------------------------------------------------------------------------- 1 | module Hp.Worker.SendEmail 2 | ( sendEmailWorker 3 | ) where 4 | 5 | import Hp.Eff.Await (AwaitEffect, await) 6 | import Hp.Eff.SendEmail (SendEmailEffect, sendEmail) 7 | import Hp.Email (Email(..)) 8 | 9 | import Control.Effect 10 | 11 | 12 | sendEmailWorker :: 13 | ( Carrier sig m 14 | , Member (AwaitEffect Email) sig 15 | , Member SendEmailEffect sig 16 | ) 17 | => m void 18 | sendEmailWorker = 19 | forever (await >>= sendEmail) 20 | -------------------------------------------------------------------------------- /src/Hp/GitHub/PostLoginOauthAccessTokenResponse.hs: -------------------------------------------------------------------------------- 1 | module Hp.GitHub.PostLoginOauthAccessTokenResponse 2 | ( GitHubPostLoginOauthAccessTokenResponse(..) 3 | ) where 4 | 5 | import Hp.GitHub.AccessToken (GitHubAccessToken) 6 | 7 | import Data.Aeson (FromJSON) 8 | 9 | 10 | data GitHubPostLoginOauthAccessTokenResponse 11 | = GitHubPostLoginOauthAccessTokenResponse 12 | { access_token :: GitHubAccessToken 13 | , scope :: Text 14 | , token_type :: Text 15 | } deriving stock (Show, Generic) 16 | deriving anyclass (FromJSON) 17 | -------------------------------------------------------------------------------- /nix/pkgs/hasql-pool.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base-prelude, hasql, hspec, resource-pool, stdenv 2 | , time 3 | }: 4 | mkDerivation { 5 | pname = "hasql-pool"; 6 | version = "0.5.0.1"; 7 | sha256 = "28c67fd0263d3418b51f3a514abbd1527b5dd690da19bcf90899e14de7b056c7"; 8 | libraryHaskellDepends = [ base-prelude hasql resource-pool time ]; 9 | testHaskellDepends = [ base-prelude hasql hspec ]; 10 | homepage = "https://github.com/nikita-volkov/hasql-pool"; 11 | description = "A pool of connections for Hasql"; 12 | license = stdenv.lib.licenses.mit; 13 | } 14 | -------------------------------------------------------------------------------- /src/Hp/Metrics.hs: -------------------------------------------------------------------------------- 1 | -- | Top-level Prometheus metrics. 2 | 3 | module Hp.Metrics 4 | ( requestCounter 5 | ) where 6 | 7 | import Prometheus 8 | 9 | import qualified Prometheus.Metric.GHC 10 | 11 | 12 | ghcMetrics :: Prometheus.Metric.GHC.GHCMetrics 13 | ghcMetrics = 14 | unsafeRegister Prometheus.Metric.GHC.ghcMetrics 15 | {-# NOINLINE ghcMetrics #-} 16 | 17 | -- | HTTP request counter. 18 | requestCounter :: Counter 19 | requestCounter = 20 | unsafeRegister (counter (Info "request_counter" "Request counter")) 21 | {-# NOINLINE requestCounter #-} 22 | -------------------------------------------------------------------------------- /src/Hp/Hasql.hs: -------------------------------------------------------------------------------- 1 | -- | Hasql helpers. 2 | 3 | module Hp.Hasql 4 | ( statement 5 | ) where 6 | 7 | import Hasql.Decoders (Result) 8 | import Hasql.Encoders (Params) 9 | import Hasql.Transaction (Transaction) 10 | 11 | import qualified Hasql.Statement 12 | import qualified Hasql.Transaction (statement) 13 | 14 | 15 | statement :: 16 | ByteString 17 | -> a 18 | -> Params a 19 | -> Result b 20 | -> Transaction b 21 | statement sql params encoder decoder = 22 | Hasql.Transaction.statement 23 | params 24 | (Hasql.Statement.Statement sql encoder decoder True) 25 | -------------------------------------------------------------------------------- /src/Hp/Eff/Log.hs: -------------------------------------------------------------------------------- 1 | module Hp.Eff.Log 2 | ( LogEffect(..) 3 | , log 4 | ) where 5 | 6 | import Hp.Eff.FirstOrder (FirstOrderEffect(..)) 7 | 8 | import Control.Effect 9 | import Control.Effect.Carrier 10 | 11 | 12 | data LogEffect (m :: Type -> Type) (k :: Type) where 13 | Log :: 14 | Text 15 | -> k 16 | -> LogEffect m k 17 | 18 | deriving stock (Functor) 19 | deriving (Effect, HFunctor) 20 | via (FirstOrderEffect LogEffect) 21 | 22 | log :: 23 | ( Carrier sig m 24 | , Member LogEffect sig 25 | ) 26 | => Text 27 | -> m () 28 | log message = 29 | send (Log message (pure ())) 30 | -------------------------------------------------------------------------------- /src/Hp/GitHub/AccessToken.hs: -------------------------------------------------------------------------------- 1 | module Hp.GitHub.AccessToken 2 | ( GitHubAccessToken(..) 3 | ) where 4 | 5 | import Data.Aeson (FromJSON) 6 | import Web.HttpApiData (ToHttpApiData(..)) 7 | 8 | 9 | newtype GitHubAccessToken 10 | = GitHubAccessToken { unGitHubAccessToken :: Text } 11 | deriving stock (Show) 12 | deriving newtype (FromJSON) 13 | 14 | instance ToHttpApiData GitHubAccessToken where 15 | toQueryParam :: GitHubAccessToken -> Text 16 | toQueryParam = 17 | coerce 18 | 19 | toHeader :: GitHubAccessToken -> ByteString 20 | toHeader (GitHubAccessToken token) = 21 | "token " <> toHeader token 22 | -------------------------------------------------------------------------------- /frontend/README.org: -------------------------------------------------------------------------------- 1 | * Instructions for building 2 | 3 | ** Building the purescript frontend with pulp: 4 | 5 | #+begin_src bash 6 | pulp -w build --to static/app.js 7 | #+end_src 8 | 9 | ** Starting an nginx server for development use: 10 | 11 | We can build an nginx config file and get a bash executable starting 12 | nginx with that config by first building the nginx nix expression 13 | with: 14 | 15 | #+begin_src 16 | nix-build nginx.nix --argstr nginxRoot "$PWD" 17 | #+end_src 18 | 19 | then running the built executable with: 20 | 21 | #+begin_src bash 22 | ./result/bin/nginx-run 23 | #+end_src 24 | 25 | The server is configured to listen on port ~8888~ 26 | -------------------------------------------------------------------------------- /src/Hp/GitHub/Response.hs: -------------------------------------------------------------------------------- 1 | module Hp.GitHub.Response 2 | ( GitHubResponse(..) 3 | ) where 4 | 5 | import Hp.GitHub.ErrorResponse (GitHubErrorResponse) 6 | 7 | import Data.Aeson (FromJSON(..), Value) 8 | import Data.Aeson.Types (Parser) 9 | 10 | 11 | data GitHubResponse a 12 | = GitHubResponseError GitHubErrorResponse 13 | | GitHubResponseSuccess a 14 | deriving stock (Show) 15 | 16 | instance FromJSON a => FromJSON (GitHubResponse a) where 17 | parseJSON :: Value -> Parser (GitHubResponse a) 18 | parseJSON value = 19 | asum 20 | [ GitHubResponseError <$> parseJSON value 21 | , GitHubResponseSuccess <$> parseJSON value 22 | ] 23 | -------------------------------------------------------------------------------- /nix/pkgs/fused-effects.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, criterion, deepseq, doctest, hspec 2 | , MonadRandom, QuickCheck, random, stdenv, transformers 3 | }: 4 | mkDerivation { 5 | pname = "fused-effects"; 6 | version = "0.3.0.0"; 7 | sha256 = "a6007b62e9b22c9b3426a728be06a1694c69a2d8d1c3b5ae58f7bfb60bdd91de"; 8 | libraryHaskellDepends = [ 9 | base deepseq MonadRandom random transformers 10 | ]; 11 | testHaskellDepends = [ base doctest hspec QuickCheck ]; 12 | benchmarkHaskellDepends = [ base criterion ]; 13 | homepage = "https://github.com/fused-effects/fused-effects"; 14 | description = "A fast, flexible, fused effect system"; 15 | license = stdenv.lib.licenses.bsd3; 16 | } 17 | -------------------------------------------------------------------------------- /src/Hp/Email.hs: -------------------------------------------------------------------------------- 1 | module Hp.Email 2 | ( Email(..) 3 | , PersonalEmail(..) 4 | , TransactionalEmail(..) 5 | ) where 6 | 7 | 8 | -- | An email. 9 | data Email 10 | = EmailPersonal PersonalEmail 11 | | EmailTransactional TransactionalEmail 12 | 13 | -- | An email to one person. 14 | data PersonalEmail 15 | = PersonalEmail 16 | { body :: Text 17 | , from :: Text 18 | , subject :: Text 19 | , to :: Text 20 | } deriving stock (Generic) 21 | 22 | -- | An email to a bunch of people (using BCC). 23 | data TransactionalEmail 24 | = TransactionalEmail 25 | { bcc :: [Text] 26 | , body :: Text 27 | , from :: Text 28 | , subject :: Text 29 | } deriving stock (Generic) 30 | -------------------------------------------------------------------------------- /frontend/src/Data/Route.purs: -------------------------------------------------------------------------------- 1 | module App.Data.Route where 2 | 3 | import Prelude hiding ((/)) 4 | 5 | import Data.Generic.Rep (class Generic) 6 | import Data.Generic.Rep.Show (genericShow) 7 | import Routing.Duplex (RouteDuplex', as, root, segment) 8 | import Routing.Duplex.Generic (noArgs, sum) 9 | import Routing.Duplex.Generic.Syntax ((/)) 10 | 11 | data Route 12 | = Home 13 | 14 | derive instance genericRoute :: Generic Route _ 15 | derive instance eqRoute :: Eq Route 16 | derive instance ordRoute :: Ord Route 17 | 18 | instance showRoute :: Show Route where 19 | show = genericShow 20 | 21 | routeCodec :: RouteDuplex' Route 22 | routeCodec = root $ sum 23 | { "Home": noArgs 24 | } 25 | -------------------------------------------------------------------------------- /src/Hp/Eff/Await.hs: -------------------------------------------------------------------------------- 1 | module Hp.Eff.Await 2 | ( AwaitEffect(..) 3 | , await 4 | ) where 5 | 6 | import Hp.Eff.FirstOrder (FirstOrderEffect(..)) 7 | 8 | import Control.Effect 9 | import Control.Effect.Carrier 10 | 11 | 12 | data AwaitEffect (value :: Type) (m :: Type -> Type) (k :: Type) where 13 | Await :: 14 | (value -> k) 15 | -> AwaitEffect value m k 16 | 17 | deriving stock (Functor) 18 | deriving (Effect, HFunctor) 19 | via (FirstOrderEffect (AwaitEffect value)) 20 | 21 | -- | Await a value from an anonymous producer. 22 | await :: 23 | ( Carrier sig m 24 | , Member (AwaitEffect value) sig 25 | ) 26 | => m value 27 | await = 28 | send (Await pure) 29 | -------------------------------------------------------------------------------- /src/Hp/GitHub/UserName.hs: -------------------------------------------------------------------------------- 1 | module Hp.GitHub.UserName 2 | ( GitHubUserName(..) 3 | , gitHubUserNameEncoder 4 | , gitHubUserNameDecoder 5 | ) where 6 | 7 | import Data.Aeson (FromJSON, ToJSON) 8 | 9 | import qualified Hasql.Decoders as Decoder 10 | import qualified Hasql.Encoders as Encoder 11 | 12 | 13 | newtype GitHubUserName 14 | = GitHubUserName { unGitHubUserName :: Text } 15 | deriving stock (Show) 16 | deriving newtype (FromJSON, ToJSON) 17 | 18 | gitHubUserNameEncoder :: Encoder.Value GitHubUserName 19 | gitHubUserNameEncoder = 20 | coerce Encoder.text 21 | 22 | gitHubUserNameDecoder :: Decoder.Value GitHubUserName 23 | gitHubUserNameDecoder = 24 | GitHubUserName <$> Decoder.text 25 | -------------------------------------------------------------------------------- /src/Hp/Eff/SendEmail.hs: -------------------------------------------------------------------------------- 1 | module Hp.Eff.SendEmail 2 | ( SendEmailEffect(..) 3 | , sendEmail 4 | ) where 5 | 6 | import Hp.Eff.FirstOrder (FirstOrderEffect(..)) 7 | import Hp.Email (Email) 8 | 9 | import Control.Effect 10 | import Control.Effect.Carrier 11 | 12 | 13 | data SendEmailEffect (m :: Type -> Type) (k :: Type) where 14 | SendEmail :: 15 | Email 16 | -> k 17 | -> SendEmailEffect m k 18 | 19 | deriving stock (Functor) 20 | deriving (Effect, HFunctor) 21 | via (FirstOrderEffect SendEmailEffect) 22 | 23 | sendEmail :: 24 | ( Carrier sig m 25 | , Member SendEmailEffect sig 26 | ) 27 | => Email 28 | -> m () 29 | sendEmail email = 30 | send (SendEmail email (pure ())) 31 | -------------------------------------------------------------------------------- /src/Hp/Eff/Yield.hs: -------------------------------------------------------------------------------- 1 | module Hp.Eff.Yield 2 | ( YieldEffect(..) 3 | , yield 4 | ) where 5 | 6 | import Hp.Eff.FirstOrder (FirstOrderEffect(..)) 7 | 8 | import Control.Effect 9 | import Control.Effect.Carrier 10 | 11 | 12 | data YieldEffect (value :: Type) (m :: Type -> Type) (k :: Type) where 13 | Yield :: 14 | value 15 | -> k 16 | -> YieldEffect value m k 17 | 18 | deriving stock (Functor) 19 | deriving (Effect, HFunctor) 20 | via (FirstOrderEffect (YieldEffect value)) 21 | 22 | -- | Yield a value to an anonymous consumer. 23 | yield :: 24 | ( Carrier sig m 25 | , Member (YieldEffect value) sig 26 | ) 27 | => value 28 | -> m () 29 | yield value = 30 | send (Yield value (pure ())) 31 | -------------------------------------------------------------------------------- /src/Hp/Eff/GetCurrentTime.hs: -------------------------------------------------------------------------------- 1 | module Hp.Eff.GetCurrentTime 2 | ( GetCurrentTimeEffect(..) 3 | , getCurrentTime 4 | ) where 5 | 6 | import Hp.Eff.FirstOrder (FirstOrderEffect(..)) 7 | 8 | import Control.Effect 9 | import Control.Effect.Carrier 10 | import Data.Time (UTCTime) 11 | 12 | 13 | data GetCurrentTimeEffect (m :: Type -> Type) (k :: Type) where 14 | GetCurrentTime :: 15 | (UTCTime -> k) 16 | -> GetCurrentTimeEffect m k 17 | 18 | deriving stock (Functor) 19 | deriving (Effect, HFunctor) 20 | via (FirstOrderEffect GetCurrentTimeEffect) 21 | 22 | getCurrentTime :: 23 | ( Carrier sig m 24 | , Member GetCurrentTimeEffect sig 25 | ) 26 | => m UTCTime 27 | getCurrentTime = 28 | send (GetCurrentTime pure) 29 | -------------------------------------------------------------------------------- /src/Hp/Eff/GitHubAuth.hs: -------------------------------------------------------------------------------- 1 | module Hp.Eff.GitHubAuth 2 | ( GitHubAuthEffect(..) 3 | , gitHubAuth 4 | ) where 5 | 6 | import Hp.Eff.FirstOrder (FirstOrderEffect(..)) 7 | import Hp.GitHub.Code (GitHubCode) 8 | import Hp.GitHub.User (GitHubUser) 9 | 10 | import Control.Effect 11 | import Control.Effect.Carrier 12 | 13 | 14 | data GitHubAuthEffect (m :: Type -> Type) (k :: Type) where 15 | GitHubAuth :: 16 | GitHubCode 17 | -> (Maybe GitHubUser -> k) 18 | -> GitHubAuthEffect m k 19 | 20 | deriving stock (Functor) 21 | deriving (Effect, HFunctor) 22 | via (FirstOrderEffect GitHubAuthEffect) 23 | 24 | gitHubAuth :: 25 | ( Carrier sig m 26 | , Member GitHubAuthEffect sig 27 | ) 28 | => GitHubCode 29 | -> m (Maybe GitHubUser) 30 | gitHubAuth code = 31 | send (GitHubAuth code pure) 32 | -------------------------------------------------------------------------------- /src/Hp/PostgresConfig.hs: -------------------------------------------------------------------------------- 1 | -- TODO Mitchell moved PostgresConfig into Hp.Config, now this module has a 2 | -- werid name! 3 | module Hp.PostgresConfig 4 | ( acquirePostgresPool 5 | ) where 6 | 7 | import Hp.Config (PostgresConfig(..)) 8 | 9 | import qualified Hasql.Connection as Hasql 10 | import qualified Hasql.Pool as Pool 11 | 12 | 13 | acquirePostgresPool :: MonadIO m => PostgresConfig -> m Pool.Pool 14 | acquirePostgresPool PostgresConfig{..} = liftIO $ Pool.acquire settings 15 | where 16 | settings :: Pool.Settings 17 | settings = (fromIntegral poolSize, fromIntegral poolTimeout, connSettings) 18 | 19 | connSettings :: Hasql.Settings 20 | connSettings = Hasql.settings 21 | (host ^. re utf8) 22 | (fromIntegral port) 23 | (user ^. re utf8) 24 | (password ^. re utf8) 25 | (dbName ^. re utf8) 26 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ### Building & running 2 | 3 | ``` 4 | ./make 5 | docker-compose up -d 6 | cabal v2-run 7 | ``` 8 | 9 | ### Coding conventions 10 | 11 | - Effects are defined in `Hp.Eff.` and named 12 | `Effect` 13 | - Carriers are defined in `Hp.Eff..` and named 14 | `Carrier` 15 | - Types with a persistent identity are defined in `Hp.Entity.` and 16 | implement the `IsEntity` type class 17 | - Event types (domain events of interest to other parts of the application) are 18 | defined in `Hp.Event.` and use the past tense 19 | - Misc. types are defined in `Hp.` 20 | - HTTP API routes are given declarative verb names `Route` 21 | - The corresponding route handler is defined in `Hp.Handler.`, which 22 | exports a single function named `handle` 23 | -------------------------------------------------------------------------------- /src/Hp/Handler/GetRoot.hs: -------------------------------------------------------------------------------- 1 | module Hp.Handler.GetRoot 2 | ( handleGetRoot 3 | ) where 4 | 5 | import Hp.Entity.User (UserId) 6 | 7 | import Control.Effect 8 | import Prelude hiding (div) 9 | import Servant.Auth.Server (AuthResult(..)) 10 | import Text.Blaze.Html5 11 | import Text.Blaze.Html5.Attributes 12 | 13 | 14 | handleGetRoot :: 15 | ( Carrier sig m 16 | ) 17 | => AuthResult UserId 18 | -> m Html 19 | handleGetRoot auth = 20 | (pure . fold) 21 | [ div ("Hello, world! You are: " <> toHtml (show auth)) 22 | -- TODO set state get param 23 | -- TODO set redirect_uri get param 24 | , a "Log in with GitHub" ! 25 | href 26 | (unsafeByteStringValue 27 | (fold 28 | [ "https://github.com/login/oauth/authorize?" 29 | , "client_id=0708940f1632f7a953e8" 30 | ])) 31 | ] 32 | -------------------------------------------------------------------------------- /nix/pkgs/hasql-cursor-query.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, base-prelude, bytestring, contravariant 2 | , foldl, hasql, hasql-cursor-transaction, hasql-transaction 3 | , profunctors, QuickCheck, quickcheck-instances, rebase, stdenv 4 | , tasty, tasty-hunit, tasty-quickcheck 5 | }: 6 | mkDerivation { 7 | pname = "hasql-cursor-query"; 8 | version = "0.4.4.2"; 9 | sha256 = "09632193fd511749c5ca07f0391f22fdfa6118f1a03658f99a95c2f315e8a7c0"; 10 | libraryHaskellDepends = [ 11 | base base-prelude bytestring contravariant foldl hasql 12 | hasql-cursor-transaction hasql-transaction profunctors 13 | ]; 14 | testHaskellDepends = [ 15 | foldl hasql QuickCheck quickcheck-instances rebase tasty 16 | tasty-hunit tasty-quickcheck 17 | ]; 18 | homepage = "https://github.com/nikita-volkov/hasql-cursor-query"; 19 | description = "A declarative abstraction over PostgreSQL Cursor"; 20 | license = stdenv.lib.licenses.mit; 21 | } 22 | -------------------------------------------------------------------------------- /src/Hp/ResponseBody/GetPoll.hs: -------------------------------------------------------------------------------- 1 | module Hp.ResponseBody.GetPoll 2 | ( GetPollResponseBody(..) 3 | , makeGetPollResponseBody 4 | ) where 5 | 6 | import Hp.Entity.Poll (Poll) 7 | import Hp.PollFormElement (PollFormElement) 8 | import Hp.PollQuestionAnswer (PollQuestionAnswer) 9 | 10 | import Data.Aeson (ToJSON) 11 | import Data.Time (DiffTime, UTCTime) 12 | 13 | 14 | data GetPollResponseBody 15 | = GetPollResponseBody 16 | { created :: UTCTime 17 | , duration :: DiffTime 18 | , poll :: [PollFormElement] 19 | , answers :: Vector [PollQuestionAnswer] 20 | } deriving stock (Generic) 21 | deriving anyclass (ToJSON) 22 | 23 | makeGetPollResponseBody :: 24 | Poll 25 | -> Vector [PollQuestionAnswer] 26 | -> GetPollResponseBody 27 | makeGetPollResponseBody poll answers = 28 | GetPollResponseBody 29 | { created = poll ^. #created 30 | , duration = poll ^. #duration 31 | , poll = poll ^. #elements 32 | , answers = answers 33 | } 34 | -------------------------------------------------------------------------------- /frontend/src/Main.purs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import App.Prelude 4 | 5 | import App.AppM (Env, runAppM) 6 | import App.Data.Route (routeCodec, Route(Home)) 7 | import Effect (Effect) 8 | import Effect.Aff (launchAff_) 9 | import Halogen as H 10 | import Halogen.Aff as HA 11 | import Halogen.VDom.Driver (runUI) 12 | import App.Component.Router as Router 13 | import Routing.Duplex (parse) 14 | import Routing.PushState (matchesWith, makeInterface) 15 | 16 | main :: Effect Unit 17 | main = HA.runHalogenAff do 18 | body <- HA.awaitBody 19 | env <- makeEnv 20 | driver <- runUI (H.hoist (runAppM env) Router.component) Home body 21 | 22 | liftEffect do 23 | -- hook up router 24 | void $ env.nav # matchesWith (parse routeCodec) \old new -> 25 | when (old /= Just new) do 26 | launchAff_ $ driver.query $ Router.Navigate new unit 27 | 28 | pure unit 29 | 30 | makeEnv :: Aff Env 31 | makeEnv = liftEffect do 32 | nav <- makeInterface 33 | pure { baseUrl: "/api/" 34 | , nav: nav 35 | } 36 | -------------------------------------------------------------------------------- /src/Hp/Eff/Log/Stdout.hs: -------------------------------------------------------------------------------- 1 | -- | Log carrier that synchronously logs to stdout. 2 | 3 | {-# LANGUAGE UndecidableInstances #-} 4 | 5 | module Hp.Eff.Log.Stdout 6 | ( runLogStdout 7 | ) where 8 | 9 | import Hp.Eff.Log (LogEffect(..)) 10 | 11 | import Control.Effect.Carrier 12 | import Control.Effect.Sum 13 | import Say (say) 14 | 15 | 16 | newtype LogCarrierStdout m a 17 | = LogCarrierStdout { unLogCarrierStdout :: m a } 18 | deriving newtype (Applicative, Functor, Monad, MonadIO) 19 | 20 | instance 21 | ( Carrier sig m 22 | , MonadIO m 23 | ) 24 | => Carrier (LogEffect :+: sig) (LogCarrierStdout m) where 25 | 26 | eff :: 27 | (LogEffect :+: sig) (LogCarrierStdout m) (LogCarrierStdout m a) 28 | -> LogCarrierStdout m a 29 | eff = \case 30 | L (Log message next) -> do 31 | say message 32 | next 33 | 34 | R other -> 35 | LogCarrierStdout (eff (handleCoercible other)) 36 | 37 | runLogStdout :: 38 | LogCarrierStdout m a 39 | -> m a 40 | runLogStdout = 41 | unLogCarrierStdout 42 | -------------------------------------------------------------------------------- /docker-compose.dhall: -------------------------------------------------------------------------------- 1 | { services = 2 | { postgres = 3 | { image = "postgres:11.2" 4 | , environment = 5 | [ "POSTGRES_USER=hspolls" 6 | ] 7 | , network_mode = "host" 8 | , volumes = 9 | [ { type = "bind" 10 | , source = "./db/schema.sql" 11 | , target = "/docker-entrypoint-initdb.d/schema.sql" 12 | } 13 | ] 14 | } 15 | 16 | , prometheus = 17 | { image = "prom/prometheus:v2.8.1" 18 | , network_mode = "host" 19 | , volumes = 20 | [ { type = "bind" 21 | , source = "./etc/prometheus.yaml" 22 | , target = "/etc/prometheus/prometheus.yml" 23 | } 24 | , { type = "volume" 25 | , source = "prometheus" 26 | , target = "/prometheus" 27 | } 28 | ] 29 | } 30 | } 31 | 32 | , version = "3.7" 33 | 34 | , volumes = 35 | { postgres = {=} 36 | , prometheus = {=} 37 | } 38 | } 39 | -------------------------------------------------------------------------------- /src/Hp/Handler/GetUserProfile.hs: -------------------------------------------------------------------------------- 1 | module Hp.Handler.GetUserProfile 2 | ( handleGetUserProfile 3 | ) where 4 | 5 | import Hp.Eff.PersistUser (PersistUserEffect, getUserById) 6 | import Hp.Eff.Throw (ThrowEffect, throw) 7 | import Hp.Entity.User (UserId) 8 | import Hp.UserProfile (UserProfile(..)) 9 | 10 | import Control.Effect 11 | import Servant.Auth.Server (AuthResult(..)) 12 | import Servant.Server (ServerError, err401, err404) 13 | 14 | 15 | handleGetUserProfile :: 16 | ( Carrier sig m 17 | , Member PersistUserEffect sig 18 | , Member (ThrowEffect ServerError) sig 19 | ) 20 | => AuthResult UserId 21 | -> m UserProfile 22 | handleGetUserProfile = \case 23 | Authenticated userId -> 24 | getUserById userId >>= \case 25 | Nothing -> 26 | throw err404 27 | 28 | Just user -> 29 | pure UserProfile 30 | { gitHub = user ^. #value . #gitHub 31 | , subscribedToPollCreated = user ^. #value . #subscribedToPollCreated 32 | } 33 | 34 | _ -> 35 | throw err401 36 | -------------------------------------------------------------------------------- /nix/haskell-overrides.nix: -------------------------------------------------------------------------------- 1 | { runCommand, cabal2nix, lib, haskellLib, fetchFromGitHub }: 2 | 3 | self: super: with haskellLib; with builtins; with lib.strings; 4 | let callLocalPkg = name: pth: 5 | let src' = lib.cleanSourceWith { filter = filt; src = pth; }; 6 | filt = path: type: 7 | let isHiddenFile = hasPrefix "." (baseNameOf path); 8 | in !isHiddenFile; 9 | in self.callCabal2nix name src' {}; 10 | in 11 | { 12 | hspolls = callLocalPkg "hspolls" ../.; 13 | fused-effects = super.callPackage ./pkgs/fused-effects.nix {}; 14 | servant = super.servant_0_16; 15 | servant-server = super.servant-server_0_16; 16 | servant-client-core = super.servant-client-core_0_16; 17 | servant-client = super.servant-client_0_16; 18 | servant-blaze = super.servant-blaze_0_9; 19 | 20 | # tests require database connection 21 | hasql-pool = 22 | let p = super.callPackage ./pkgs/hasql-pool.nix {}; 23 | in dontCheck p; 24 | hasql-cursor-query = 25 | let p = super.callPackage ./pkgs/hasql-cursor-query.nix {}; 26 | in dontCheck p; 27 | } 28 | -------------------------------------------------------------------------------- /src/Hp/Handler/Subscribe.hs: -------------------------------------------------------------------------------- 1 | module Hp.Handler.Subscribe 2 | ( handleSubscribe 3 | ) where 4 | 5 | import Hp.Eff.PersistUser (PersistUserEffect, setUserSubscription) 6 | import Hp.Eff.Throw (ThrowEffect, throw) 7 | import Hp.Entity.User (UserId) 8 | import Hp.RequestBody.Subscribe (SubscribeRequestBody(..)) 9 | import Hp.Subscription (Subscription(..)) 10 | 11 | import Control.Effect 12 | import Servant (NoContent(..), ServerError, err401) 13 | import Servant.Auth.Server (AuthResult(..)) 14 | 15 | 16 | handleSubscribe :: 17 | ( Carrier sig m 18 | , Member PersistUserEffect sig 19 | , Member (ThrowEffect ServerError) sig 20 | ) 21 | => AuthResult UserId 22 | -> SubscribeRequestBody 23 | -> m NoContent 24 | handleSubscribe authResult body = 25 | case authResult of 26 | Authenticated userId -> do 27 | setUserSubscription 28 | userId 29 | Subscription 30 | { pollCreated = body ^. #pollCreated } 31 | 32 | pure NoContent 33 | 34 | _ -> 35 | throw err401 36 | -------------------------------------------------------------------------------- /src/Hp/Entity/PollAnswer.hs: -------------------------------------------------------------------------------- 1 | -- TODO PollAnswer -> PollResponse everywhere 2 | 3 | module Hp.Entity.PollAnswer 4 | ( PollAnswer(..) 5 | , EntityId(PollAnswerId) 6 | , PollAnswerId 7 | , pollAnswerIdDecoder 8 | ) where 9 | 10 | import Hp.Entity.Poll (PollId) 11 | import Hp.Entity.User (UserId) 12 | import Hp.IsEntity (IsEntity(..)) 13 | import Hp.PollQuestionAnswer (PollQuestionAnswer) 14 | 15 | import Data.Time (UTCTime) 16 | import Data.UUID (UUID) 17 | 18 | import qualified Hasql.Decoders as Decoder 19 | 20 | 21 | data PollAnswer 22 | = PollAnswer 23 | { answers :: [PollQuestionAnswer] 24 | , created :: UTCTime 25 | , pollId :: PollId 26 | , userId :: Maybe UserId 27 | } deriving stock (Generic, Show) 28 | 29 | instance IsEntity PollAnswer where 30 | newtype EntityId PollAnswer 31 | = PollAnswerId { unPollAnswerId :: UUID } 32 | deriving stock (Show) 33 | 34 | type PollAnswerId 35 | = EntityId PollAnswer 36 | 37 | pollAnswerIdDecoder :: Decoder.Value PollAnswerId 38 | pollAnswerIdDecoder = 39 | PollAnswerId <$> Decoder.uuid 40 | -------------------------------------------------------------------------------- /src/Hp/PollQuestion.hs: -------------------------------------------------------------------------------- 1 | module Hp.PollQuestion 2 | ( PollQuestion(..) 3 | , isPollQuestionValid 4 | ) where 5 | 6 | import Data.Char (isSpace) 7 | 8 | import qualified Data.Text as Text 9 | 10 | 11 | -- | A single question in a poll. 12 | data PollQuestion 13 | = CheckboxQuestion Text [Text] 14 | -- | DropdownQuestion Text [Text] 15 | -- | NumberQuestion Text Int 16 | -- | RadioQuestion Text [Text] 17 | -- | TextQuestion Text Bool Text -- Bool means: is text area? 18 | deriving stock (Generic, Show) 19 | 20 | -- | Is this question valid? (disallow empty strings, etc) 21 | isPollQuestionValid :: PollQuestion -> Bool 22 | isPollQuestionValid = \case 23 | CheckboxQuestion header choices -> 24 | and 25 | [ sensible header 26 | , not (null choices) 27 | , all sensible choices 28 | ] 29 | 30 | where 31 | -- Not null, no leading or trailing whitespace 32 | sensible :: Text -> Bool 33 | sensible s = 34 | and 35 | [ not (Text.null s) 36 | , not (isSpace (s ^?! _head)) 37 | , not (isSpace (s ^?! _last)) 38 | ] 39 | -------------------------------------------------------------------------------- /frontend/bower.json: -------------------------------------------------------------------------------- 1 | { 2 | "private": true, 3 | "name": "hspolls", 4 | "ignore": [ 5 | "*/.*", 6 | "node_modules", 7 | "bower_components", 8 | "output", 9 | "dist" 10 | ], 11 | "dependencies": { 12 | "purescript-aff": "^5.1.0", 13 | "purescript-affjax": "^9.0.0", 14 | "purescript-argonaut-codecs": "^6.0.1", 15 | "purescript-argonaut-core": "^5.0.0", 16 | "purescript-console": "^4.1.0", 17 | "purescript-effect": "^2.0.1", 18 | "purescript-foreign-object": "2.0.1", 19 | "purescript-formatters": "^4.0.1", 20 | "purescript-halogen": "^5.0.0", 21 | "purescript-nonempty": "^5.0.0", 22 | "purescript-now": "^4.0.0", 23 | "purescript-prelude": "^4.1.0", 24 | "purescript-profunctor-lenses": "6.1.1", 25 | "purescript-record": "2.0.0", 26 | "purescript-routing": "^9.0.0", 27 | "purescript-routing-duplex": "^0.3.0", 28 | "purescript-transformers": "^4.2.0", 29 | "purescript-typelevel-prelude": "4.0.0", 30 | "purescript-variant": "^6.0.0" 31 | }, 32 | "devDependencies": { 33 | "purescript-spec": "^3.1.0" 34 | } 35 | } 36 | -------------------------------------------------------------------------------- /src/Hp/Handler/GetPoll.hs: -------------------------------------------------------------------------------- 1 | module Hp.Handler.GetPoll 2 | ( handleGetPoll 3 | ) where 4 | 5 | import Hp.Eff.PersistPoll (PersistPollEffect, getPoll) 6 | import Hp.Eff.PersistPollAnswer (PersistPollAnswerEffect, getPollAnswers) 7 | import Hp.Eff.Throw (ThrowEffect, throw) 8 | import Hp.Entity.Poll (PollId) 9 | import Hp.PollQuestionAnswer (PollQuestionAnswer) 10 | import Hp.ResponseBody.GetPoll (GetPollResponseBody(..), 11 | makeGetPollResponseBody) 12 | 13 | import Control.Effect 14 | import Servant (ServerError, err404) 15 | 16 | 17 | handleGetPoll :: 18 | ( Carrier sig m 19 | , Member PersistPollEffect sig 20 | , Member PersistPollAnswerEffect sig 21 | , Member (ThrowEffect ServerError) sig 22 | ) 23 | => PollId 24 | -> m GetPollResponseBody 25 | handleGetPoll pollId = 26 | getPoll pollId >>= \case 27 | Nothing -> 28 | throw err404 29 | 30 | Just poll -> do 31 | answers :: Vector [PollQuestionAnswer] <- 32 | getPollAnswers (poll ^. #key) 33 | 34 | pure (makeGetPollResponseBody (poll ^. #value) answers) 35 | -------------------------------------------------------------------------------- /etc/config.dhall: -------------------------------------------------------------------------------- 1 | { aws = 2 | Some ./aws.dhall 3 | ? 4 | None { accessKeyId : Text, secretAccessKey : Text } 5 | 6 | , gitHub = 7 | Some ./github.dhall 8 | ? 9 | None { clientId : Text, clientSecret : Text } 10 | 11 | , postgres = 12 | { host = "127.0.0.1" 13 | , port = 5432 14 | , user = "hspolls" 15 | , password = "" 16 | , dbName = "hspolls" 17 | , poolSize = 20 18 | , poolTimeout = 5 19 | } 20 | 21 | , port = 8000 22 | 23 | , session = 24 | { -- The JSON Web Key used to sign and verify JSON Web Tokens. If None, 25 | -- generates a random JWK at runtime. 26 | jwk = 27 | Some ./jwk.dhall 28 | ? 29 | None Text 30 | 31 | -- The session cookie name. 32 | , name = "Session" 33 | 34 | -- Only send session cookie over TLS. 35 | , secure = False 36 | 37 | -- How long the session cookie lasts (in seconds). If None, the cookie 38 | -- will last until the user's browser is closed. 39 | , ttl = None Natural 40 | 41 | -- Whether or not to use XSRF as implemented by servant-auth. 42 | , xsrf = False 43 | } 44 | } 45 | -------------------------------------------------------------------------------- /src/Hp/Eff/Yield/Print.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | 3 | module Hp.Eff.Yield.Print 4 | ( YieldCarrierPrint 5 | , runYieldPrint 6 | ) where 7 | 8 | import Hp.Eff.Yield (YieldEffect(..)) 9 | 10 | import Control.Effect 11 | import Control.Effect.Carrier 12 | import Control.Effect.Sum 13 | 14 | 15 | newtype YieldCarrierPrint value m a 16 | = YieldCarrierPrint { unYieldCarrierPrint :: m a } 17 | deriving newtype (Applicative, Functor, Monad, MonadIO) 18 | 19 | instance 20 | ( Carrier sig m 21 | , MonadIO m 22 | , Show value 23 | ) 24 | => Carrier (YieldEffect value :+: sig) (YieldCarrierPrint value m) where 25 | 26 | eff :: 27 | (YieldEffect value :+: sig) (YieldCarrierPrint value m) (YieldCarrierPrint value m a) 28 | -> YieldCarrierPrint value m a 29 | eff = \case 30 | L (Yield value next) -> do 31 | YieldCarrierPrint (liftIO (print value)) 32 | next 33 | 34 | R other -> 35 | YieldCarrierPrint (eff (handleCoercible other)) 36 | 37 | runYieldPrint :: 38 | forall value a m. 39 | YieldCarrierPrint value m a 40 | -> m a 41 | runYieldPrint = 42 | unYieldCarrierPrint 43 | -------------------------------------------------------------------------------- /src/Hp/Eff/FirstOrder.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | 3 | -- | A newtype wrapper used to derive 'Effect' and 'HFunctor' for first-order 4 | -- effects. 5 | -- 6 | -- Used like so: 7 | -- 8 | -- @ 9 | -- data MyEffect (m :: Type -> Type) (k :: Type) where ... 10 | -- deriving (Effect, HFunctor) via (FirstOrderEffect MyEffect) 11 | -- @ 12 | 13 | module Hp.Eff.FirstOrder 14 | ( FirstOrderEffect(..) 15 | ) where 16 | 17 | import Control.Effect 18 | import Control.Effect.Carrier 19 | 20 | 21 | newtype FirstOrderEffect 22 | (sig :: (Type -> Type) -> Type -> Type) 23 | (m :: Type -> Type) 24 | (k :: Type) 25 | = FirstOrderEffect (sig m k) 26 | deriving stock Functor 27 | 28 | instance 29 | ( forall m n a. (Coercible (sig m a) (sig n a)) 30 | , forall m. Functor (sig m) 31 | ) 32 | => HFunctor (FirstOrderEffect sig) where 33 | 34 | hmap _ = 35 | coerce 36 | 37 | instance 38 | ( forall m n a. Coercible (sig m a) (sig n a) 39 | , forall m. Functor (sig m) 40 | ) 41 | => Effect (FirstOrderEffect sig) where 42 | 43 | handle state handler = 44 | coerce . fmap (handler . (<$ state)) 45 | -------------------------------------------------------------------------------- /nix/docker.nix: -------------------------------------------------------------------------------- 1 | with (import ./world.nix {}).pkgs; 2 | 3 | let 4 | docker-images-src = fetchFromGitHub { 5 | owner = "tstat"; 6 | repo = "docker-images-nix"; 7 | rev = "b64a7061d021617b1ab6b4d24b9999bcdc702c51"; 8 | sha256 = "1qwa2ws9ab867rs769lvfd6whn514vnr7x1nnpm0bvp5dr71wzxk"; 9 | }; 10 | buildImages = import docker-images-src; 11 | myImages = { pkgs, config, lib, ... }: 12 | { imports = [ "${docker-images-src}/postgresql" ]; 13 | config = { 14 | postgresql = { 15 | dev = { 16 | enable = true; 17 | package = pkgs.postgresql_11; 18 | enableTCPIP = true; 19 | 20 | authentication = '' 21 | local all all trust 22 | host all all 0.0.0.0/0 trust 23 | ''; 24 | 25 | extraConfig = '' 26 | log_statement = 'all' 27 | log_duration = true 28 | session_preload_libraries = 'auto_explain' 29 | auto_explain.log_min_duration = 0 30 | auto_explain.log_analyze = true 31 | ''; 32 | }; 33 | }; 34 | }; 35 | }; 36 | in buildImages [ myImages ] 37 | -------------------------------------------------------------------------------- /src/Hp/Entity/User.hs: -------------------------------------------------------------------------------- 1 | module Hp.Entity.User 2 | ( User(..) 3 | , EntityId(UserId) 4 | , UserId 5 | , userIdDecoder 6 | , userIdEncoder 7 | ) where 8 | 9 | import Hp.GitHub.UserName (GitHubUserName) 10 | import Hp.IsEntity (IsEntity(..)) 11 | 12 | import Data.Aeson (FromJSON, ToJSON) 13 | import Data.UUID (UUID) 14 | import Servant.Auth.Server (FromJWT(..), ToJWT(..)) 15 | 16 | import qualified Hasql.Decoders as Decoder 17 | import qualified Hasql.Encoders as Encoder 18 | 19 | 20 | data User 21 | = User 22 | { email :: Maybe Text 23 | , gitHub :: Maybe GitHubUserName 24 | , subscribedToPollCreated :: Bool 25 | } deriving stock (Generic, Show) 26 | deriving anyclass (FromJSON, ToJSON) 27 | 28 | instance IsEntity User where 29 | newtype EntityId User 30 | = UserId { unUserId :: UUID } 31 | deriving stock (Show) 32 | deriving newtype (FromJSON, ToJSON) 33 | deriving anyclass (FromJWT, ToJWT) 34 | 35 | type UserId 36 | = EntityId User 37 | 38 | userIdDecoder :: Decoder.Value UserId 39 | userIdDecoder = 40 | UserId <$> Decoder.uuid 41 | 42 | userIdEncoder :: Encoder.Value UserId 43 | userIdEncoder = 44 | coerce Encoder.uuid 45 | 46 | -------------------------------------------------------------------------------- /frontend/src/App/AppM.purs: -------------------------------------------------------------------------------- 1 | module App.AppM where 2 | 3 | import App.Prelude 4 | 5 | import App.Data.Route as Route 6 | import App.Effect.Navigate (class Navigate, navigate) 7 | import Foreign (unsafeToForeign) 8 | import Routing.Duplex (print) 9 | import Routing.PushState (PushStateInterface) 10 | import Type.Equality (class TypeEquals, from) 11 | 12 | type Env = 13 | { baseUrl :: String 14 | , nav :: PushStateInterface 15 | } 16 | 17 | newtype AppM a 18 | = AppM (ReaderT Env Aff a) 19 | 20 | runAppM :: Env -> AppM ~> Aff 21 | runAppM env (AppM m) = runReaderT m env 22 | 23 | derive newtype instance functorAppM :: Functor AppM 24 | derive newtype instance applyAppM :: Apply AppM 25 | derive newtype instance applicativeAppM :: Applicative AppM 26 | derive newtype instance bindAppM :: Bind AppM 27 | derive newtype instance monadAppM :: Monad AppM 28 | derive newtype instance monadEffectAppM :: MonadEffect AppM 29 | derive newtype instance monadAffAppM :: MonadAff AppM 30 | 31 | instance monadAskAppM :: TypeEquals e Env => MonadAsk e AppM where 32 | ask = AppM $ asks from 33 | 34 | instance navigateAppM :: Navigate AppM where 35 | navigate r = do 36 | env <- ask 37 | liftEffect $ env.nav.pushState (unsafeToForeign {}) (print Route.routeCodec r) 38 | -------------------------------------------------------------------------------- /src/Hp/Eff/HttpSession.hs: -------------------------------------------------------------------------------- 1 | module Hp.Eff.HttpSession 2 | ( HttpSessionEffect(..) 3 | , beginHttpSession 4 | ) where 5 | 6 | import Hp.Eff.FirstOrder (FirstOrderEffect(..)) 7 | 8 | import Control.Effect 9 | import Control.Effect.Carrier 10 | import Servant (AddHeader) 11 | import Servant.Auth.Server (SetCookie, ToJWT) 12 | 13 | 14 | data HttpSessionEffect (m :: Type -> Type) (k :: Type) where 15 | BeginHttpSession :: 16 | ( AddHeader "Set-Cookie" SetCookie response0 response1 17 | , AddHeader "Set-Cookie" SetCookie response1 response2 18 | , ToJWT session 19 | ) 20 | => session 21 | -> response0 22 | -> (response2 -> k) 23 | -> HttpSessionEffect m k 24 | 25 | deriving (Effect, HFunctor) 26 | via (FirstOrderEffect HttpSessionEffect) 27 | 28 | deriving stock instance Functor (HttpSessionEffect m) 29 | 30 | 31 | beginHttpSession :: 32 | ( AddHeader "Set-Cookie" SetCookie response0 response1 33 | , AddHeader "Set-Cookie" SetCookie response1 response2 34 | , Carrier sig m 35 | , Member HttpSessionEffect sig 36 | , ToJWT session 37 | ) 38 | => session 39 | -> response0 40 | -> m response2 41 | beginHttpSession session response = 42 | send (BeginHttpSession session response pure) 43 | -------------------------------------------------------------------------------- /src/Hp/Eff/Await/Chan.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | 3 | module Hp.Eff.Await.Chan 4 | ( AwaitCarrierChan 5 | , runAwaitChan 6 | ) where 7 | 8 | import Hp.Eff.Await (AwaitEffect(..)) 9 | 10 | import Control.Concurrent.STM 11 | import Control.Effect 12 | import Control.Effect.Carrier 13 | import Control.Effect.Reader 14 | import Control.Effect.Sum 15 | 16 | 17 | newtype AwaitCarrierChan value m a 18 | = AwaitCarrierChan { unAwaitCarrierChan :: ReaderC (TChan value) m a } 19 | deriving newtype (Applicative, Functor, Monad, MonadIO) 20 | 21 | instance 22 | ( Carrier sig m 23 | , MonadIO m 24 | ) 25 | => Carrier (AwaitEffect value :+: sig) (AwaitCarrierChan value m) where 26 | 27 | eff :: 28 | (AwaitEffect value :+: sig) (AwaitCarrierChan value m) (AwaitCarrierChan value m a) 29 | -> AwaitCarrierChan value m a 30 | eff = \case 31 | L (Await next) -> 32 | AwaitCarrierChan $ do 33 | chan :: TChan value <- 34 | ask 35 | 36 | liftIO (atomically (readTChan chan)) >>= 37 | unAwaitCarrierChan . next 38 | 39 | R other -> 40 | AwaitCarrierChan (eff (R (handleCoercible other))) 41 | 42 | runAwaitChan :: 43 | TChan value 44 | -> AwaitCarrierChan value m a 45 | -> m a 46 | runAwaitChan chan = 47 | runReader chan . unAwaitCarrierChan 48 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | steps: 2 | - simple_align: 3 | cases: false 4 | top_level_patterns: false 5 | records: false 6 | - imports: 7 | align: group 8 | list_align: after_alias 9 | pad_module_names: true 10 | long_list_align: inline 11 | empty_list_align: inherit 12 | list_padding: 2 13 | separate_lists: false 14 | space_surround: false 15 | - language_pragmas: 16 | style: compact 17 | align: true 18 | remove_redundant: true 19 | columns: 80 20 | newline: native 21 | language_extensions: 22 | - BangPatterns 23 | - ConstraintKinds 24 | - DataKinds 25 | - DefaultSignatures 26 | - DeriveAnyClass 27 | - DeriveFunctor 28 | - DeriveGeneric 29 | - DerivingStrategies 30 | - ExistentialQuantification 31 | - FlexibleContexts 32 | - FlexibleInstances 33 | - GADTs 34 | - GeneralizedNewtypeDeriving 35 | - InstanceSigs 36 | - KindSignatures 37 | - LambdaCase 38 | - MagicHash 39 | - MultiParamTypeClasses 40 | - NamedFieldPuns 41 | - NoImplicitPrelude 42 | - OverloadedLabels 43 | - OverloadedStrings 44 | - PatternSynonyms 45 | - RankNTypes 46 | - RecordWildCards 47 | - ScopedTypeVariables 48 | - StandaloneDeriving 49 | - TupleSections 50 | - TypeApplications 51 | - TypeFamilies 52 | - TypeOperators 53 | - UnicodeSyntax 54 | - ViewPatterns 55 | -------------------------------------------------------------------------------- /src/Hp/Eff/Yield/Chan.hs: -------------------------------------------------------------------------------- 1 | -- | Handle yields by writing them to a broadcast TChan. 2 | 3 | {-# LANGUAGE UndecidableInstances #-} 4 | 5 | module Hp.Eff.Yield.Chan 6 | ( YieldCarrierChan 7 | , runYieldChan 8 | ) where 9 | 10 | import Hp.Eff.Yield (YieldEffect(..)) 11 | 12 | import Control.Concurrent.STM 13 | import Control.Effect 14 | import Control.Effect.Carrier 15 | import Control.Effect.Reader 16 | import Control.Effect.Sum 17 | 18 | 19 | newtype YieldCarrierChan value m a 20 | = YieldCarrierChan { unYieldCarrierChan :: ReaderC (TChan value) m a } 21 | deriving newtype (Applicative, Functor, Monad, MonadIO) 22 | 23 | instance 24 | ( Carrier sig m 25 | , MonadIO m 26 | ) 27 | => Carrier (YieldEffect value :+: sig) (YieldCarrierChan value m) where 28 | 29 | eff :: 30 | (YieldEffect value :+: sig) (YieldCarrierChan value m) (YieldCarrierChan value m a) 31 | -> YieldCarrierChan value m a 32 | eff = \case 33 | L (Yield value next) -> do 34 | YieldCarrierChan $ do 35 | chan :: TChan value <- 36 | ask 37 | liftIO (atomically (writeTChan chan value)) 38 | next 39 | 40 | R other -> 41 | YieldCarrierChan (eff (R (handleCoercible other))) 42 | 43 | runYieldChan :: 44 | TChan value 45 | -> YieldCarrierChan value m a 46 | -> m a 47 | runYieldChan chan = 48 | runReader chan . unYieldCarrierChan 49 | -------------------------------------------------------------------------------- /src/Hp/Handler/GitHubOauthCallback.hs: -------------------------------------------------------------------------------- 1 | module Hp.Handler.GitHubOauthCallback 2 | ( handleGitHubOauthCallback 3 | ) where 4 | 5 | import Hp.Eff.GitHubAuth (GitHubAuthEffect, gitHubAuth) 6 | import Hp.Eff.HttpSession (HttpSessionEffect, beginHttpSession) 7 | import Hp.Eff.PersistUser (PersistUserEffect, putUserByGitHubUser) 8 | import Hp.Entity (Entity) 9 | import Hp.Entity.User (User) 10 | import Hp.GitHub.Code (GitHubCode) 11 | 12 | import Control.Effect 13 | import Servant (Header, Headers, NoContent(..), addHeader, noHeader) 14 | import Servant.Auth.Server (SetCookie) 15 | 16 | handleGitHubOauthCallback :: 17 | ( Carrier sig m 18 | , Member GitHubAuthEffect sig 19 | , Member HttpSessionEffect sig 20 | , Member PersistUserEffect sig 21 | ) 22 | => GitHubCode 23 | -> m (Headers 24 | '[ Header "Location" Text 25 | , Header "Set-Cookie" SetCookie 26 | , Header "Set-Cookie" SetCookie 27 | ] 28 | NoContent) 29 | handleGitHubOauthCallback code = 30 | gitHubAuth code >>= \case 31 | Nothing -> 32 | pure (redirect (noHeader (noHeader NoContent))) 33 | 34 | Just gitHubUser -> do 35 | user :: Entity User <- 36 | putUserByGitHubUser gitHubUser 37 | 38 | redirect <$> beginHttpSession (user ^. #key) NoContent 39 | 40 | where 41 | redirect = 42 | addHeader "/" 43 | -------------------------------------------------------------------------------- /src/Hp/Eff/PersistPoll.hs: -------------------------------------------------------------------------------- 1 | module Hp.Eff.PersistPoll 2 | ( PersistPollEffect(..) 3 | , getPoll 4 | , savePoll 5 | ) where 6 | 7 | import Hp.Eff.FirstOrder (FirstOrderEffect(..)) 8 | import Hp.Entity (Entity) 9 | import Hp.Entity.Poll 10 | import Hp.Entity.User (UserId) 11 | import Hp.PollFormElement (PollFormElement) 12 | 13 | import Control.Effect 14 | import Control.Effect.Carrier 15 | import Data.Time (DiffTime) 16 | 17 | 18 | data PersistPollEffect (m :: Type -> Type) (k :: Type) where 19 | GetPoll :: 20 | PollId 21 | -> (Maybe (Entity Poll) -> k) 22 | -> PersistPollEffect m k 23 | 24 | SavePoll :: 25 | DiffTime 26 | -> [PollFormElement] 27 | -> Maybe UserId 28 | -> (Entity Poll -> k) 29 | -> PersistPollEffect m k 30 | 31 | deriving stock (Functor) 32 | deriving (Effect, HFunctor) 33 | via (FirstOrderEffect PersistPollEffect) 34 | 35 | getPoll :: 36 | ( Carrier sig m 37 | , Member PersistPollEffect sig 38 | ) 39 | => PollId 40 | -> m (Maybe (Entity Poll)) 41 | getPoll pollId = 42 | send (GetPoll pollId pure) 43 | 44 | savePoll :: 45 | ( Carrier sig m 46 | , Member PersistPollEffect sig 47 | ) 48 | => DiffTime 49 | -> [PollFormElement] 50 | -> Maybe UserId 51 | -> m (Entity Poll) 52 | savePoll duration elements userId = 53 | send (SavePoll duration elements userId pure) 54 | -------------------------------------------------------------------------------- /src/Hp/TBroadcastChan.hs: -------------------------------------------------------------------------------- 1 | module Hp.TBroadcastChan 2 | ( TBroadcastChan 3 | , unsafeTBroadcastChanToTChan 4 | , newTBroadcastChan 5 | , newTBroadcastChanIO 6 | , dupTBroadcastChan 7 | , dupTBroadcastChanIO 8 | , writeTBroadcastChan 9 | , writeTBroadcastChanIO 10 | ) where 11 | 12 | import Control.Concurrent.STM 13 | 14 | newtype TBroadcastChan a 15 | = TBroadcastChan (TChan a) 16 | 17 | -- | Forget that a channel can only be written to. 18 | unsafeTBroadcastChanToTChan :: TBroadcastChan a -> TChan a 19 | unsafeTBroadcastChanToTChan (TBroadcastChan chan) = 20 | chan 21 | 22 | newTBroadcastChan :: forall a. STM (TBroadcastChan a) 23 | newTBroadcastChan = 24 | coerce @(STM (TChan a)) newTChan 25 | 26 | newTBroadcastChanIO :: forall a. IO (TBroadcastChan a) 27 | newTBroadcastChanIO = 28 | coerce @(IO (TChan a)) newTChanIO 29 | 30 | dupTBroadcastChan :: forall a. TBroadcastChan a -> STM (TChan a) 31 | dupTBroadcastChan = 32 | coerce @(TChan a -> _) dupTChan 33 | 34 | dupTBroadcastChanIO :: TBroadcastChan a -> IO (TChan a) 35 | dupTBroadcastChanIO = 36 | atomically . dupTBroadcastChan 37 | 38 | writeTBroadcastChan :: forall a. TBroadcastChan a -> a -> STM () 39 | writeTBroadcastChan = 40 | coerce @(TChan a -> _ -> _) writeTChan 41 | 42 | writeTBroadcastChanIO :: TBroadcastChan a -> a -> IO () 43 | writeTBroadcastChanIO chan value = 44 | atomically (writeTBroadcastChan chan value) 45 | -------------------------------------------------------------------------------- /frontend/src/Component/Router.purs: -------------------------------------------------------------------------------- 1 | module App.Component.Router where 2 | 3 | import App.Prelude 4 | 5 | import App.Data.Route (Route(..)) 6 | import Data.Array as Array 7 | import Halogen as H 8 | import Halogen.HTML as HH 9 | import Halogen.HTML.Events as HE 10 | import Halogen.HTML.Properties as HP 11 | import Halogen.HTML.Core as HC 12 | 13 | type State 14 | = { route :: Route 15 | } 16 | 17 | data Query k 18 | = Navigate Route k 19 | 20 | type ChildSlots = 21 | () 22 | 23 | component 24 | :: ∀ o m. Navigate m 25 | => MonadAff m 26 | => H.Component HH.HTML Query Route o m 27 | component = 28 | H.mkComponent 29 | { initialState 30 | , render 31 | , eval: H.mkEval $ H.defaultEval { handleQuery = handleQuery 32 | } 33 | } 34 | 35 | initialState :: Route -> State 36 | initialState r = { route: r 37 | } 38 | 39 | render 40 | :: ∀ m. Navigate m 41 | => MonadAff m 42 | => State 43 | -> H.ComponentHTML Void ChildSlots m 44 | render state = 45 | HH.div_ 46 | [ child 47 | ] 48 | where 49 | child :: HH.ComponentHTML Void ChildSlots m 50 | child = case state.route of 51 | Home -> HH.h1_ [ HH.text "Home" ] 52 | 53 | handleQuery ∷ ∀ a o m x. MonadAff m => Query x -> H.HalogenM State a ChildSlots o m (Maybe x) 54 | handleQuery = case _ of 55 | Navigate r k -> Just k <$ do 56 | H.modify_ (_ { route = r }) 57 | -------------------------------------------------------------------------------- /src/Hp/Eff/Throw.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | 3 | module Hp.Eff.Throw 4 | ( ThrowEffect(..) 5 | , throw 6 | , runThrow 7 | ) where 8 | 9 | import Hp.Eff.FirstOrder (FirstOrderEffect(..)) 10 | 11 | import Control.Effect 12 | import Control.Effect.Carrier 13 | import Control.Effect.Sum 14 | 15 | import qualified Control.Effect.Error as Error 16 | 17 | 18 | data ThrowEffect (e :: Type) (m :: Type -> Type) (k :: Type) where 19 | Throw :: 20 | e 21 | -> ThrowEffect e m k 22 | 23 | deriving stock (Functor) 24 | deriving (Effect, HFunctor) 25 | via (FirstOrderEffect (ThrowEffect e)) 26 | 27 | throw :: 28 | ( Carrier sig m 29 | , Member (ThrowEffect e) sig 30 | ) 31 | => e 32 | -> m a 33 | throw err = 34 | send (Throw err) 35 | 36 | 37 | newtype ThrowCarrier e m a 38 | = ThrowCarrier { unThrowCarrier :: Error.ErrorC e m a } 39 | deriving newtype (Applicative, Functor, Monad, MonadIO) 40 | 41 | instance 42 | ( Carrier sig m 43 | , Effect sig 44 | ) 45 | => Carrier (ThrowEffect e :+: sig) (ThrowCarrier e m) where 46 | 47 | eff :: 48 | (ThrowEffect e :+: sig) (ThrowCarrier e m) (ThrowCarrier e m a) 49 | -> ThrowCarrier e m a 50 | eff = \case 51 | L (Throw err) -> 52 | ThrowCarrier (Error.throwError err) 53 | 54 | R other -> 55 | ThrowCarrier (eff (R (handleCoercible other))) 56 | 57 | runThrow :: 58 | ThrowCarrier e m a 59 | -> m (Either e a) 60 | runThrow = 61 | Error.runError . unThrowCarrier 62 | -------------------------------------------------------------------------------- /frontend/nginx.nix: -------------------------------------------------------------------------------- 1 | { nginxRoot }: 2 | let pkgs = import {}; 3 | nginxConf = pkgs.writeText "nginx.conf" '' 4 | worker_processes 1; 5 | daemon off; 6 | error_log stderr; 7 | pid /tmp/nginx.pid; 8 | 9 | events { 10 | worker_connections 128; 11 | } 12 | 13 | http { 14 | access_log /dev/stdout; 15 | log_format main '$remote_addr - $remote_user [$time_local] "$request" ' 16 | '$status $body_bytes_sent "$http_referer" ' 17 | '"$http_user_agent" "$http_x_forwarded_for"'; 18 | 19 | include ${pkgs.nginx}/conf/mime.types; 20 | sendfile on; 21 | tcp_nopush on; 22 | tcp_nodelay on; 23 | keepalive_timeout 65; 24 | types_hash_max_size 2048; 25 | 26 | default_type application/octet-stream; 27 | server { 28 | listen 0.0.0.0:8888; 29 | server_name default; 30 | root ${nginxRoot}/static; 31 | index index.html; 32 | ssl off; 33 | location /api { 34 | proxy_pass http://hspolls_server; 35 | } 36 | location / { 37 | try_files $uri $uri/ /index.html; 38 | client_max_body_size 5m; 39 | } 40 | } 41 | upstream hspolls_server { 42 | server localhost:8000; 43 | } 44 | } 45 | ''; 46 | runNginx = pkgs.writeScriptBin "nginx-run" '' 47 | #! /bin/sh 48 | mkdir -p /tmp/logs 49 | ${pkgs.nginx}/bin/nginx -c ${nginxConf} -p /tmp 50 | ''; 51 | in runNginx 52 | -------------------------------------------------------------------------------- /db/schema.sql: -------------------------------------------------------------------------------- 1 | CREATE EXTENSION IF NOT EXISTS "uuid-ossp"; 2 | 3 | CREATE TABLE users ( 4 | id 5 | uuid 6 | DEFAULT uuid_generate_v4(), 7 | 8 | email 9 | text, 10 | 11 | -- The user's GitHub username, or NULL if they haven't authenticated with 12 | -- GitHub. Once set, may be overwritten if the user decides to authenticate 13 | -- as a different GitHub user (we only want to track/display one). 14 | github 15 | text, 16 | 17 | -- Send the user an email when a new poll is created? 18 | subscribed_to_poll_created 19 | boolean 20 | DEFAULT false, 21 | 22 | PRIMARY KEY (id), 23 | UNIQUE (email), 24 | UNIQUE (github) 25 | ); 26 | 27 | CREATE TABLE polls ( 28 | id 29 | uuid 30 | DEFAULT uuid_generate_v4(), 31 | 32 | created_at 33 | timestamp with time zone 34 | NOT NULL 35 | DEFAULT current_timestamp, 36 | 37 | duration 38 | interval 39 | NOT NULL, 40 | 41 | form 42 | jsonb 43 | NOT NULL, 44 | 45 | userId 46 | uuid, 47 | 48 | FOREIGN KEY (userId) REFERENCES users (id), 49 | PRIMARY KEY (id) 50 | ); 51 | 52 | CREATE TABLE poll_responses ( 53 | id 54 | uuid 55 | DEFAULT uuid_generate_v4(), 56 | 57 | created_at 58 | timestamp with time zone 59 | NOT NULL 60 | DEFAULT current_timestamp, 61 | 62 | pollId 63 | uuid 64 | NOT NULL, 65 | 66 | response 67 | jsonb 68 | NOT NULL, 69 | 70 | userId 71 | uuid, 72 | 73 | FOREIGN KEY (pollId) REFERENCES polls (id), 74 | FOREIGN KEY (userId) REFERENCES users (id), 75 | PRIMARY KEY (id) 76 | ); 77 | -------------------------------------------------------------------------------- /src/Hp/Worker/SendPollCreatedEmail.hs: -------------------------------------------------------------------------------- 1 | module Hp.Worker.SendPollCreatedEmail 2 | ( sendPollCreatedEmailWorker 3 | ) where 4 | 5 | import Hp.Eff.Await (AwaitEffect, await) 6 | import Hp.Eff.PersistUser (PersistUserEffect, 7 | getUserEmailsSubscribedToPollCreatedEvents) 8 | import Hp.Eff.Yield (YieldEffect, yield) 9 | import Hp.Email (Email(..), TransactionalEmail(..)) 10 | import Hp.Event.PollCreated (PollCreatedEvent) 11 | 12 | import Control.Effect 13 | 14 | 15 | sendPollCreatedEmailWorker :: 16 | ( Carrier sig m 17 | , Member (AwaitEffect PollCreatedEvent) sig 18 | , Member PersistUserEffect sig 19 | , Member (YieldEffect Email) sig 20 | ) 21 | => m void 22 | sendPollCreatedEmailWorker = 23 | forever $ do 24 | event :: PollCreatedEvent <- 25 | await 26 | 27 | emailAddresses :: Vector Text <- 28 | getUserEmailsSubscribedToPollCreatedEvents 29 | 30 | case handlePollCreatedEvent event emailAddresses of 31 | Nothing -> 32 | pure () 33 | 34 | Just email -> 35 | yield email 36 | 37 | handlePollCreatedEvent :: 38 | PollCreatedEvent 39 | -> Vector Text 40 | -> Maybe Email 41 | handlePollCreatedEvent event addresses = do 42 | guard (not (null addresses)) 43 | 44 | pure $ EmailTransactional TransactionalEmail 45 | { bcc = toListOf folded addresses 46 | , body = 47 | event ^. #poll . #key . Prelude.to show . packed <> " created" 48 | , from = "mitchellwrosen@gmail.com" 49 | , subject = "Poll created" 50 | } 51 | -------------------------------------------------------------------------------- /src/Hp/Eff/HttpSession/IO.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | 3 | module Hp.Eff.HttpSession.IO 4 | ( runHttpSessionIO 5 | ) where 6 | 7 | import Hp.Eff.HttpSession (HttpSessionEffect(..)) 8 | 9 | import Control.Effect.Carrier 10 | import Control.Effect.Interpret 11 | import Servant (AddHeader) 12 | import Servant.Auth.Server (CookieSettings, JWTSettings, SetCookie, ToJWT, 13 | acceptLogin) 14 | 15 | 16 | runHttpSessionIO :: 17 | ( Carrier sig m 18 | , MonadIO m -- Because of servant-auth-server... only need randomness >_< 19 | ) 20 | => CookieSettings 21 | -> JWTSettings 22 | -> InterpretC HttpSessionEffect m a 23 | -> m a 24 | runHttpSessionIO cookieSettings jwtSettings = 25 | runInterpret $ \case 26 | BeginHttpSession session request next -> 27 | doBeginHttpSession cookieSettings jwtSettings session request >>= next 28 | 29 | doBeginHttpSession :: 30 | ( AddHeader "Set-Cookie" SetCookie response0 response1 31 | , AddHeader "Set-Cookie" SetCookie response1 response2 32 | , MonadIO m 33 | , ToJWT session 34 | ) 35 | => CookieSettings 36 | -> JWTSettings 37 | -> session 38 | -> response0 39 | -> m response2 40 | doBeginHttpSession cookieSettings jwtSettings session response = 41 | liftIO (acceptLogin cookieSettings jwtSettings session) >>= \case 42 | Nothing -> 43 | -- TODO throw an error if acceptLogin fails (it won't, with valid JWTSettings) 44 | undefined 45 | 46 | Just applyCookies -> 47 | pure (applyCookies response) 48 | -------------------------------------------------------------------------------- /src/Hp/Eff/PersistPollAnswer.hs: -------------------------------------------------------------------------------- 1 | module Hp.Eff.PersistPollAnswer 2 | ( PersistPollAnswerEffect(..) 3 | , getPollAnswers 4 | , putPollAnswer 5 | ) where 6 | 7 | import Hp.Eff.FirstOrder (FirstOrderEffect(..)) 8 | import Hp.Entity (Entity) 9 | import Hp.Entity.Poll (PollId) 10 | import Hp.Entity.PollAnswer (PollAnswer) 11 | import Hp.Entity.User (UserId) 12 | import Hp.PollQuestionAnswer (PollQuestionAnswer) 13 | 14 | import Control.Effect 15 | import Control.Effect.Carrier 16 | 17 | 18 | data PersistPollAnswerEffect (m :: Type -> Type) (k :: Type) where 19 | GetPollAnswers :: 20 | PollId 21 | -> (Vector [PollQuestionAnswer] -> k) 22 | -> PersistPollAnswerEffect m k 23 | 24 | PutPollAnswer :: 25 | [PollQuestionAnswer] 26 | -> PollId 27 | -> Maybe UserId 28 | -> (Entity PollAnswer -> k) 29 | -> PersistPollAnswerEffect m k 30 | 31 | deriving stock (Functor) 32 | deriving (Effect, HFunctor) 33 | via (FirstOrderEffect PersistPollAnswerEffect) 34 | 35 | -- | Get all of the answers to a poll. 36 | getPollAnswers :: 37 | ( Carrier sig m 38 | , Member PersistPollAnswerEffect sig 39 | ) 40 | => PollId 41 | -> m (Vector [PollQuestionAnswer]) 42 | getPollAnswers pollId = 43 | send (GetPollAnswers pollId pure) 44 | 45 | -- | Insert a poll answer and return its id. 46 | putPollAnswer :: 47 | ( Carrier sig m 48 | , Member PersistPollAnswerEffect sig 49 | ) 50 | => [PollQuestionAnswer] 51 | -> PollId 52 | -> Maybe UserId 53 | -> m (Entity PollAnswer) 54 | putPollAnswer answers pollId userId = 55 | send (PutPollAnswer answers pollId userId pure) 56 | -------------------------------------------------------------------------------- /src/Hp/GitHub/API.hs: -------------------------------------------------------------------------------- 1 | module Hp.GitHub.API 2 | ( GitHubAPI(..) 3 | ) where 4 | 5 | import Hp.GitHub.AccessToken (GitHubAccessToken) 6 | import Hp.GitHub.ClientId (GitHubClientId) 7 | import Hp.GitHub.ClientSecret (GitHubClientSecret) 8 | import Hp.GitHub.Code (GitHubCode) 9 | import Hp.GitHub.PostLoginOauthAccessTokenResponse (GitHubPostLoginOauthAccessTokenResponse) 10 | import Hp.GitHub.Response (GitHubResponse) 11 | import Hp.GitHub.User (GitHubUser) 12 | 13 | import Servant.API 14 | import Servant.API.Generic 15 | 16 | 17 | data GitHubAPI route 18 | = GitHubAPI 19 | { -- | https://developer.github.com/v3/users/#get-the-authenticated-user 20 | gitHubGetUser 21 | :: route 22 | :- "user" 23 | :> Header' '[Required, Strict] "User-Agent" Text 24 | :> Header' '[Required, Strict] "Authorization" GitHubAccessToken 25 | :> Get '[JSON] GitHubUser 26 | 27 | -- | https://developer.github.com/apps/building-oauth-apps/authorizing-oauth-apps/#2-users-are-redirected-back-to-your-site-by-github 28 | , gitHubPostLoginOauthAccessToken 29 | :: route 30 | :- "login" 31 | :> "oauth" 32 | :> "access_token" 33 | :> QueryParam' '[Required, Strict] "client_id" GitHubClientId 34 | :> QueryParam' '[Required, Strict] "client_secret" GitHubClientSecret 35 | :> QueryParam' '[Required, Strict] "code" GitHubCode 36 | :> QueryParam' '[Optional, Strict] "redirect_uri" Text 37 | :> QueryParam' '[Optional, Strict] "state" Text 38 | :> Get '[JSON] (GitHubResponse GitHubPostLoginOauthAccessTokenResponse) 39 | } deriving stock (Generic) 40 | -------------------------------------------------------------------------------- /src/Hp/Handler/CreatePoll.hs: -------------------------------------------------------------------------------- 1 | module Hp.Handler.CreatePoll 2 | ( handleCreatePoll 3 | ) where 4 | 5 | import Hp.Eff.PersistPoll (PersistPollEffect, savePoll) 6 | import Hp.Eff.Throw (ThrowEffect, throw) 7 | import Hp.Eff.Yield (YieldEffect, yield) 8 | import Hp.Entity (Entity(..)) 9 | import Hp.Entity.Poll (Poll(..), PollId) 10 | import Hp.Entity.User (UserId) 11 | import Hp.Event.PollCreated (PollCreatedEvent(..)) 12 | import Hp.PollFormElement (arePollFormElementsValid) 13 | import Hp.RequestBody.CreatePoll (CreatePollRequestBody(..)) 14 | 15 | import Control.Effect 16 | import Prelude hiding (id) 17 | import Servant (ServerError, err400) 18 | import Servant.Auth.Server (AuthResult(..)) 19 | 20 | 21 | handleCreatePoll :: 22 | ( Carrier sig m 23 | , Member PersistPollEffect sig 24 | , Member (ThrowEffect ServerError) sig 25 | , Member (YieldEffect PollCreatedEvent) sig 26 | ) 27 | => AuthResult UserId 28 | -> CreatePollRequestBody 29 | -> m PollId 30 | handleCreatePoll authResult body = do 31 | validatePoll body 32 | 33 | poll :: Entity Poll <- 34 | savePoll 35 | (body ^. #duration) 36 | (body ^. #elements) 37 | userId 38 | 39 | yield PollCreatedEvent 40 | { poll = poll } 41 | 42 | pure (poll ^. #key) 43 | 44 | where 45 | userId :: Maybe UserId 46 | userId = do 47 | Authenticated id <- pure authResult 48 | pure id 49 | 50 | -- Validate a poll: 51 | -- 52 | -- * Duration is at least 1 minute 53 | -- * Questions are all valid 54 | validatePoll :: 55 | ( Carrier sig m 56 | , Member (ThrowEffect ServerError) sig 57 | ) 58 | => CreatePollRequestBody 59 | -> m () 60 | validatePoll body = do 61 | when ((body ^. #duration) < 60) (throw err400) 62 | when (not (arePollFormElementsValid (body ^. #elements))) (throw err400) 63 | -------------------------------------------------------------------------------- /src/Hp/Eff/DB.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | 3 | module Hp.Eff.DB 4 | ( DB(..) 5 | , DBC 6 | , runDBC 7 | , runDB 8 | ) where 9 | 10 | import Hp.Eff.FirstOrder (FirstOrderEffect(..)) 11 | import Hp.Eff.Throw (ThrowEffect, throw) 12 | 13 | import Control.Effect 14 | import Control.Effect.Carrier 15 | import Control.Effect.Reader 16 | import Control.Effect.Sum 17 | import Hasql.Transaction (Transaction) 18 | 19 | import qualified Hasql.Pool as Hasql 20 | import qualified Hasql.Session as Hasql (Session) 21 | import qualified Hasql.Transaction as Hasql (Transaction) 22 | import qualified Hasql.Transaction.Sessions as Hasql (IsolationLevel(..), Mode(..), transaction) 23 | 24 | data DB (m :: Type -> Type) (k :: Type) where 25 | RunDB :: 26 | Transaction a 27 | -> (a -> k) 28 | -> DB m k 29 | 30 | deriving (Effect, HFunctor) via (FirstOrderEffect DB) 31 | 32 | deriving instance Functor (DB m) 33 | 34 | runDB :: 35 | ( Carrier sig m 36 | , Member DB sig 37 | ) 38 | => Transaction a 39 | -> m a 40 | runDB sess = 41 | send (RunDB sess pure) 42 | 43 | newtype DBC m a 44 | = DBC 45 | { unDBC :: ReaderC Hasql.Pool m a 46 | } deriving newtype (Functor, Applicative, Monad, MonadIO) 47 | 48 | instance ( Carrier sig m 49 | , Member (ThrowEffect Hasql.UsageError) sig 50 | , MonadIO m 51 | ) => Carrier (DB :+: sig) (DBC m) where 52 | eff = DBC . \case 53 | L (RunDB sess k) -> do 54 | pool :: Hasql.Pool <- ask 55 | liftIO (Hasql.use pool (runTransaction sess)) >>= \case 56 | Left err -> throw err 57 | Right result -> unDBC (k result) 58 | R other -> eff (R (handleCoercible other)) 59 | 60 | where 61 | runTransaction :: 62 | Hasql.Transaction a 63 | -> Hasql.Session a 64 | runTransaction = 65 | Hasql.transaction Hasql.Serializable Hasql.Write 66 | 67 | runDBC :: forall m a. Hasql.Pool -> DBC m a -> m a 68 | runDBC pool = runReader pool . unDBC 69 | -------------------------------------------------------------------------------- /src/Hp/Entity/Poll.hs: -------------------------------------------------------------------------------- 1 | module Hp.Entity.Poll 2 | ( Poll(..) 3 | , EntityId(..) 4 | , PollId 5 | , pollIdDecoder 6 | , pollIdEncoder 7 | , pollQuestions 8 | , isPollExpired 9 | ) where 10 | 11 | import Hp.Eff.GetCurrentTime (GetCurrentTimeEffect, getCurrentTime) 12 | import Hp.Entity.User (UserId) 13 | import Hp.IsEntity (IsEntity(..)) 14 | import Hp.PollFormElement (PollFormElement(..)) 15 | import Hp.PollQuestion (PollQuestion) 16 | 17 | import Control.Effect 18 | import Data.Aeson (FromJSON, ToJSON) 19 | import Data.Time (DiffTime, NominalDiffTime, UTCTime, diffUTCTime) 20 | import Data.UUID (UUID) 21 | import Web.HttpApiData (FromHttpApiData) 22 | 23 | import qualified Hasql.Decoders as Decoder 24 | import qualified Hasql.Encoders as Encoder 25 | 26 | 27 | data Poll 28 | = Poll 29 | { created :: UTCTime 30 | , duration :: DiffTime 31 | , elements :: [PollFormElement] 32 | , userId :: Maybe UserId 33 | } deriving stock (Generic, Show) 34 | 35 | instance IsEntity Poll where 36 | newtype EntityId Poll 37 | = PollId { unPollId :: UUID } 38 | deriving stock (Show) 39 | deriving newtype (FromHttpApiData, FromJSON, ToJSON) 40 | 41 | type PollId 42 | = EntityId Poll 43 | 44 | pollIdDecoder :: Decoder.Value PollId 45 | pollIdDecoder = 46 | PollId <$> Decoder.uuid 47 | 48 | pollIdEncoder :: Encoder.Value PollId 49 | pollIdEncoder = 50 | coerce Encoder.uuid 51 | 52 | -- | Extract just the questions from a poll. 53 | pollQuestions :: 54 | Poll 55 | -> [PollQuestion] 56 | pollQuestions poll = 57 | [ question | QuestionElement question <- poll ^. #elements ] 58 | 59 | -- | Is this poll expired? 60 | isPollExpired :: 61 | ( Carrier sig m 62 | , Member GetCurrentTimeEffect sig 63 | ) 64 | => Poll 65 | -> m Bool 66 | isPollExpired poll = do 67 | now :: UTCTime <- 68 | getCurrentTime 69 | 70 | let 71 | elapsed :: NominalDiffTime 72 | elapsed = 73 | now `diffUTCTime` (poll ^. #created) 74 | 75 | pure (elapsed >= realToFrac (poll ^. #duration)) 76 | -------------------------------------------------------------------------------- /src/Hp/PollQuestionAnswer.hs: -------------------------------------------------------------------------------- 1 | module Hp.PollQuestionAnswer 2 | ( PollQuestionAnswer(..) 3 | , arePollQuestionAnswersValid 4 | , isPollQuestionAnswerValid 5 | ) where 6 | 7 | import Hp.PollQuestion (PollQuestion(..)) 8 | 9 | import Data.Aeson (FromJSON(..), ToJSON(..), Value, object, withObject, 10 | withText, (.:), (.=)) 11 | import Data.Aeson.Types (Parser) 12 | 13 | 14 | data PollQuestionAnswer 15 | = CheckboxAnswer [Bool] 16 | -- = RadioAnswer Natural -- 0-based index into question 17 | deriving stock (Show) 18 | 19 | instance FromJSON PollQuestionAnswer where 20 | parseJSON :: Value -> Parser PollQuestionAnswer 21 | parseJSON = 22 | withObject "PollQuestionAnswer" $ \o -> do 23 | type_ <- o .: "type" 24 | value <- o .: "value" 25 | 26 | withText 27 | "type" 28 | (\case 29 | "checkbox" -> 30 | parseCheckboxAnswer value 31 | 32 | s -> 33 | fail ("Unknown type: " ++ s ^. unpacked) 34 | ) 35 | type_ 36 | 37 | where 38 | parseCheckboxAnswer :: Value -> Parser PollQuestionAnswer 39 | parseCheckboxAnswer value = 40 | CheckboxAnswer <$> parseJSON value 41 | 42 | instance ToJSON PollQuestionAnswer where 43 | toJSON :: PollQuestionAnswer -> Value 44 | toJSON = \case 45 | CheckboxAnswer answers -> 46 | object 47 | [ "type" .= ("checkbox" :: Text) 48 | , "value" .= toJSON answers 49 | ] 50 | 51 | arePollQuestionAnswersValid :: 52 | [PollQuestion] 53 | -> [PollQuestionAnswer] 54 | -> Bool 55 | arePollQuestionAnswersValid questions answers = 56 | all (uncurry isPollQuestionAnswerValid) (zip questions answers) 57 | 58 | -- | Does this question/answer pair make sense? 59 | -- 60 | -- Precondition: question was already validated with isValidPollQuestion 61 | -- 62 | -- TODO gdp 63 | isPollQuestionAnswerValid :: PollQuestion -> PollQuestionAnswer -> Bool 64 | isPollQuestionAnswerValid question answer = 65 | case (question, answer) of 66 | (CheckboxQuestion _ xs, CheckboxAnswer ys) -> 67 | length xs == length ys 68 | -------------------------------------------------------------------------------- /src/Hp/Eff/GitHubAuth/Http.hs: -------------------------------------------------------------------------------- 1 | module Hp.Eff.GitHubAuth.Http 2 | ( runGitHubAuthHttp 3 | ) where 4 | 5 | import Hp.Eff.GitHubAuth (GitHubAuthEffect(..)) 6 | import Hp.Eff.HttpRequest (HttpRequestEffect) 7 | import Hp.Eff.Log (LogEffect, log) 8 | import Hp.Eff.Throw (ThrowEffect) 9 | import Hp.GitHub (gitHubGetUser, gitHubPostLoginOauthAccessToken) 10 | import Hp.GitHub.ClientId (GitHubClientId) 11 | import Hp.GitHub.ClientSecret (GitHubClientSecret) 12 | import Hp.GitHub.PostLoginOauthAccessTokenResponse (GitHubPostLoginOauthAccessTokenResponse) 13 | import Hp.GitHub.Response (GitHubResponse(..)) 14 | 15 | import Control.Effect 16 | import Control.Effect.Interpret 17 | 18 | import qualified Servant.Client as Servant (ClientError, Response) 19 | 20 | 21 | runGitHubAuthHttp :: 22 | ( Carrier sig m 23 | , Member HttpRequestEffect sig 24 | , Member LogEffect sig 25 | , Member (ThrowEffect Servant.ClientError) sig 26 | ) 27 | => GitHubClientId 28 | -> GitHubClientSecret 29 | -> InterpretC GitHubAuthEffect m a 30 | -> m a 31 | runGitHubAuthHttp clientId clientSecret = 32 | runInterpret $ \case 33 | GitHubAuth code next -> do 34 | result :: Either Servant.Response (GitHubResponse GitHubPostLoginOauthAccessTokenResponse) <- 35 | gitHubPostLoginOauthAccessToken 36 | clientId 37 | clientSecret 38 | code 39 | -- TODO type safe link, and get this from the environment 40 | (Just "http://localhost:8000/oauth/github") 41 | -- TODO send random state 42 | Nothing 43 | 44 | case result of 45 | Left response -> do 46 | log (show response ^. packed) 47 | next Nothing 48 | 49 | Right (GitHubResponseError err) -> do 50 | log (show err ^. packed) 51 | next Nothing 52 | 53 | Right (GitHubResponseSuccess response) -> 54 | gitHubGetUser (response ^. #access_token) >>= \case 55 | Left response -> do 56 | log (show response ^. packed) 57 | next Nothing 58 | 59 | Right user -> 60 | next (Just user) 61 | -------------------------------------------------------------------------------- /src/Hp/Eff/PersistUser.hs: -------------------------------------------------------------------------------- 1 | module Hp.Eff.PersistUser 2 | ( PersistUserEffect(..) 3 | , getUserById 4 | , getUserEmailsSubscribedToPollCreatedEvents 5 | , putUserByGitHubUser 6 | , setUserSubscription 7 | ) where 8 | 9 | import Hp.Eff.FirstOrder (FirstOrderEffect(..)) 10 | import Hp.Entity (Entity) 11 | import Hp.Entity.User (User, UserId) 12 | import Hp.GitHub.User (GitHubUser(..)) 13 | import Hp.Subscription (Subscription) 14 | 15 | import Control.Effect 16 | import Control.Effect.Carrier 17 | 18 | 19 | data PersistUserEffect (m :: Type -> Type) (k :: Type) where 20 | GetUserById :: 21 | UserId 22 | -> (Maybe (Entity User) -> k) 23 | -> PersistUserEffect m k 24 | 25 | GetUserEmailsSubscribedToPollCreatedEvents :: 26 | (Vector Text -> k) 27 | -> PersistUserEffect m k 28 | 29 | PutUserByGitHubUser :: 30 | GitHubUser 31 | -> (Entity User -> k) 32 | -> PersistUserEffect m k 33 | 34 | SetUserSubscription :: 35 | UserId 36 | -> Subscription 37 | -> k 38 | -> PersistUserEffect m k 39 | 40 | deriving stock (Functor) 41 | deriving (Effect, HFunctor) 42 | via (FirstOrderEffect PersistUserEffect) 43 | 44 | getUserById :: 45 | ( Carrier sig m 46 | , Member PersistUserEffect sig 47 | ) 48 | => UserId 49 | -> m (Maybe (Entity User)) 50 | getUserById userId = 51 | send (GetUserById userId pure) 52 | 53 | -- | Get all email addresses to blast with a "new poll was created" event. 54 | getUserEmailsSubscribedToPollCreatedEvents :: 55 | ( Carrier sig m 56 | , Member PersistUserEffect sig 57 | ) 58 | => m (Vector Text) 59 | getUserEmailsSubscribedToPollCreatedEvents = 60 | send (GetUserEmailsSubscribedToPollCreatedEvents pure) 61 | 62 | 63 | -- | Insert and return a user, given its GitHub user name and email address. If 64 | -- the user already exists, just returns it (updating email address if 65 | -- necessary). 66 | putUserByGitHubUser :: 67 | ( Carrier sig m 68 | , Member PersistUserEffect sig 69 | ) 70 | => GitHubUser 71 | -> m (Entity User) 72 | putUserByGitHubUser user = 73 | send (PutUserByGitHubUser user pure) 74 | 75 | -- | Set the user's email subscription settings. 76 | setUserSubscription :: 77 | ( Carrier sig m 78 | , Member PersistUserEffect sig 79 | ) 80 | => UserId 81 | -> Subscription 82 | -> m () 83 | setUserSubscription userId sub = 84 | send (SetUserSubscription userId sub (pure ())) 85 | -------------------------------------------------------------------------------- /src/Hp/Eff/Catch.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | 3 | module Hp.Eff.Catch 4 | ( CatchEffect(..) 5 | , catch 6 | , runCatch 7 | ) where 8 | 9 | import Hp.Eff.Throw (ThrowEffect(..)) 10 | 11 | import Control.Effect 12 | import Control.Effect.Carrier 13 | import Control.Effect.Sum 14 | 15 | import qualified Control.Effect.Error as Error 16 | 17 | 18 | data CatchEffect (e :: Type) (m :: Type -> Type) (k :: Type) where 19 | Catch :: 20 | m a 21 | -> (e -> m a) 22 | -> (a -> k) 23 | -> CatchEffect e m k 24 | 25 | deriving stock instance Functor (CatchEffect e m) 26 | 27 | instance Effect (CatchEffect e) where 28 | handle :: 29 | Functor f 30 | => f () 31 | -> (forall x. f (m x) -> n (f x)) 32 | -> CatchEffect e m (m a) 33 | -> CatchEffect e n (n (f a)) 34 | handle state handler (Catch action h next) = 35 | Catch 36 | (handler (action <$ state)) 37 | (handler . (<$ state) . h) 38 | (handler . fmap next) 39 | 40 | instance HFunctor (CatchEffect e) where 41 | hmap :: (forall x. m x -> n x) -> CatchEffect e m k -> CatchEffect e n k 42 | hmap f (Catch action handler next) = 43 | Catch (f action) (f . handler) next 44 | 45 | catch :: 46 | forall e m sig a. 47 | ( Carrier sig m 48 | , Member (CatchEffect e) sig 49 | ) 50 | => m a 51 | -> (e -> m a) 52 | -> m a 53 | catch action handler = 54 | send (Catch action handler pure) 55 | 56 | newtype CatchCarrier e m a 57 | = CatchCarrier { unCatchCarrier :: Error.ErrorC e m a } 58 | deriving newtype (Applicative, Functor, Monad) 59 | 60 | instance 61 | ( Carrier sig m 62 | , Effect sig 63 | ) 64 | => Carrier (CatchEffect e :+: ThrowEffect e :+: sig) (CatchCarrier e m) where 65 | 66 | eff :: 67 | (CatchEffect e :+: ThrowEffect e :+: sig) 68 | (CatchCarrier e m) 69 | (CatchCarrier e m a) 70 | -> CatchCarrier e m a 71 | eff = \case 72 | L (Catch action handler next) -> 73 | CatchCarrier $ 74 | Error.ErrorC $ 75 | runCatch action >>= \case 76 | Left err -> runCatch (handler err >>= next) 77 | Right result -> runCatch (next result) 78 | 79 | R (L (Throw err)) -> 80 | CatchCarrier (Error.throwError err) 81 | 82 | R (R other) -> 83 | CatchCarrier (eff (R (handleCoercible other))) 84 | 85 | runCatch :: 86 | CatchCarrier e m a 87 | -> m (Either e a) 88 | runCatch = 89 | Error.runError . unCatchCarrier 90 | -------------------------------------------------------------------------------- /src/Hp/Eff/HttpRequest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | 3 | module Hp.Eff.HttpRequest 4 | ( HttpRequestEffect(..) 5 | , httpRequest 6 | , fromServantClient 7 | ) where 8 | 9 | import Hp.Eff.FirstOrder (FirstOrderEffect(..)) 10 | import Hp.Eff.Throw (ThrowEffect, throw) 11 | 12 | import Control.Effect 13 | import Control.Effect.Carrier 14 | import Control.Monad.Free (Free(..)) 15 | 16 | import qualified Servant.Client.Core as Servant (BaseUrl, Request, Response) 17 | import qualified Servant.Client.Free as Servant 18 | 19 | 20 | -- TODO more accurate exception than SomeException 21 | data HttpRequestEffect (m :: Type -> Type) (k :: Type) where 22 | HttpRequest :: 23 | Servant.BaseUrl 24 | -> Servant.Request 25 | -> (Either Servant.Response Servant.Response -> k) 26 | -> HttpRequestEffect m k 27 | 28 | deriving stock (Functor) 29 | deriving (Effect, HFunctor) 30 | via (FirstOrderEffect HttpRequestEffect) 31 | 32 | 33 | httpRequest :: 34 | ( Carrier sig m 35 | , Member HttpRequestEffect sig 36 | ) 37 | => Servant.BaseUrl 38 | -> Servant.Request 39 | -> m (Either Servant.Response Servant.Response) 40 | httpRequest baseUrl request = 41 | send (HttpRequest baseUrl request pure) 42 | 43 | -- | Helper function for translating servant-generated client calls into the 44 | -- HttpRequestEffect effect. 45 | -- 46 | -- Assumes (unsafely) that servant calls are *always* structured as containing a 47 | -- request node at the top (Free RunRequest) followed by either a success node 48 | -- (Pure) or a failure node (Free Throw). 49 | fromServantClient :: 50 | ( Carrier sig m 51 | , Member HttpRequestEffect sig 52 | , Member (ThrowEffect Servant.ClientError) sig 53 | ) 54 | => Servant.BaseUrl 55 | -> Free Servant.ClientF a 56 | -> m (Either Servant.Response a) 57 | fromServantClient baseUrl = \case 58 | Free (Servant.RunRequest request next) -> 59 | httpRequest baseUrl request >>= \case 60 | Left response -> 61 | pure (Left response) 62 | 63 | Right response -> 64 | case next response of 65 | Pure result -> 66 | pure (Right result) 67 | 68 | Free (Servant.Throw clientError) -> 69 | case clientError of 70 | Servant.FailureResponse _ response -> 71 | pure (Left response) 72 | 73 | _ -> 74 | throw clientError 75 | 76 | Free Servant.RunRequest{} -> 77 | impossible 78 | 79 | Pure _ -> impossible 80 | Free Servant.Throw{} -> impossible 81 | -------------------------------------------------------------------------------- /src/Hp/Eff/HttpRequest/IO.hs: -------------------------------------------------------------------------------- 1 | -- | The IO carrier for the http request effect; i.e. the one that actually 2 | -- performs requests. 3 | 4 | {-# LANGUAGE UndecidableInstances #-} 5 | 6 | module Hp.Eff.HttpRequest.IO 7 | ( runHttpRequestIO 8 | , HttpConnectionError(..) 9 | ) where 10 | 11 | import Hp.Eff.HttpRequest (HttpRequestEffect(..)) 12 | import Hp.Eff.Throw (ThrowEffect, throw) 13 | 14 | import Control.Effect 15 | import Control.Effect.Interpret 16 | import Control.Exception.Safe (tryAny) 17 | 18 | import qualified Network.HTTP.Client as Http 19 | import qualified Servant.Client as Servant 20 | import qualified Servant.Client.Core as Servant (Request) 21 | import qualified Servant.Client.Internal.HttpClient as Servant (performRequest) 22 | 23 | 24 | newtype HttpConnectionError 25 | = HttpConnectionError SomeException 26 | deriving stock (Show) 27 | 28 | -- | Run HTTP requests in IO using the provided HTTP manager. Truly unexpected 29 | -- client errors (due to decoding failures, etc) are thrown, but negative 30 | -- responses from the server are not. 31 | runHttpRequestIO :: 32 | ( Carrier sig m 33 | , Member (ThrowEffect HttpConnectionError) sig 34 | , Member (ThrowEffect Servant.ClientError) sig 35 | , MonadIO m 36 | ) 37 | => Http.Manager 38 | -> InterpretC HttpRequestEffect m a 39 | -> m a 40 | runHttpRequestIO manager = 41 | runInterpret $ \case 42 | HttpRequest baseUrl request next -> 43 | doHttpRequest manager baseUrl request >>= next 44 | 45 | doHttpRequest :: 46 | ( Carrier sig m 47 | , Member (ThrowEffect HttpConnectionError) sig 48 | , Member (ThrowEffect Servant.ClientError) sig 49 | , MonadIO m 50 | ) 51 | => Http.Manager 52 | -> Servant.BaseUrl 53 | -> Servant.Request 54 | -> m (Either Servant.Response Servant.Response) 55 | doHttpRequest manager baseUrl request = 56 | liftIO (tryAny doRequest) >>= \case 57 | Left ex -> 58 | throw (HttpConnectionError ex) 59 | 60 | Right (Left (Servant.FailureResponse _ response)) -> 61 | pure (Left response) 62 | 63 | Right (Left clientError) -> 64 | throw clientError 65 | 66 | Right (Right response) -> 67 | pure (Right response) 68 | 69 | where 70 | doRequest :: IO (Either Servant.ClientError Servant.Response) 71 | doRequest = 72 | Servant.runClientM 73 | (Servant.performRequest request) 74 | Servant.ClientEnv 75 | { Servant.manager = manager 76 | , Servant.baseUrl = baseUrl 77 | , Servant.cookieJar = Nothing 78 | } 79 | -------------------------------------------------------------------------------- /src/Prelude.hs: -------------------------------------------------------------------------------- 1 | module Prelude 2 | ( error 3 | , impossible 4 | , undefined 5 | , module X 6 | ) where 7 | 8 | import Control.Applicative as X ((<|>)) 9 | import Control.Category as X ((>>>)) 10 | import Control.Exception.Safe as X (SomeException, throwIO) 11 | import Control.Lens as X (Fold, Getter, Lens, Lens', Traversal, 12 | Traversal', at, each, foldMapOf, folded, 13 | foldlOf, foldrOf, ix, mapped, over, 14 | preview, re, review, reviews, set, 15 | strict, to, toListOf, uncons, view, 16 | (%~), (.~), (^.), (^..), (^?), (^?!), 17 | _1, _2, _3, _4, _5, _Just, _Left, 18 | _Nothing, _Right, _head, _init, _last, 19 | _tail) 20 | import Control.Monad as X (forever, guard, unless, when) 21 | import Control.Monad.IO.Class as X 22 | import Data.ByteString as X (ByteString) 23 | import Data.ByteString.Lens as X (packedBytes, packedChars) 24 | import Data.Coerce as X (Coercible, coerce) 25 | import Data.Foldable as X (asum, fold, for_) 26 | import Data.Function as X (fix, (&)) 27 | import Data.Functor as X (void) 28 | import Data.Functor.Contravariant as X ((>$<)) 29 | import Data.Generics.Labels as X () 30 | import Data.Generics.Product as X (HasType, typed) 31 | import Data.Kind as X (Type) 32 | import Data.Sequence as X (Seq) 33 | import Data.Text as X (Text) 34 | import Data.Text.Lens as X (builder, packed, text, unpacked, _Text) 35 | import Data.Text.Strict.Lens as X (utf8) 36 | import Data.Traversable as X (for) 37 | import Data.Vector as X (Vector) 38 | import Data.Void as X (Void, absurd) 39 | import Debug.Trace as X (traceShowM) 40 | import GHC.Generics as X (Generic) 41 | import Numeric.Natural as X (Natural) 42 | import PreludeFromBase as X hiding (error, log, undefined) 43 | 44 | import qualified PreludeFromBase 45 | 46 | error :: [Char] -> a 47 | error = 48 | PreludeFromBase.error 49 | {-# WARNING error "error" #-} 50 | 51 | impossible :: a 52 | impossible = 53 | PreludeFromBase.error "impossible" 54 | 55 | undefined :: a 56 | undefined = 57 | PreludeFromBase.undefined 58 | {-# WARNING undefined "undefined" #-} 59 | -------------------------------------------------------------------------------- /src/Hp/API.hs: -------------------------------------------------------------------------------- 1 | module Hp.API 2 | ( API(..) 3 | ) where 4 | 5 | import Hp.Entity.Poll (PollId) 6 | import Hp.Entity.User (UserId) 7 | import Hp.GitHub.Code (GitHubCode) 8 | import Hp.RequestBody.AnswerPoll (AnswerPollRequestBody) 9 | import Hp.RequestBody.CreatePoll (CreatePollRequestBody) 10 | import Hp.RequestBody.Subscribe (SubscribeRequestBody) 11 | import Hp.ResponseBody.GetPoll (GetPollResponseBody) 12 | import Hp.UserProfile (UserProfile) 13 | 14 | import Servant 15 | import Servant.API.Generic 16 | import Servant.Auth (Auth, Cookie) 17 | import Servant.Auth.Server (SetCookie) 18 | import Servant.HTML.Blaze 19 | 20 | import qualified Text.Blaze.Html as Blaze 21 | 22 | 23 | data API route 24 | = API 25 | { -- | Answer a poll. 26 | answerPollRoute 27 | :: route 28 | :- Auth '[Cookie] UserId 29 | :> "poll" 30 | :> Capture "PollId" PollId 31 | :> ReqBody '[JSON] AnswerPollRequestBody 32 | :> Post '[JSON] NoContent 33 | 34 | -- | Create a poll. 35 | , createPollRoute 36 | :: route 37 | :- Auth '[Cookie] UserId 38 | :> "poll" 39 | :> ReqBody '[JSON] CreatePollRequestBody 40 | :> Post '[JSON] PollId 41 | 42 | -- | Get Prometheus metrics. 43 | , getMetricsRoute 44 | :: route 45 | :- "metrics" 46 | :> Get '[PlainText] Text 47 | 48 | , getPollRoute 49 | :: route 50 | :- "poll" 51 | :> Capture "PollId" PollId 52 | :> Get '[JSON] GetPollResponseBody 53 | 54 | , getRootRoute 55 | :: route 56 | :- Auth '[Cookie] UserId 57 | :> Get '[HTML] Blaze.Html 58 | 59 | , getUserProfileRoute 60 | :: route 61 | :- Auth '[Cookie] UserId 62 | :> "profile" 63 | :> Get '[JSON] UserProfile 64 | 65 | -- | Callback URL used for GitHub OAuth. 66 | , gitHubOauthCallbackRoute 67 | :: route 68 | :- "oauth" 69 | :> "github" 70 | :> QueryParam' '[Required, Strict] "code" GitHubCode 71 | -- TODO required "state" query param 72 | -- TODO just returning html for now, but should redirect 73 | :> Verb 74 | 'GET 75 | 302 76 | '[HTML] 77 | (Headers 78 | '[ Header "Location" Text 79 | , Header "Set-Cookie" SetCookie 80 | , Header "Set-Cookie" SetCookie 81 | ] 82 | NoContent) 83 | 84 | -- | Adjust subscription settings. 85 | , subscribeRoute 86 | :: route 87 | :- Auth '[Cookie] UserId 88 | :> "subscribe" 89 | :> ReqBody '[JSON] SubscribeRequestBody 90 | :> Post '[JSON] NoContent 91 | } deriving stock (Generic) 92 | -------------------------------------------------------------------------------- /src/Hp/Eff/PersistPoll/DB.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | 3 | module Hp.Eff.PersistPoll.DB 4 | ( runPersistPollDB 5 | ) where 6 | 7 | import Hp.Eff.DB 8 | import Hp.Eff.PersistPoll (PersistPollEffect(..)) 9 | import Hp.Entity (Entity(..)) 10 | import Hp.Entity.Poll 11 | import Hp.Entity.User (UserId, userIdDecoder, userIdEncoder) 12 | import Hp.Hasql (statement) 13 | import Hp.PollFormElement (PollFormElement) 14 | 15 | import Control.Effect 16 | import Control.Effect.Interpret 17 | import Data.Aeson (eitherDecodeStrict, toJSON) 18 | import Data.Time (DiffTime) 19 | 20 | import qualified Hasql.Decoders as Decoder 21 | import qualified Hasql.Encoders as Encoder 22 | 23 | 24 | runPersistPollDB :: 25 | ( Carrier sig m 26 | , Member DB sig 27 | ) 28 | => InterpretC PersistPollEffect m a 29 | -> m a 30 | runPersistPollDB = 31 | runInterpret $ \case 32 | GetPoll pollId next -> 33 | doGetPoll pollId >>= next 34 | 35 | SavePoll duration elements userId next -> 36 | doSavePoll duration elements userId >>= next 37 | 38 | doGetPoll :: 39 | ( Carrier sig m 40 | , Member DB sig 41 | ) 42 | => PollId 43 | -> m (Maybe (Entity Poll)) 44 | doGetPoll pollId = 45 | runDB $ 46 | statement 47 | "SELECT created_at, duration, form, userId FROM polls WHERE id = $1" 48 | pollId 49 | (Encoder.param pollIdEncoder) 50 | (Decoder.rowMaybe 51 | (do 52 | created <- Decoder.column Decoder.timestamptz 53 | duration <- Decoder.column Decoder.interval 54 | elements <- 55 | Decoder.column 56 | (Decoder.jsonbBytes (over _Left (view packed) . eitherDecodeStrict)) 57 | userId <- Decoder.nullableColumn userIdDecoder 58 | pure (Entity pollId Poll{..}))) 59 | 60 | doSavePoll :: 61 | ( Carrier sig m 62 | , Member DB sig 63 | ) 64 | => DiffTime 65 | -> [PollFormElement] 66 | -> Maybe UserId 67 | -> m (Entity Poll) 68 | doSavePoll duration elements userId = 69 | runDB $ 70 | statement 71 | "INSERT INTO polls (duration, form, userId) VALUES ($1, $2, $3) RETURNING created_at, id" 72 | (duration, elements, userId) 73 | (fold 74 | [ view _1 >$< Encoder.param Encoder.interval 75 | , toJSON . view _2 >$< Encoder.param Encoder.jsonb 76 | , view _3 >$< Encoder.nullableParam userIdEncoder 77 | ]) 78 | (Decoder.singleRow 79 | (do 80 | created <- Decoder.column Decoder.timestamptz 81 | pollId <- Decoder.column pollIdDecoder 82 | pure Entity 83 | { key = pollId 84 | , value = 85 | Poll 86 | { created = created 87 | , duration = duration 88 | , elements = elements 89 | , userId = userId 90 | } 91 | })) 92 | -------------------------------------------------------------------------------- /src/Hp/Eff/PersistPollAnswer/DB.hs: -------------------------------------------------------------------------------- 1 | -- | Real database carrier for the PersistPollAnswer effect. 2 | 3 | {-# LANGUAGE UndecidableInstances #-} 4 | 5 | module Hp.Eff.PersistPollAnswer.DB 6 | ( runPersistPollAnswerDB 7 | ) where 8 | 9 | import Hp.Eff.DB (DB, runDB) 10 | import Hp.Eff.PersistPollAnswer (PersistPollAnswerEffect(..)) 11 | import Hp.Entity (Entity(..)) 12 | import Hp.Entity.Poll (PollId, pollIdEncoder) 13 | import Hp.Entity.PollAnswer (PollAnswer(..), pollAnswerIdDecoder) 14 | import Hp.Entity.User (UserId, userIdEncoder) 15 | import Hp.Hasql (statement) 16 | import Hp.PollQuestionAnswer (PollQuestionAnswer) 17 | 18 | import Control.Effect 19 | import Control.Effect.Interpret 20 | import Data.Aeson (eitherDecodeStrict, toJSON) 21 | 22 | import qualified Hasql.Decoders as Decoder 23 | import qualified Hasql.Encoders as Encoder 24 | 25 | 26 | runPersistPollAnswerDB :: 27 | ( Carrier sig m 28 | , Member DB sig 29 | ) 30 | => InterpretC PersistPollAnswerEffect m a 31 | -> m a 32 | runPersistPollAnswerDB = 33 | runInterpret $ \case 34 | GetPollAnswers pollId next -> 35 | doGetPollAnswers pollId >>= next 36 | 37 | PutPollAnswer answers pollId userId next -> 38 | doPutPollAnswer answers pollId userId >>= next 39 | 40 | doGetPollAnswers :: 41 | ( Carrier sig m 42 | , Member DB sig 43 | ) 44 | => PollId 45 | -> m (Vector [PollQuestionAnswer]) 46 | doGetPollAnswers pollId = 47 | runDB $ 48 | statement 49 | "SELECT response FROM poll_responses WHERE pollId = $1" 50 | pollId 51 | (Encoder.param pollIdEncoder) 52 | (Decoder.rowVector 53 | (Decoder.column 54 | (Decoder.jsonbBytes (over _Left (view packed) . eitherDecodeStrict)))) 55 | 56 | doPutPollAnswer :: 57 | ( Carrier sig m 58 | , Member DB sig 59 | ) 60 | => [PollQuestionAnswer] 61 | -> PollId 62 | -> Maybe UserId 63 | -> m (Entity PollAnswer) 64 | doPutPollAnswer answers pollId userId = 65 | runDB $ 66 | statement 67 | "INSERT INTO poll_responses (pollId, response, userId) VALUES ($1, $2, $3) RETURNING id, created_at" 68 | (pollId, answers, userId) 69 | (fold 70 | [ view _1 >$< Encoder.param pollIdEncoder 71 | , toJSON . view _2 >$< Encoder.param Encoder.jsonb 72 | , view _3 >$< Encoder.nullableParam userIdEncoder 73 | ]) 74 | (Decoder.singleRow 75 | (do 76 | pollAnswerId <- Decoder.column pollAnswerIdDecoder 77 | created <- Decoder.column Decoder.timestamptz 78 | pure Entity 79 | { key = pollAnswerId 80 | , value = 81 | PollAnswer 82 | { answers = answers 83 | , created = created 84 | , pollId = pollId 85 | , userId = userId 86 | } 87 | })) 88 | -------------------------------------------------------------------------------- /src/Hp/Handler/AnswerPoll.hs: -------------------------------------------------------------------------------- 1 | module Hp.Handler.AnswerPoll 2 | ( handleAnswerPoll 3 | ) where 4 | 5 | import Hp.Eff.GetCurrentTime (GetCurrentTimeEffect) 6 | import Hp.Eff.PersistPoll (PersistPollEffect, getPoll) 7 | import Hp.Eff.PersistPollAnswer (PersistPollAnswerEffect, putPollAnswer) 8 | import Hp.Eff.Throw (ThrowEffect, throw) 9 | import Hp.Eff.Yield (YieldEffect, yield) 10 | import Hp.Entity (Entity(..)) 11 | import Hp.Entity.Poll (PollId, isPollExpired, pollQuestions) 12 | import Hp.Entity.PollAnswer (PollAnswer(..)) 13 | import Hp.Entity.User (UserId) 14 | import Hp.Event.PollAnswered (PollAnsweredEvent(..)) 15 | import Hp.PollQuestionAnswer (PollQuestionAnswer, 16 | arePollQuestionAnswersValid) 17 | import Hp.RequestBody.AnswerPoll (AnswerPollRequestBody(..)) 18 | 19 | import Control.Effect 20 | import Servant (NoContent(..), ServerError, err400, err403, err404) 21 | import Servant.Auth.Server (AuthResult(..)) 22 | 23 | 24 | handleAnswerPoll :: 25 | ( Carrier sig m 26 | , Member GetCurrentTimeEffect sig 27 | , Member PersistPollEffect sig 28 | , Member PersistPollAnswerEffect sig 29 | , Member (ThrowEffect ServerError) sig 30 | , Member (YieldEffect PollAnsweredEvent) sig 31 | ) 32 | => AuthResult UserId 33 | -> PollId 34 | -> AnswerPollRequestBody 35 | -> m NoContent 36 | handleAnswerPoll authResult pollId body = 37 | validateAnswerPoll pollId (body ^. #answers) >>= \case 38 | Left PollDoesNotExist -> 39 | throw err404 40 | 41 | Left PollIsExpired -> 42 | throw err403 43 | 44 | Left QuestionsAreInvalid -> 45 | throw err400 46 | 47 | Right () -> do 48 | pollAnswer :: Entity PollAnswer <- 49 | putPollAnswer 50 | (body ^. #answers) 51 | pollId 52 | userId 53 | 54 | yield PollAnsweredEvent 55 | { answer = pollAnswer } 56 | 57 | pure NoContent 58 | 59 | where 60 | userId :: Maybe UserId 61 | userId = do 62 | Authenticated id <- pure authResult 63 | pure id 64 | 65 | 66 | data AnswerPollError 67 | = PollDoesNotExist 68 | | PollIsExpired 69 | | QuestionsAreInvalid 70 | 71 | validateAnswerPoll :: 72 | ( Carrier sig m 73 | , Member GetCurrentTimeEffect sig 74 | , Member PersistPollEffect sig 75 | ) 76 | => PollId 77 | -> [PollQuestionAnswer] 78 | -> m (Either AnswerPollError ()) 79 | validateAnswerPoll pollId answers = 80 | getPoll pollId >>= \case 81 | Nothing -> 82 | pure (Left PollDoesNotExist) 83 | 84 | Just poll -> do 85 | expired :: Bool <- 86 | isPollExpired (poll ^. #value) 87 | 88 | let 89 | valid :: Bool 90 | valid = 91 | arePollQuestionAnswersValid (pollQuestions (poll ^. #value)) answers 92 | 93 | pure $ 94 | case (expired, valid) of 95 | (True, _) -> Left PollIsExpired 96 | (_, False) -> Left QuestionsAreInvalid 97 | _ -> Right () 98 | -------------------------------------------------------------------------------- /src/Hp/Eff/SendEmail/AmazonSES.hs: -------------------------------------------------------------------------------- 1 | module Hp.Eff.SendEmail.AmazonSES 2 | ( runSendEmailAmazonSES 3 | ) where 4 | 5 | import Hp.Eff.Log (LogEffect, log) 6 | import Hp.Eff.SendEmail (SendEmailEffect(..)) 7 | import Hp.Email (Email(..)) 8 | 9 | import Control.Effect 10 | import Control.Effect.Interpret 11 | import Control.Exception.Safe (try) 12 | import Control.Monad.Trans.Resource (runResourceT) 13 | 14 | import qualified Data.List as List 15 | import qualified Network.AWS as Aws 16 | import qualified Network.AWS.SES.SendEmail as Aws 17 | import qualified Network.AWS.SES.Types as Aws 18 | 19 | 20 | runSendEmailAmazonSES :: 21 | ( Carrier sig m 22 | , Member LogEffect sig 23 | , MonadIO m 24 | ) 25 | => Aws.Env 26 | -> InterpretC SendEmailEffect m a 27 | -> m a 28 | runSendEmailAmazonSES env = 29 | runInterpret $ \case 30 | SendEmail email next -> do 31 | doSendEmail env email 32 | next 33 | 34 | doSendEmail :: 35 | ( Carrier sig m 36 | , Member LogEffect sig 37 | , MonadIO m 38 | ) 39 | => Aws.Env 40 | -> Email 41 | -> m () 42 | doSendEmail env email = 43 | case email of 44 | EmailPersonal{} -> 45 | doSendEmail_ env email 46 | 47 | -- 50 recipients at a time 48 | EmailTransactional email -> 49 | (`fix` email) $ \loop email -> 50 | case List.splitAt 50 (email ^. #bcc) of 51 | (_, []) -> 52 | doSendEmail_ env (EmailTransactional email) 53 | 54 | (xs, ys) -> do 55 | doSendEmail_ env (EmailTransactional (email & #bcc .~ xs)) 56 | loop (email & #bcc .~ ys) 57 | 58 | -- Precondition: email has <= 50 recipients 59 | doSendEmail_ :: 60 | ( Carrier sig m 61 | , Member LogEffect sig 62 | , MonadIO m 63 | ) 64 | => Aws.Env 65 | -> Email 66 | -> m () 67 | doSendEmail_ env email = 68 | liftIO (try @_ @Aws.Error (runResourceT (Aws.runAWS env (Aws.send request)))) >>= \case 69 | Left ex -> 70 | log (show ex ^. packed) 71 | 72 | Right response -> 73 | case response ^. Aws.sersResponseStatus of 74 | 200 -> 75 | pure () 76 | 77 | _ -> 78 | log (show response ^. packed) 79 | 80 | where 81 | request :: Aws.SendEmail 82 | request = 83 | case email of 84 | EmailPersonal email -> 85 | Aws.sendEmail 86 | (email ^. #from) 87 | (Aws.destination 88 | & Aws.dToAddresses .~ [email ^. #to]) 89 | (Aws.message 90 | (Aws.content (email ^. #subject)) 91 | (Aws.body 92 | & Aws.bText .~ Just (Aws.content (email ^. #body)))) 93 | 94 | EmailTransactional email -> 95 | Aws.sendEmail 96 | (email ^. #from) 97 | (Aws.destination 98 | & Aws.dBCCAddresses .~ email ^. #bcc) 99 | (Aws.message 100 | (Aws.content (email ^. #subject)) 101 | (Aws.body 102 | & Aws.bText .~ Just (Aws.content (email ^. #body)))) 103 | -------------------------------------------------------------------------------- /src/Hp/GitHub.hs: -------------------------------------------------------------------------------- 1 | module Hp.GitHub 2 | ( gitHubGetUser 3 | , gitHubPostLoginOauthAccessToken 4 | ) where 5 | 6 | import Hp.Eff.HttpRequest (HttpRequestEffect, 7 | fromServantClient) 8 | import Hp.Eff.Throw (ThrowEffect) 9 | import Hp.GitHub.AccessToken (GitHubAccessToken) 10 | import Hp.GitHub.API (GitHubAPI) 11 | import Hp.GitHub.ClientId (GitHubClientId(..)) 12 | import Hp.GitHub.ClientSecret (GitHubClientSecret) 13 | import Hp.GitHub.Code (GitHubCode) 14 | import Hp.GitHub.PostLoginOauthAccessTokenResponse (GitHubPostLoginOauthAccessTokenResponse) 15 | import Hp.GitHub.Response (GitHubResponse) 16 | import Hp.GitHub.User (GitHubUser) 17 | 18 | import qualified Hp.GitHub.API as API 19 | 20 | import Control.Effect 21 | import Control.Monad.Free (Free(..)) 22 | 23 | import qualified Servant.Client as Servant 24 | import qualified Servant.Client.Free as Servant 25 | import qualified Servant.Client.Generic as Servant 26 | 27 | 28 | baseUrl :: Servant.BaseUrl 29 | baseUrl = 30 | Servant.BaseUrl 31 | { Servant.baseUrlScheme = Servant.Https 32 | , Servant.baseUrlHost = "github.com" 33 | , Servant.baseUrlPort = 443 34 | , Servant.baseUrlPath = "" 35 | } 36 | 37 | apiBaseUrl :: Servant.BaseUrl 38 | apiBaseUrl = 39 | Servant.BaseUrl 40 | { Servant.baseUrlScheme = Servant.Https 41 | , Servant.baseUrlHost = "api.github.com" 42 | , Servant.baseUrlPort = 443 43 | , Servant.baseUrlPath = "" 44 | } 45 | 46 | userAgent :: Text 47 | userAgent = 48 | "hspolls" 49 | 50 | 51 | -------------------------------------------------------------------------------- 52 | -- Internal servant-generated client 53 | -------------------------------------------------------------------------------- 54 | 55 | servantClient :: GitHubAPI (Servant.AsClientT (Free Servant.ClientF)) 56 | servantClient = 57 | Servant.genericClient 58 | 59 | 60 | -------------------------------------------------------------------------------- 61 | -- Cleaned up client API 62 | -------------------------------------------------------------------------------- 63 | 64 | gitHubGetUser :: 65 | ( Carrier sig m 66 | , Member HttpRequestEffect sig 67 | , Member (ThrowEffect Servant.ClientError) sig 68 | ) 69 | => GitHubAccessToken 70 | -> m (Either Servant.Response GitHubUser) 71 | gitHubGetUser accessToken = 72 | fromServantClient 73 | apiBaseUrl 74 | (API.gitHubGetUser 75 | servantClient 76 | userAgent 77 | accessToken) 78 | 79 | gitHubPostLoginOauthAccessToken :: 80 | ( Carrier sig m 81 | , Member HttpRequestEffect sig 82 | , Member (ThrowEffect Servant.ClientError) sig 83 | ) 84 | => GitHubClientId 85 | -> GitHubClientSecret 86 | -> GitHubCode 87 | -> Maybe Text 88 | -> Maybe Text 89 | -> m (Either Servant.Response (GitHubResponse GitHubPostLoginOauthAccessTokenResponse)) 90 | gitHubPostLoginOauthAccessToken clientId clientSecret code redirectUri state = 91 | fromServantClient 92 | baseUrl 93 | (API.gitHubPostLoginOauthAccessToken 94 | servantClient 95 | clientId 96 | clientSecret 97 | code 98 | redirectUri 99 | state) 100 | -------------------------------------------------------------------------------- /src/Hp/PollFormElement.hs: -------------------------------------------------------------------------------- 1 | module Hp.PollFormElement 2 | ( PollFormElement(..) 3 | , arePollFormElementsValid 4 | ) where 5 | 6 | import Hp.PollQuestion (PollQuestion(..), isPollQuestionValid) 7 | 8 | import Data.Aeson (FromJSON(..), ToJSON(..), Value(..), object, 9 | withObject, withText, (.:), (.=)) 10 | import Data.Aeson.Types (Parser) 11 | 12 | 13 | -- TODO proper markdown type 14 | newtype Markdown 15 | = Markdown Text 16 | deriving newtype (FromJSON, Show, ToJSON) 17 | 18 | data PollFormElement 19 | = MarkdownElement Markdown 20 | | QuestionElement PollQuestion 21 | deriving stock (Generic, Show) 22 | 23 | instance FromJSON PollFormElement where 24 | parseJSON :: Value -> Parser PollFormElement 25 | parseJSON = 26 | withObject "PollFormElement" $ \o -> do 27 | type_ <- o .: "type" 28 | value <- o .: "value" 29 | 30 | withText 31 | "type" 32 | (\case 33 | "checkbox" -> 34 | parseCheckboxElement value 35 | 36 | "markdown" -> 37 | parseMarkdownElement value 38 | 39 | s -> 40 | fail ("Unknown type: " ++ s ^. unpacked) 41 | ) 42 | type_ 43 | 44 | where 45 | parseCheckboxElement :: Value -> Parser PollFormElement 46 | parseCheckboxElement = 47 | withObject "checkbox" $ \o -> 48 | QuestionElement <$> 49 | (CheckboxQuestion 50 | <$> o .: "header" 51 | <*> o .: "options") 52 | 53 | parseMarkdownElement :: Value -> Parser PollFormElement 54 | parseMarkdownElement value = 55 | MarkdownElement <$> parseJSON value 56 | 57 | instance ToJSON PollFormElement where 58 | toJSON :: PollFormElement -> Value 59 | toJSON = \case 60 | MarkdownElement markdown -> 61 | object 62 | [ "type" .= String "markdown" 63 | , "value" .= markdown 64 | ] 65 | 66 | QuestionElement (CheckboxQuestion header options) -> 67 | object 68 | [ "type" .= String "checkbox" 69 | , "value" .= 70 | object 71 | [ "header" .= header 72 | , "options" .= options 73 | ] 74 | ] 75 | 76 | -- | Validate a list of form elements: 77 | -- 78 | -- * There's at least one question 79 | -- * There aren't two markdown elements in a row 80 | -- * Elements are all individually valid 81 | arePollFormElementsValid :: [PollFormElement] -> Bool 82 | arePollFormElementsValid elements = 83 | and 84 | [ atLeastOneQuestion 85 | , notTwoConsecutiveMarkdown 86 | , all isPollFormElementValid elements 87 | ] 88 | 89 | where 90 | atLeastOneQuestion :: Bool 91 | atLeastOneQuestion = 92 | not (null [ () | QuestionElement{} <- elements ]) 93 | 94 | notTwoConsecutiveMarkdown :: Bool 95 | notTwoConsecutiveMarkdown = 96 | null 97 | [ () | (MarkdownElement{}, MarkdownElement{}) <- consecutive elements ] 98 | where 99 | consecutive :: [a] -> [(a, a)] 100 | consecutive = \case 101 | [] -> [] 102 | _:[] -> [] 103 | x:y:ys -> (x, y) : consecutive (y:ys) 104 | 105 | -- | Validate a single form element 106 | isPollFormElementValid :: PollFormElement -> Bool 107 | isPollFormElementValid = \case 108 | MarkdownElement markdown -> 109 | isMarkdownValid markdown 110 | QuestionElement question -> 111 | isPollQuestionValid question 112 | 113 | isMarkdownValid :: Markdown -> Bool 114 | isMarkdownValid _ = True -- TODO validate markdown 115 | -------------------------------------------------------------------------------- /frontend/src/App/Prelude.purs: -------------------------------------------------------------------------------- 1 | module App.Prelude 2 | ( module Export 3 | , undefined 4 | ) where 5 | 6 | import Prelude (class Applicative, class Apply, class Bind, class BooleanAlgebra, class Bounded, class Category, class CommutativeRing, class Discard, class DivisionRing, class Eq, class EuclideanRing, class Field, class Functor, class HeytingAlgebra, class Monad, class Monoid, class Ord, class Ring, class Semigroup, class Semigroupoid, class Semiring, class Show, type (~>), Ordering(..), Unit, Void, absurd, add, ap, append, apply, between, bind, bottom, clamp, compare, comparing, compose, conj, const, degree, discard, disj, div, eq, flap, flip, gcd, identity, ifM, join, lcm, liftA1, liftM1, map, max, mempty, min, mod, mul, negate, not, notEq, one, otherwise, pure, recip, show, sub, top, unit, unless, unlessM, void, when, whenM, zero, (#), ($), ($>), (&&), (*), (*>), (+), (-), (/), (/=), (<), (<#>), (<$), (<$>), (<*), (<*>), (<<<), (<=), (<=<), (<>), (<@>), (=<<), (==), (>), (>=), (>=>), (>>=), (>>>), (||)) as Export 7 | 8 | import Data.Maybe (Maybe(..), fromJust, fromMaybe, fromMaybe', isJust, isNothing, maybe, maybe', optional) as Export 9 | 10 | import Data.Either (Either(..), choose, either, fromLeft, fromRight, hush, isLeft, isRight, note, note') as Export 11 | 12 | import Halogen (Component, ComponentHTML, modify, modify_) as Export 13 | import Halogen.HTML (HTML) as Export 14 | 15 | import Effect.Class (class MonadEffect, liftEffect) as Export 16 | import Effect.Ref (Ref) as Export 17 | import Effect.Console (log) as Export 18 | 19 | import Data.Newtype (class Newtype, ala, alaF, unwrap, wrap) as Export 20 | 21 | import Data.Lens.Types (class Wander, AGrate, AGrate', ALens, ALens', APrism, APrism', AnIndexedLens, AnIndexedLens', AnIso, AnIso', Exchange(..), Fold, Fold', Forget(..), Getter, Getter', Grate, Grate', Grating, Indexed(..), IndexedFold, IndexedFold', IndexedGetter, IndexedGetter', IndexedLens, IndexedLens', IndexedOptic, IndexedOptic', IndexedSetter, IndexedSetter', IndexedTraversal, IndexedTraversal', Iso, Iso', Lens, Lens', Market(..), Optic, Optic', Prism, Prism', Re(..), Review, Review', Setter, Setter', Shop(..), Tagged(..), Traversal, Traversal', wander) as Export 22 | 23 | import Data.Bounded (class Bounded, bottom, top) as Export 24 | import Data.Enum (class Enum, pred, succ, upFromIncluding) as Export 25 | import Data.Lens (_1, _2, _Just, _Left, _Nothing, _Right, first, left, right, second, united, over, (%~), set, (.~), view, (^.), toListOf, (^..), preview, (^?), traverseOf) as Export 26 | import Data.Lens.Iso.Newtype (_Newtype) as Export 27 | import Data.Lens.Record (prop) as Export 28 | import Data.Symbol (SProxy(..)) as Export 29 | import Data.Generic.Rep (class Generic) as Export 30 | import Data.Generic.Rep.Show (genericShow) as Export 31 | import Data.Generic.Rep.Enum (genericPred, genericSucc) as Export 32 | import Data.Generic.Rep.Bounded (genericBottom, genericTop) as Export 33 | 34 | import Data.Foldable (class Foldable, intercalate) as Export 35 | 36 | import Control.Monad.Error.Class (class MonadThrow, try) as Export 37 | import Control.Monad.Trans.Class (lift) as Export 38 | import Control.Monad.Maybe.Trans (MaybeT(..), runMaybeT) as Export 39 | import Control.Monad.Except (class MonadError, ExceptT(..), runExceptT, except) as Export 40 | import Control.Monad.Reader (class MonadAsk, class MonadReader, ReaderT(..), runReaderT, ask, asks) as Export 41 | import Data.Const (Const) as Export 42 | import Control.Alt as Export 43 | import Effect.Aff (Aff, launchAff, forkAff, throwError, catchError) as Export 44 | import Effect.Aff.Class (class MonadAff, liftAff) as Export 45 | import Effect (Effect) as Export 46 | import Effect.Exception (Error, error) as Export 47 | 48 | import Data.Symbol (class IsSymbol) as Export 49 | import Prim.Row (class Cons) as Export 50 | import Data.Date (Date) as Export 51 | import Data.NonEmpty (NonEmpty(..), (:|)) as Export 52 | 53 | import App.Data.Route (Route(..)) as Export 54 | import App.Effect.Navigate (class Navigate, navigate) as Export 55 | 56 | import Unsafe.Coerce (unsafeCoerce) 57 | 58 | import Prelude 59 | 60 | undefined :: ∀ a. a 61 | undefined = unsafeCoerce unit 62 | -------------------------------------------------------------------------------- /hspolls.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | 3 | name: hspolls 4 | version: 0 5 | 6 | library 7 | build-depends: 8 | aeson ^>= 1.4, 9 | amazonka ^>= 1.6, 10 | amazonka-ses ^>= 1.6, 11 | base ^>= 4.12, 12 | blaze-html ^>= 0.9, 13 | bytestring ^>= 0.10, 14 | containers ^>= 0.6, 15 | free ^>= 5.1, 16 | fused-effects ^>= 0.3.1, 17 | dhall ^>= 1.19, 18 | generic-lens ^>= 1.1, 19 | hasql ^>= 1.3.0.3, 20 | hasql-pool ^>= 0.5.0.1, 21 | hasql-transaction ^>= 0.7, 22 | hasql-cursor-transaction ^>= 0.6.3.1, 23 | hasql-cursor-query ^>= 0.4.4.2, 24 | http-api-data ^>= 0.4, 25 | http-client ^>= 0.5 || ^>= 0.6, 26 | http-client-tls ^>= 0.3, 27 | jose ^>= 0.8, 28 | lens ^>= 4.17, 29 | memory ^>= 0.14, 30 | prometheus-client ^>= 1.0, 31 | prometheus-metrics-ghc ^>= 1.0, 32 | resourcet ^>= 1.2, 33 | safe-exceptions ^>= 0.1, 34 | say ^>= 0.1, 35 | servant ^>= 0.16, 36 | servant-auth ^>= 0.3, 37 | servant-auth-server ^>= 0.4, 38 | servant-blaze ^>= 0.9, 39 | servant-client ^>= 0.16, 40 | servant-client-core ^>= 0.16, 41 | servant-server ^>= 0.16, 42 | slave-thread ^>= 1.0, 43 | stm ^>= 2.5, 44 | text ^>= 1.2, 45 | time ^>= 1.8 || ^>= 1.9, 46 | transformers ^>= 0.5, 47 | uuid ^>= 1.3, 48 | validation ^>= 1, 49 | vector ^>= 0.12, 50 | wai ^>= 3.2, 51 | warp ^>= 3.2, 52 | 53 | default-extensions: 54 | DataKinds 55 | DeriveAnyClass 56 | DeriveFunctor 57 | DeriveGeneric 58 | DerivingStrategies 59 | DerivingVia 60 | DuplicateRecordFields 61 | FlexibleContexts 62 | FlexibleInstances 63 | GADTs 64 | GeneralizedNewtypeDeriving 65 | InstanceSigs 66 | KindSignatures 67 | LambdaCase 68 | MultiParamTypeClasses 69 | NamedFieldPuns 70 | OverloadedLabels 71 | OverloadedStrings 72 | PartialTypeSignatures 73 | QuantifiedConstraints 74 | RankNTypes 75 | RecordWildCards 76 | ScopedTypeVariables 77 | StandaloneDeriving 78 | StrictData 79 | TypeApplications 80 | TypeFamilies 81 | TypeOperators 82 | 83 | default-language: 84 | Haskell2010 85 | 86 | exposed-modules: 87 | Hp.API 88 | Hp.Config 89 | Hp.Eff.Await 90 | Hp.Eff.Await.Chan 91 | Hp.Eff.Catch 92 | Hp.Eff.DB 93 | Hp.Eff.FirstOrder 94 | Hp.Eff.GetCurrentTime 95 | Hp.Eff.GitHubAuth 96 | Hp.Eff.GitHubAuth.AlwaysFail 97 | Hp.Eff.GitHubAuth.Http 98 | Hp.Eff.HttpRequest 99 | Hp.Eff.HttpRequest.IO 100 | Hp.Eff.HttpSession 101 | Hp.Eff.HttpSession.IO 102 | Hp.Eff.Log 103 | Hp.Eff.Log.Stdout 104 | Hp.Eff.PersistPoll 105 | Hp.Eff.PersistPoll.DB 106 | Hp.Eff.PersistPollAnswer 107 | Hp.Eff.PersistPollAnswer.DB 108 | Hp.Eff.PersistUser 109 | Hp.Eff.PersistUser.DB 110 | Hp.Eff.SendEmail 111 | Hp.Eff.SendEmail.AmazonSES 112 | Hp.Eff.SendEmail.Noop 113 | Hp.Eff.Throw 114 | Hp.Eff.Yield 115 | Hp.Eff.Yield.Chan 116 | Hp.Eff.Yield.Print 117 | Hp.Email 118 | Hp.Entity 119 | Hp.Entity.Poll 120 | Hp.Entity.PollAnswer 121 | Hp.Entity.User 122 | Hp.Event.PollAnswered 123 | Hp.Event.PollCreated 124 | Hp.GitHub 125 | Hp.GitHub.API 126 | Hp.GitHub.AccessToken 127 | Hp.GitHub.ClientId 128 | Hp.GitHub.ClientSecret 129 | Hp.GitHub.Code 130 | Hp.GitHub.ErrorResponse 131 | Hp.GitHub.PostLoginOauthAccessTokenResponse 132 | Hp.GitHub.Response 133 | Hp.GitHub.User 134 | Hp.GitHub.UserName 135 | Hp.Handler.AnswerPoll 136 | Hp.Handler.CreatePoll 137 | Hp.Handler.GetMetrics 138 | Hp.Handler.GetPoll 139 | Hp.Handler.GetRoot 140 | Hp.Handler.GetUserProfile 141 | Hp.Handler.GitHubOauthCallback 142 | Hp.Handler.Subscribe 143 | Hp.Hasql 144 | Hp.IsEntity 145 | Hp.Main 146 | Hp.Metrics 147 | Hp.PollFormElement 148 | Hp.PollQuestion 149 | Hp.PollQuestionAnswer 150 | Hp.PostgresConfig 151 | Hp.RequestBody.AnswerPoll 152 | Hp.RequestBody.CreatePoll 153 | Hp.RequestBody.Subscribe 154 | Hp.ResponseBody.GetPoll 155 | Hp.Subscription 156 | Hp.TBroadcastChan 157 | Hp.UserProfile 158 | Hp.Worker.SendEmail 159 | Hp.Worker.SendPollCreatedEmail 160 | Prelude 161 | 162 | ghc-options: 163 | -Wall 164 | -Wcompat 165 | -Widentities 166 | -Wincomplete-record-updates 167 | -Wincomplete-uni-patterns 168 | -Wmissing-export-lists 169 | -Wpartial-fields 170 | -Wredundant-constraints 171 | -fhide-source-paths 172 | -fno-warn-name-shadowing 173 | -fprint-explicit-foralls 174 | -fprint-unicode-syntax 175 | 176 | hs-source-dirs: 177 | src 178 | 179 | mixins: 180 | base hiding (Prelude), 181 | base (Prelude as PreludeFromBase) 182 | 183 | executable hspolls 184 | build-depends: 185 | base, 186 | hspolls 187 | 188 | default-language: 189 | Haskell2010 190 | 191 | ghc-options: 192 | -Wall -threaded -rtsopts 193 | 194 | hs-source-dirs: 195 | app 196 | 197 | main-is: 198 | Main.hs 199 | 200 | mixins: 201 | base hiding (Prelude) 202 | -------------------------------------------------------------------------------- /src/Hp/Eff/PersistUser/DB.hs: -------------------------------------------------------------------------------- 1 | -- | Real database carrier for the PersistUser effect. 2 | 3 | {-# LANGUAGE UndecidableInstances #-} 4 | 5 | module Hp.Eff.PersistUser.DB 6 | ( runPersistUserDB 7 | ) where 8 | 9 | import Hp.Eff.DB (DB, runDB) 10 | import Hp.Eff.PersistUser 11 | import Hp.Entity (Entity(..)) 12 | import Hp.Entity.User (User(..), UserId, userIdDecoder, userIdEncoder) 13 | import Hp.GitHub.User (GitHubUser(..)) 14 | import Hp.GitHub.UserName (gitHubUserNameDecoder, gitHubUserNameEncoder) 15 | import Hp.Hasql (statement) 16 | import Hp.Subscription (Subscription(..)) 17 | 18 | import Control.Effect 19 | import Control.Effect.Interpret 20 | import Prelude hiding (id) 21 | 22 | import qualified Hasql.Decoders as Decoder 23 | import qualified Hasql.Encoders as Encoder 24 | 25 | 26 | runPersistUserDB :: 27 | ( Carrier sig m 28 | , Member DB sig 29 | ) 30 | => InterpretC PersistUserEffect m a 31 | -> m a 32 | runPersistUserDB = 33 | runInterpret $ \case 34 | GetUserById userId next -> 35 | doGetUserById userId >>= next 36 | 37 | GetUserEmailsSubscribedToPollCreatedEvents next -> 38 | doGetUserEmailsSubscribedToPollCreatedEvents >>= next 39 | 40 | PutUserByGitHubUser user next -> 41 | doPutUserByGitHubUser user >>= next 42 | 43 | SetUserSubscription userId sub next -> do 44 | doSetUserSubscription userId sub 45 | next 46 | 47 | doGetUserById :: 48 | ( Carrier sig m 49 | , Member DB sig 50 | ) 51 | => UserId 52 | -> m (Maybe (Entity User)) 53 | doGetUserById userId = 54 | runDB $ 55 | statement 56 | "SELECT email, gitHub, subscribed_to_poll_created FROM users WHERE id = $1" 57 | userId 58 | (Encoder.param userIdEncoder) 59 | (Decoder.rowMaybe 60 | (Entity userId 61 | <$> (do 62 | email <- Decoder.nullableColumn Decoder.text 63 | gitHub <- Decoder.nullableColumn gitHubUserNameDecoder 64 | subscribedToPollCreated <- Decoder.column Decoder.bool 65 | pure User 66 | { email = email 67 | , gitHub = gitHub 68 | , subscribedToPollCreated = subscribedToPollCreated 69 | }))) 70 | 71 | doGetUserEmailsSubscribedToPollCreatedEvents :: 72 | ( Carrier sig m 73 | , Member DB sig 74 | ) 75 | => m (Vector Text) 76 | doGetUserEmailsSubscribedToPollCreatedEvents = 77 | runDB $ 78 | statement 79 | "SELECT email FROM users WHERE subscribed_to_poll_created = true AND email IS NOT NULL" 80 | () 81 | Encoder.unit 82 | (Decoder.rowVector (Decoder.column Decoder.text)) 83 | 84 | 85 | doPutUserByGitHubUser :: 86 | ( Carrier sig m 87 | , Member DB sig 88 | ) 89 | => GitHubUser 90 | -> m (Entity User) 91 | doPutUserByGitHubUser GitHubUser { email, login } = 92 | runDB $ do 93 | result :: Maybe (Entity User) <- 94 | statement 95 | "SELECT id, email, subscribed_to_poll_created FROM users WHERE github = $1" 96 | login 97 | (Encoder.param gitHubUserNameEncoder) 98 | (Decoder.rowMaybe 99 | (Entity 100 | <$> Decoder.column userIdDecoder 101 | <*> (do 102 | email <- Decoder.nullableColumn Decoder.text 103 | subscribedToPollCreated <- Decoder.column Decoder.bool 104 | pure User 105 | { email = email 106 | , gitHub = Just login 107 | , subscribedToPollCreated = subscribedToPollCreated 108 | }))) 109 | 110 | case result of 111 | Nothing -> do 112 | userId :: UserId <- 113 | statement 114 | "INSERT INTO users (email, github) VALUES ($1, $2) RETURNING id" 115 | (email, Just login) 116 | (fold 117 | [ view _1 >$< Encoder.nullableParam Encoder.text 118 | , view _2 >$< Encoder.nullableParam gitHubUserNameEncoder 119 | ]) 120 | (Decoder.singleRow (Decoder.column userIdDecoder)) 121 | 122 | pure 123 | (Entity userId User 124 | { email = email 125 | , gitHub = Just login 126 | , subscribedToPollCreated = False 127 | }) 128 | 129 | Just user 130 | | user ^. #value . #email == email -> 131 | pure user 132 | 133 | -- User changed their email address on GitHub apparently, so use it 134 | | otherwise -> do 135 | statement 136 | "UPDATE users SET email = $1 WHERE id = $2" 137 | (email, user ^. #key) 138 | (fold 139 | [ view _1 >$< Encoder.nullableParam Encoder.text 140 | , view _2 >$< Encoder.param userIdEncoder 141 | ]) 142 | Decoder.unit 143 | 144 | pure (user & #value . #email .~ email) 145 | 146 | doSetUserSubscription :: 147 | ( Carrier sig m 148 | , Member DB sig 149 | ) 150 | => UserId 151 | -> Subscription 152 | -> m () 153 | doSetUserSubscription userId sub = 154 | runDB $ 155 | statement 156 | "UPDATE users SET subscribed_to_poll_created = $1 WHERE id = $2" 157 | (userId, sub) 158 | (fold 159 | [ view (_2 . #pollCreated) >$< Encoder.param Encoder.bool 160 | , view _1 >$< Encoder.param userIdEncoder 161 | ]) 162 | Decoder.unit 163 | -------------------------------------------------------------------------------- /src/Hp/Config.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ApplicativeDo #-} 2 | 3 | module Hp.Config 4 | ( Config(..) 5 | , AwsConfig(..) 6 | , GitHubConfig(..) 7 | , PostgresConfig(..) 8 | , readConfigFile 9 | ) where 10 | 11 | import Hp.GitHub.ClientId (GitHubClientId(..)) 12 | import Hp.GitHub.ClientSecret (GitHubClientSecret(..)) 13 | 14 | import Crypto.JOSE.JWK (JWK) 15 | import Data.ByteArray.Encoding (Base(..), convertFromBase) 16 | import Data.Validation 17 | import Servant.Auth.Server (CookieSettings(..), IsSecure(..), 18 | JWTSettings(..), SameSite(..), 19 | defaultJWTSettings, defaultXsrfCookieSettings, 20 | generateKey) 21 | 22 | import qualified Crypto.JOSE.JWK as JWK 23 | import qualified Data.ByteString as ByteString 24 | import qualified Dhall 25 | import qualified Network.AWS as AWS 26 | 27 | 28 | -- | Config parsed straight from a dhall value, with no additional checks on the 29 | -- values (e.g. the JWT must be a certain length string). 30 | data UnvalidatedConfig 31 | = UnvalidatedConfig 32 | { aws :: Maybe UnvalidatedAwsConfig 33 | , gitHub :: Maybe UnvalidatedGitHubConfig 34 | , port :: Natural 35 | , postgres :: UnvalidatedPostgresConfig 36 | , session :: UnvalidatedSessionConfig 37 | } deriving stock (Generic) 38 | deriving anyclass (Dhall.Interpret) 39 | 40 | data UnvalidatedAwsConfig 41 | = UnvalidatedAwsConfig 42 | { accessKeyId :: Text 43 | , secretAccessKey :: Text 44 | } deriving stock (Generic) 45 | deriving anyclass (Dhall.Interpret) 46 | 47 | data UnvalidatedGitHubConfig 48 | = UnvalidatedGitHubConfig 49 | { clientId :: Text 50 | , clientSecret :: Text 51 | } deriving stock (Generic) 52 | deriving anyclass (Dhall.Interpret) 53 | 54 | data UnvalidatedPostgresConfig 55 | = UnvalidatedPostgresConfig 56 | { host :: Text 57 | , port :: Natural 58 | , user :: Text 59 | , password :: Text 60 | , dbName :: Text 61 | , poolSize :: Natural 62 | , poolTimeout :: Natural 63 | } deriving stock (Generic, Show) 64 | deriving anyclass (Dhall.Interpret) 65 | 66 | data UnvalidatedSessionConfig 67 | = UnvalidatedSessionConfig 68 | { jwk :: Maybe Text 69 | , name :: Text 70 | , secure :: Bool 71 | , ttl :: Maybe Natural 72 | , xsrf :: Bool 73 | } deriving stock (Generic) 74 | deriving anyclass (Dhall.Interpret) 75 | 76 | data Config 77 | = Config 78 | { aws :: Maybe AwsConfig 79 | , gitHub :: Maybe GitHubConfig 80 | , port :: Natural 81 | , postgres :: PostgresConfig 82 | , session :: SessionConfig 83 | } deriving stock (Generic) 84 | 85 | data AwsConfig 86 | = AwsConfig 87 | { accessKeyId :: AWS.AccessKey 88 | , secretAccessKey :: AWS.SecretKey 89 | } deriving stock (Generic) 90 | 91 | data GitHubConfig 92 | = GitHubConfig 93 | { clientId :: GitHubClientId 94 | , clientSecret :: GitHubClientSecret 95 | } deriving stock (Generic, Show) 96 | 97 | data PostgresConfig 98 | = PostgresConfig 99 | { host :: Text 100 | , port :: Natural 101 | , user :: Text 102 | , password :: Text 103 | , dbName :: Text 104 | , poolSize :: Natural 105 | , poolTimeout :: Natural 106 | } deriving stock (Generic, Show) 107 | 108 | data SessionConfig 109 | = SessionConfig 110 | { cookie :: CookieSettings 111 | , jwt :: Either (IO JWTSettings) JWTSettings 112 | } deriving stock (Generic) 113 | 114 | readConfigFile :: FilePath -> IO (Either [Text] Config) 115 | readConfigFile path = do 116 | unvalidatedConfig :: UnvalidatedConfig <- 117 | Dhall.detailed (Dhall.input Dhall.auto (path ^. packed)) 118 | 119 | pure (toEither (validateConfig unvalidatedConfig)) 120 | 121 | validateConfig :: UnvalidatedConfig -> Validation [Text] Config 122 | validateConfig config = do 123 | aws :: Maybe AwsConfig <- 124 | traverse validateAwsConfig (config ^. #aws) 125 | 126 | gitHub :: Maybe GitHubConfig <- 127 | traverse validateGitHubConfig (config ^. #gitHub) 128 | 129 | postgres :: PostgresConfig <- 130 | validatePostgresConfig (config ^. #postgres) 131 | 132 | session :: SessionConfig <- 133 | validateSessionConfig (config ^. #session) 134 | 135 | pure Config 136 | { aws = aws 137 | , gitHub = gitHub 138 | -- TODO validate port is < 2^6 139 | , port = config ^. #port 140 | , postgres = postgres 141 | , session = session 142 | } 143 | 144 | validateAwsConfig :: 145 | UnvalidatedAwsConfig 146 | -> Validation [Text] AwsConfig 147 | validateAwsConfig config = 148 | pure AwsConfig 149 | { accessKeyId = AWS.AccessKey (config ^. #accessKeyId . re utf8) 150 | , secretAccessKey = AWS.SecretKey (config ^. #secretAccessKey . re utf8) 151 | } 152 | 153 | validateGitHubConfig :: 154 | UnvalidatedGitHubConfig 155 | -> Validation [Text] GitHubConfig 156 | validateGitHubConfig config = 157 | pure GitHubConfig 158 | { clientId = GitHubClientId (config ^. #clientId) 159 | , clientSecret = GitHubClientSecret (config ^. #clientSecret) 160 | } 161 | 162 | validateJWK :: Text -> Validation [Text] JWK 163 | validateJWK bytes = 164 | case convertFromBase Base64 (bytes ^. re utf8) :: Either String ByteString of 165 | Left err -> 166 | Failure ["Invalid JWK (expected 256 base64-encoded bytes): " <> err ^. packed] 167 | 168 | Right bytes -> 169 | case ByteString.length bytes of 170 | 256 -> 171 | pure (JWK.fromOctets bytes) 172 | 173 | _ -> 174 | Failure ["Invalid JWK (expected 256 base64-encoded bytes)"] 175 | 176 | validateSessionConfig :: 177 | UnvalidatedSessionConfig 178 | -> Validation [Text] SessionConfig 179 | validateSessionConfig config = 180 | SessionConfig 181 | <$> validateCookieSettings 182 | <*> validateJWTSettings 183 | 184 | where 185 | validateCookieSettings :: Validation [Text] CookieSettings 186 | validateCookieSettings = 187 | pure CookieSettings 188 | { cookieDomain = 189 | Nothing 190 | 191 | , cookieExpires = 192 | Nothing 193 | 194 | , cookieIsSecure = 195 | if config ^. #secure 196 | then Secure 197 | else NotSecure 198 | 199 | , cookieMaxAge = 200 | fromIntegral <$> (config ^. #ttl) 201 | 202 | , cookiePath = 203 | Just "/" 204 | 205 | , cookieSameSite = 206 | SameSiteLax 207 | 208 | , cookieXsrfSetting = 209 | if config ^. #xsrf 210 | then Just defaultXsrfCookieSettings 211 | else Nothing 212 | 213 | , sessionCookieName = 214 | config ^. #name . re utf8 215 | } 216 | 217 | validateJWTSettings :: 218 | Validation [Text] (Either (IO JWTSettings) JWTSettings) 219 | validateJWTSettings = 220 | case config ^. #jwk of 221 | Nothing -> 222 | pure (Left (defaultJWTSettings <$> generateKey)) 223 | 224 | Just bytes -> do 225 | jwk :: JWK <- 226 | validateJWK bytes 227 | 228 | pure (Right (defaultJWTSettings jwk)) 229 | 230 | validatePostgresConfig :: 231 | UnvalidatedPostgresConfig 232 | -> Validation [Text] PostgresConfig 233 | validatePostgresConfig config = 234 | pure PostgresConfig 235 | { host = config ^. #host 236 | , port = config ^. #port 237 | , user = config ^. #user 238 | , password = config ^. #password 239 | , dbName = config ^. #dbName 240 | , poolSize = config ^. #poolSize 241 | , poolTimeout = config ^. #poolTimeout 242 | } 243 | -------------------------------------------------------------------------------- /src/Hp/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | 3 | {-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} 4 | 5 | module Hp.Main 6 | ( main 7 | ) where 8 | 9 | import Hp.API 10 | import Hp.Config (Config(..), GitHubConfig(..), 11 | readConfigFile) 12 | import Hp.Eff.Await.Chan (runAwaitChan) 13 | import Hp.Eff.DB (runDBC) 14 | import Hp.Eff.GetCurrentTime (GetCurrentTimeEffect(..)) 15 | import Hp.Eff.GitHubAuth.AlwaysFail (runGitHubAuthAlwaysFail) 16 | import Hp.Eff.GitHubAuth.Http (runGitHubAuthHttp) 17 | import Hp.Eff.HttpRequest.IO (HttpConnectionError, runHttpRequestIO) 18 | import Hp.Eff.HttpSession.IO (runHttpSessionIO) 19 | import Hp.Eff.Log (log) 20 | import Hp.Eff.Log.Stdout (runLogStdout) 21 | import Hp.Eff.PersistPoll.DB (runPersistPollDB) 22 | import Hp.Eff.PersistPollAnswer.DB (runPersistPollAnswerDB) 23 | import Hp.Eff.PersistUser.DB (runPersistUserDB) 24 | import Hp.Eff.SendEmail.AmazonSES (runSendEmailAmazonSES) 25 | import Hp.Eff.SendEmail.Noop (runSendEmailNoop) 26 | import Hp.Eff.Throw (ThrowEffect(..), runThrow, throw) 27 | import Hp.Eff.Yield.Chan (runYieldChan) 28 | import Hp.Email (Email) 29 | import Hp.Event.PollAnswered (PollAnsweredEvent) 30 | import Hp.Event.PollCreated (PollCreatedEvent) 31 | import Hp.Handler.AnswerPoll (handleAnswerPoll) 32 | import Hp.Handler.CreatePoll (handleCreatePoll) 33 | import Hp.Handler.GetMetrics (handleGetMetrics) 34 | import Hp.Handler.GetPoll (handleGetPoll) 35 | import Hp.Handler.GetRoot (handleGetRoot) 36 | import Hp.Handler.GetUserProfile (handleGetUserProfile) 37 | import Hp.Handler.GitHubOauthCallback (handleGitHubOauthCallback) 38 | import Hp.Handler.Subscribe (handleSubscribe) 39 | import Hp.Metrics (requestCounter) 40 | import Hp.PostgresConfig (acquirePostgresPool) 41 | import Hp.TBroadcastChan 42 | import Hp.Worker.SendEmail (sendEmailWorker) 43 | import Hp.Worker.SendPollCreatedEmail (sendPollCreatedEmailWorker) 44 | 45 | import Control.Concurrent.STM 46 | import Control.Effect 47 | import Control.Effect.Interpret 48 | import Control.Monad.Trans.Except (ExceptT(..)) 49 | import Servant (Context((:.))) 50 | import Servant.Auth.Server (CookieSettings, JWTSettings) 51 | import System.Exit (exitFailure) 52 | 53 | import qualified Data.Text.IO as Text 54 | import qualified Data.Time as Time (getCurrentTime) 55 | import qualified Hasql.Pool as Hasql (Pool, UsageError) 56 | import qualified Network.AWS as Aws 57 | import qualified Network.AWS.Env as Aws (newEnvWith) 58 | import qualified Network.HTTP.Client as Http 59 | import qualified Network.HTTP.Client.TLS as Http (tlsManagerSettings) 60 | import qualified Network.Wai as Wai 61 | import qualified Network.Wai.Handler.Warp as Warp 62 | import qualified Prometheus 63 | import qualified Servant 64 | import qualified Servant.Client as Servant (ClientError) 65 | import qualified Servant.Server.Generic as Servant (genericServeTWithContext) 66 | import qualified SlaveThread 67 | 68 | 69 | main :: IO () 70 | main = do 71 | config :: Config <- 72 | readConfigFile "./etc/config.dhall" >>= \case 73 | Left errs -> do 74 | for_ errs Text.putStrLn 75 | exitFailure 76 | 77 | Right config -> 78 | pure config 79 | 80 | httpManager :: Http.Manager <- 81 | Http.newManager Http.tlsManagerSettings 82 | 83 | awsEnv :: Maybe Aws.Env <- 84 | for (config ^. #aws) $ \awsConfig -> 85 | Aws.newEnvWith 86 | (Aws.FromKeys 87 | (awsConfig ^. #accessKeyId) 88 | (awsConfig ^. #secretAccessKey)) 89 | Nothing 90 | httpManager 91 | 92 | jwtSettings :: JWTSettings <- 93 | either id pure (config ^. #session . #jwt) 94 | 95 | pgPool :: Hasql.Pool <- 96 | acquirePostgresPool (config ^. #postgres) 97 | 98 | pollAnsweredEventChan :: TBroadcastChan PollAnsweredEvent <- 99 | newTBroadcastChanIO 100 | 101 | pollCreatedEventChan :: TBroadcastChan PollCreatedEvent <- 102 | newTBroadcastChanIO 103 | 104 | emailChan :: TBroadcastChan Email <- 105 | newTBroadcastChanIO 106 | 107 | void . SlaveThread.fork $ do 108 | chan :: TChan PollCreatedEvent <- 109 | dupTBroadcastChanIO pollCreatedEventChan 110 | 111 | forever $ do 112 | result :: Either Hasql.UsageError Void <- 113 | sendPollCreatedEmailWorker 114 | & runAwaitChan chan 115 | & runPersistUserDB 116 | & runDBC pgPool 117 | & runThrow @Hasql.UsageError 118 | & runYieldChan (unsafeTBroadcastChanToTChan emailChan) 119 | & runM 120 | 121 | case result of 122 | Left err -> do 123 | log (show err ^. packed) 124 | & runLogStdout 125 | & runM 126 | 127 | Right void -> 128 | absurd void 129 | 130 | void . SlaveThread.fork $ do 131 | chan :: TChan Email <- 132 | dupTBroadcastChanIO emailChan 133 | 134 | sendEmailWorker 135 | & runAwaitChan chan 136 | & case awsEnv of 137 | Nothing -> runSendEmailNoop 138 | Just awsEnv -> runSendEmailAmazonSES awsEnv 139 | & runLogStdout 140 | & runM 141 | 142 | Warp.run 143 | (fromIntegral (config ^. #port)) 144 | (middleware 145 | (application 146 | (config ^. #session . #cookie) 147 | (config ^. #gitHub) 148 | httpManager 149 | jwtSettings 150 | pgPool 151 | pollAnsweredEventChan 152 | pollCreatedEventChan)) 153 | 154 | middleware :: 155 | ( Wai.Request 156 | -> (Wai.Response -> IO Wai.ResponseReceived) 157 | -> IO Wai.ResponseReceived 158 | ) 159 | -> Wai.Request 160 | -> (Wai.Response -> IO Wai.ResponseReceived) 161 | -> IO Wai.ResponseReceived 162 | middleware app request respond = do 163 | Prometheus.incCounter requestCounter 164 | app request respond 165 | 166 | application :: 167 | CookieSettings 168 | -> Maybe GitHubConfig 169 | -> Http.Manager 170 | -> JWTSettings 171 | -> Hasql.Pool 172 | -> TBroadcastChan PollAnsweredEvent 173 | -> TBroadcastChan PollCreatedEvent 174 | -> Wai.Request 175 | -> (Wai.Response -> IO Wai.ResponseReceived) 176 | -> IO Wai.ResponseReceived 177 | application 178 | cookieSettings 179 | gitHubConfig 180 | httpManager 181 | jwtSettings 182 | postgresPool 183 | pollAnsweredEventChan 184 | pollCreatedEventChan = do 185 | 186 | Servant.genericServeTWithContext 187 | eta 188 | API 189 | { answerPollRoute = handleAnswerPoll 190 | , createPollRoute = handleCreatePoll 191 | , getMetricsRoute = handleGetMetrics 192 | , getPollRoute = handleGetPoll 193 | , getRootRoute = handleGetRoot 194 | , getUserProfileRoute = handleGetUserProfile 195 | , gitHubOauthCallbackRoute = handleGitHubOauthCallback 196 | , subscribeRoute = handleSubscribe 197 | } 198 | (cookieSettings 199 | :. jwtSettings 200 | :. Servant.EmptyContext) 201 | 202 | where 203 | eta :: forall a. _ a -> Servant.Handler a 204 | eta = -- Outgoing HTTP requests 205 | runGitHubAuth 206 | >>> runHttpRequestIO httpManager 207 | 208 | -- Persistence layer 209 | >>> runPersistPollDB 210 | >>> runPersistPollAnswerDB 211 | >>> runPersistUserDB 212 | >>> runDBC postgresPool 213 | 214 | -- HTTP session 215 | >>> runHttpSessionIO cookieSettings jwtSettings 216 | 217 | -- Event handlers 218 | >>> runYieldChan (unsafeTBroadcastChanToTChan pollAnsweredEventChan) 219 | >>> runYieldChan (unsafeTBroadcastChanToTChan pollCreatedEventChan) 220 | 221 | -- Error handlers 222 | >>> runInterpret 223 | (\(Throw err) -> do 224 | log (show (err :: Hasql.UsageError) ^. packed) 225 | throw Servant.err500) 226 | >>> runInterpret 227 | (\(Throw err) -> do 228 | log (show (err :: HttpConnectionError) ^. packed) 229 | throw Servant.err500) 230 | >>> runInterpret 231 | (\(Throw err) -> do 232 | log (show (err :: Servant.ClientError) ^. packed) 233 | throw Servant.err500) 234 | >>> runThrow 235 | 236 | -- Current time 237 | >>> runInterpret 238 | (\(GetCurrentTime next) -> liftIO Time.getCurrentTime >>= next) 239 | 240 | -- Logging 241 | >>> runLogStdout 242 | 243 | -- IO boilerplate 244 | >>> runM 245 | >>> ExceptT 246 | >>> Servant.Handler 247 | 248 | runGitHubAuth :: _ -> _ -- GHC wants this? 249 | runGitHubAuth = 250 | case gitHubConfig of 251 | Nothing -> 252 | runGitHubAuthAlwaysFail 253 | Just GitHubConfig { clientId, clientSecret } -> 254 | runGitHubAuthHttp clientId clientSecret 255 | --------------------------------------------------------------------------------