about summary refs log tree commit diff
path: root/website
diff options
context:
space:
mode:
authorWilliam Carroll <wpcarro@gmail.com>2020-08-09T21·17+0100
committerWilliam Carroll <wpcarro@gmail.com>2020-08-09T21·17+0100
commitbbcd0bf27d2663a9673983ccf6e2cf7034ddf240 (patch)
tree18c6fa980ffce4a598e4889ea56510fd2f21495f /website
parent7d85ba559dd50e0552abccb45d1cf5766ebcb541 (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!
Diffstat (limited to 'website')
-rw-r--r--website/sandbox/learnpianochords/src/server/App.hs46
-rw-r--r--website/sandbox/learnpianochords/src/server/Fixtures.hs1
-rw-r--r--website/sandbox/learnpianochords/src/server/GoogleSignIn.hs8
-rw-r--r--website/sandbox/learnpianochords/src/server/Main.hs51
-rw-r--r--website/sandbox/learnpianochords/src/server/Spec.hs3
-rw-r--r--website/sandbox/learnpianochords/src/server/TestUtils.hs3
-rw-r--r--website/sandbox/learnpianochords/src/server/Types.hs22
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