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!
This commit is contained in:
parent
7d85ba559d
commit
bbcd0bf27d
7 changed files with 95 additions and 39 deletions
46
website/sandbox/learnpianochords/src/server/App.hs
Normal file
46
website/sandbox/learnpianochords/src/server/App.hs
Normal file
|
@ -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"]
|
||||
}
|
|
@ -1,6 +1,7 @@
|
|||
--------------------------------------------------------------------------------
|
||||
module Fixtures where
|
||||
--------------------------------------------------------------------------------
|
||||
import RIO
|
||||
import Web.JWT
|
||||
import Utils
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"]
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue