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:
William Carroll 2020-08-09 22:17:19 +01:00
parent 7d85ba559d
commit bbcd0bf27d
7 changed files with 95 additions and 39 deletions

View 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"]
}

View file

@ -1,6 +1,7 @@
--------------------------------------------------------------------------------
module Fixtures where
--------------------------------------------------------------------------------
import RIO
import Web.JWT
import Utils

View file

@ -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

View file

@ -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

View file

@ -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"]

View file

@ -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"

View file

@ -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