diff options
author | William Carroll <wpcarro@gmail.com> | 2020-08-09T21·17+0100 |
---|---|---|
committer | William Carroll <wpcarro@gmail.com> | 2020-08-09T21·17+0100 |
commit | bbcd0bf27d2663a9673983ccf6e2cf7034ddf240 (patch) | |
tree | 18c6fa980ffce4a598e4889ea56510fd2f21495f | |
parent | 7d85ba559dd50e0552abccb45d1cf5766ebcb541 (diff) |
Replace Prelude with RIO
I believe RIO stands for: "ReaderT <something-something> IO", which is a nod to the top-level application data type: ```haskell -- This is a simplification newtype RIO env a = RIO { runRIO :: ReaderT env a () } ``` I read about RIO from an FP-Complete blog post a few months ago, and now I'm excited to try it out for a real project. Bon voyage!
7 files changed, 95 insertions, 39 deletions
diff --git a/website/sandbox/learnpianochords/src/server/App.hs b/website/sandbox/learnpianochords/src/server/App.hs new file mode 100644 index 000000000000..98742daef7af --- /dev/null +++ b/website/sandbox/learnpianochords/src/server/App.hs @@ -0,0 +1,46 @@ +-------------------------------------------------------------------------------- +module App where +-------------------------------------------------------------------------------- +import RIO hiding (Handler) +import Servant +import API +import Data.String.Conversions (cs) +import Control.Monad.IO.Class (liftIO) +import GoogleSignIn (EncodedJWT(..), ValidationResult(..)) +import Utils + +import qualified Network.Wai.Handler.Warp as Warp +import qualified Network.Wai.Middleware.Cors as Cors +import qualified GoogleSignIn +import qualified Types as T +-------------------------------------------------------------------------------- + +server :: Server API +server = verifyGoogleSignIn + where + verifyGoogleSignIn :: T.VerifyGoogleSignInRequest -> Handler NoContent + verifyGoogleSignIn T.VerifyGoogleSignInRequest{..} = do + validationResult <- liftIO $ GoogleSignIn.validateJWT False (EncodedJWT idToken) + case validationResult of + Valid _ -> do + -- If GoogleLinkedAccounts has email from JWT: + -- create a new session for email + -- Else: + -- Redirect the SPA to the sign-up / payment page + pure NoContent + err -> do + throwError err401 { errBody = err |> GoogleSignIn.explainResult |> cs } + +run :: RIO T.Context () +run = do + T.Context{..} <- ask + liftIO $ Warp.run contextServerPort (enforceCors $ serve (Proxy @ API) $ server) + where + enforceCors = Cors.cors (const $ Just corsPolicy) + corsPolicy :: Cors.CorsResourcePolicy + corsPolicy = + Cors.simpleCorsResourcePolicy + { Cors.corsOrigins = Just (["http://localhost:8000"], True) + , Cors.corsMethods = Cors.simpleMethods ++ ["PUT", "PATCH", "DELETE", "OPTIONS"] + , Cors.corsRequestHeaders = Cors.simpleHeaders ++ ["Content-Type", "Authorization"] + } diff --git a/website/sandbox/learnpianochords/src/server/Fixtures.hs b/website/sandbox/learnpianochords/src/server/Fixtures.hs index 974df97ce7fa..7c153e422822 100644 --- a/website/sandbox/learnpianochords/src/server/Fixtures.hs +++ b/website/sandbox/learnpianochords/src/server/Fixtures.hs @@ -1,6 +1,7 @@ -------------------------------------------------------------------------------- module Fixtures where -------------------------------------------------------------------------------- +import RIO import Web.JWT import Utils diff --git a/website/sandbox/learnpianochords/src/server/GoogleSignIn.hs b/website/sandbox/learnpianochords/src/server/GoogleSignIn.hs index 0f48a9a1d36b..dcccadcb7022 100644 --- a/website/sandbox/learnpianochords/src/server/GoogleSignIn.hs +++ b/website/sandbox/learnpianochords/src/server/GoogleSignIn.hs @@ -1,8 +1,8 @@ -------------------------------------------------------------------------------- module GoogleSignIn where -------------------------------------------------------------------------------- +import RIO import Data.String.Conversions (cs) -import Data.Text import Web.JWT import Utils @@ -23,7 +23,7 @@ instance Eq DecodedJWT where data ValidationResult = Valid DecodedJWT - | DecodeError + | CannotDecodeJWT | GoogleSaysInvalid Text | NoMatchingClientIDs [StringOrURI] | WrongIssuer StringOrURI @@ -46,7 +46,7 @@ validateJWT :: Bool -> IO ValidationResult validateJWT skipHTTP (EncodedJWT encodedJWT) = do case encodedJWT |> decode of - Nothing -> pure DecodeError + Nothing -> pure CannotDecodeJWT Just jwt -> do if skipHTTP then continue jwt @@ -101,7 +101,7 @@ validateJWT skipHTTP (EncodedJWT encodedJWT) = do -- | Attempt to explain the `ValidationResult` to a human. explainResult :: ValidationResult -> String explainResult (Valid _) = "Everything appears to be valid" -explainResult DecodeError = "We had difficulty decoding the provided JWT" +explainResult CannotDecodeJWT = "We had difficulty decoding the provided JWT" explainResult (GoogleSaysInvalid x) = "After checking with Google, they claimed that the provided JWT was invalid: " ++ cs x explainResult (NoMatchingClientIDs audFields) = "None of the values in the `aud` field on the provided JWT match our client ID: " ++ show audFields explainResult (WrongIssuer issuer) = "The `iss` field in the provided JWT does not match what we expect: " ++ show issuer diff --git a/website/sandbox/learnpianochords/src/server/Main.hs b/website/sandbox/learnpianochords/src/server/Main.hs index ae3562d48486..36044d2585eb 100644 --- a/website/sandbox/learnpianochords/src/server/Main.hs +++ b/website/sandbox/learnpianochords/src/server/Main.hs @@ -1,41 +1,30 @@ -------------------------------------------------------------------------------- module Main where -------------------------------------------------------------------------------- -import Servant -import API -import Control.Monad.IO.Class (liftIO) -import GoogleSignIn (EncodedJWT(..), ValidationResult(..)) -import Data.String.Conversions (cs) -import Utils +import RIO +import Prelude (putStrLn) -import qualified Network.Wai.Handler.Warp as Warp -import qualified Network.Wai.Middleware.Cors as Cors import qualified Types as T -import qualified GoogleSignIn +import qualified System.Envy as Envy +import qualified App -------------------------------------------------------------------------------- -server :: Server API -server = verifyGoogleSignIn - where - verifyGoogleSignIn :: T.VerifyGoogleSignInRequest -> Handler NoContent - verifyGoogleSignIn T.VerifyGoogleSignInRequest{..} = do - validationResult <- liftIO $ GoogleSignIn.validateJWT False (EncodedJWT idToken) - case validationResult of - Valid _ -> do - liftIO $ putStrLn "Sign-in valid! Let's create a session" - pure NoContent - err -> do - throwError err401 { errBody = err |> GoogleSignIn.explainResult |> cs } +-- | Attempt to read environment variables from the system and initialize the +-- Context data type for our application. +getAppContext :: IO (Either String T.Context) +getAppContext = do + mEnv <- Envy.decodeEnv + case mEnv of + Left err -> pure $ Left err + Right T.Env{..} -> pure $ Right T.Context + { contextGoogleClientID = envGoogleClientID + , contextClientPort = 8000 + , contextServerPort = 3000 + } main :: IO () main = do - Warp.run 3000 (enforceCors $ serve (Proxy @ API) $ server) - where - enforceCors = Cors.cors (const $ Just corsPolicy) - corsPolicy :: Cors.CorsResourcePolicy - corsPolicy = - Cors.simpleCorsResourcePolicy - { Cors.corsOrigins = Just (["http://localhost:8000"], True) - , Cors.corsMethods = Cors.simpleMethods ++ ["PUT", "PATCH", "DELETE", "OPTIONS"] - , Cors.corsRequestHeaders = Cors.simpleHeaders ++ ["Content-Type", "Authorization"] - } + mContext <- getAppContext + case mContext of + Left err -> putStrLn err + Right ctx -> runRIO ctx App.run diff --git a/website/sandbox/learnpianochords/src/server/Spec.hs b/website/sandbox/learnpianochords/src/server/Spec.hs index 6246dc9ef2ca..3c476bbf7b87 100644 --- a/website/sandbox/learnpianochords/src/server/Spec.hs +++ b/website/sandbox/learnpianochords/src/server/Spec.hs @@ -1,6 +1,7 @@ -------------------------------------------------------------------------------- module Spec where -------------------------------------------------------------------------------- +import RIO import Test.Hspec import Utils import Web.JWT (numericDate, decode) @@ -18,7 +19,7 @@ main = hspec $ do describe "validateJWT" $ do let validateJWT' = GoogleSignIn.validateJWT True it "returns a decode error when an incorrectly encoded JWT is used" $ do - validateJWT' (GoogleSignIn.EncodedJWT "rubbish") `shouldReturn` DecodeError + validateJWT' (GoogleSignIn.EncodedJWT "rubbish") `shouldReturn` CannotDecodeJWT it "returns validation error when the aud field doesn't match my client ID" $ do let auds = ["wrong-client-id"] diff --git a/website/sandbox/learnpianochords/src/server/TestUtils.hs b/website/sandbox/learnpianochords/src/server/TestUtils.hs index e62950369e65..24054bf47afd 100644 --- a/website/sandbox/learnpianochords/src/server/TestUtils.hs +++ b/website/sandbox/learnpianochords/src/server/TestUtils.hs @@ -1,6 +1,7 @@ -------------------------------------------------------------------------------- module TestUtils where -------------------------------------------------------------------------------- +import RIO import Web.JWT import Data.String.Conversions (cs) -------------------------------------------------------------------------------- @@ -9,7 +10,7 @@ unsafeStringOrURI :: String -> StringOrURI unsafeStringOrURI x = case stringOrURI (cs x) of Nothing -> error $ "Failed to convert to StringOrURI: " ++ x - Just x -> x + Just res -> res unsafeJust :: Maybe a -> a unsafeJust Nothing = error "Attempted to force a Nothing to be a something" diff --git a/website/sandbox/learnpianochords/src/server/Types.hs b/website/sandbox/learnpianochords/src/server/Types.hs index 5b8ca036dd0b..3a9decf39c19 100644 --- a/website/sandbox/learnpianochords/src/server/Types.hs +++ b/website/sandbox/learnpianochords/src/server/Types.hs @@ -1,12 +1,30 @@ -------------------------------------------------------------------------------- module Types where -------------------------------------------------------------------------------- +import RIO import Data.Aeson -import Data.Text +import System.Envy (FromEnv, fromEnv, env) -------------------------------------------------------------------------------- +-- | Read from .envrc +data Env = Env + { envGoogleClientID :: !String + } deriving (Eq, Show) + +instance FromEnv Env where + fromEnv _ = do + envGoogleClientID <- env "GOOGLE_CLIENT_ID" + pure Env {..} + +-- | Application context: a combination of Env and additional values. +data Context = Context + { contextGoogleClientID :: !String + , contextServerPort :: !Int + , contextClientPort :: !Int + } + data VerifyGoogleSignInRequest = VerifyGoogleSignInRequest - { idToken :: Text + { idToken :: !Text } deriving (Eq, Show) instance FromJSON VerifyGoogleSignInRequest where |