From f61ed25755da89f6068efb75642e2ac22d268278 Mon Sep 17 00:00:00 2001
From: William Carroll <wpcarro@gmail.com>
Date: Sun, 9 Aug 2020 23:15:12 +0100
Subject: Prefer ServantT for server to consume App context

Long story -> short: I'd like to access my App monad from within my Servant
handlers.

While this code type-checks, I'm not sure it's working as intended. Needing to
change throwError to throwIO fails the "smell test". I expect to refactor this
code, but I'm calling it a night for now.
---
 website/sandbox/learnpianochords/src/server/App.hs | 54 ++++++++++++----------
 .../sandbox/learnpianochords/src/server/Types.hs   |  3 ++
 2 files changed, 33 insertions(+), 24 deletions(-)

(limited to 'website/sandbox/learnpianochords')

diff --git a/website/sandbox/learnpianochords/src/server/App.hs b/website/sandbox/learnpianochords/src/server/App.hs
index 98742daef7af..095e6169b8eb 100644
--- a/website/sandbox/learnpianochords/src/server/App.hs
+++ b/website/sandbox/learnpianochords/src/server/App.hs
@@ -6,41 +6,47 @@ import Servant
 import API
 import Data.String.Conversions (cs)
 import Control.Monad.IO.Class (liftIO)
+import Network.Wai.Middleware.Cors
 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 :: ServerT API T.App
 server = verifyGoogleSignIn
   where
-    verifyGoogleSignIn :: T.VerifyGoogleSignInRequest -> Handler NoContent
+    verifyGoogleSignIn :: T.VerifyGoogleSignInRequest -> T.App 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 }
+      T.Context{..} <- ask
+      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
+          -- TODO: I would prefer to use `throwError` here, but after changing
+          -- to ServerT, I couldn't get the code to compile.
+          throwIO err401 { errBody = err |> GoogleSignIn.explainResult |> cs }
 
-run :: RIO T.Context ()
+run :: T.App ()
 run = do
-  T.Context{..} <- ask
-  liftIO $ Warp.run contextServerPort (enforceCors $ serve (Proxy @ API) $ server)
+  ctx@T.Context{..} <- ask
+  server
+    |> hoistServer (Proxy @ API) (runRIO ctx)
+    |> serve (Proxy @ API)
+    |> cors (const $ Just corsPolicy)
+    |> Warp.run contextServerPort
+    |> liftIO
   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"]
-        }
+    corsPolicy :: CorsResourcePolicy
+    corsPolicy = simpleCorsResourcePolicy
+      { corsOrigins = Just (["http://localhost:8000"], True)
+      , corsMethods = simpleMethods ++ ["PUT", "PATCH", "DELETE", "OPTIONS"]
+      , corsRequestHeaders = simpleHeaders ++ ["Content-Type", "Authorization"]
+      }
diff --git a/website/sandbox/learnpianochords/src/server/Types.hs b/website/sandbox/learnpianochords/src/server/Types.hs
index 3a9decf39c19..a9e6661f6153 100644
--- a/website/sandbox/learnpianochords/src/server/Types.hs
+++ b/website/sandbox/learnpianochords/src/server/Types.hs
@@ -23,6 +23,9 @@ data Context = Context
   , contextClientPort :: !Int
   }
 
+-- | Type synonym for my application monad.
+type App = RIO Context
+
 data VerifyGoogleSignInRequest = VerifyGoogleSignInRequest
   { idToken :: !Text
   } deriving (Eq, Show)
-- 
cgit 1.4.1