Drop support for ServantT transformer type for server

After burning a few hours wrestling with the type system, I decided to revert to
the simpler `Server API` type instead of the `ServantT` transformer type.

The problem is that I couldn't write a MonadError instance for `RIO Context`,
which is my `AppM` (i.e. application monad). Using `throwIO` in the server
handlers results in 500 errors, which is not what I wanted. I'm still pretty
fuzzy about what's happening; I now know that exception handling in Haskell is
pretty gnaryly. I may revisit this at a later time when my knowledge is more
extensive. For now: time to fry bigger fish.

An easier abstract is for me to pass `T.Context` into `server` as an argument,
which after all is what a Reader does.

TL;DR:
- Read server, client ports from .envrc
- Define a top-level Failure type (empty for now)
- Define a top-level Success type
- Define App as RIO Context (Either Failure Success)

3 files changed, 59 insertions, 16 deletions

diff --git a/website/sandbox/learnpianochords/src/server/App.hs b/website/sandbox/learnpianochords/src/server/App.hs
index 095e6169b8eb..92dee6045d46 100644
--- a/website/sandbox/learnpianochords/src/server/App.hs
+++ b/website/sandbox/learnpianochords/src/server/App.hs
@@ -15,12 +15,11 @@ import qualified GoogleSignIn
 import qualified Types as T
 --------------------------------------------------------------------------------
 
-server :: ServerT API T.App
-server = verifyGoogleSignIn
+server :: T.Context -> Server API
+server T.Context{..} = verifyGoogleSignIn
   where
-    verifyGoogleSignIn :: T.VerifyGoogleSignInRequest -> T.App NoContent
+    verifyGoogleSignIn :: T.VerifyGoogleSignInRequest -> Handler NoContent
     verifyGoogleSignIn T.VerifyGoogleSignInRequest{..} = do
-      T.Context{..} <- ask
       validationResult <- liftIO $ GoogleSignIn.validateJWT False (EncodedJWT idToken)
       case validationResult of
         Valid _ -> do
@@ -30,19 +29,18 @@ server = verifyGoogleSignIn
           --   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 }
+          throwError err401 { errBody = err |> GoogleSignIn.explainResult |> cs }
 
-run :: T.App ()
+run :: T.App
 run = do
   ctx@T.Context{..} <- ask
-  server
-    |> hoistServer (Proxy @ API) (runRIO ctx)
+  ctx
+    |> server
     |> serve (Proxy @ API)
     |> cors (const $ Just corsPolicy)
     |> Warp.run contextServerPort
     |> liftIO
+  pure $ Right ()
   where
     corsPolicy :: CorsResourcePolicy
     corsPolicy = simpleCorsResourcePolicy
diff --git a/website/sandbox/learnpianochords/src/server/Main.hs b/website/sandbox/learnpianochords/src/server/Main.hs
index 36044d2585eb..a163c66cda07 100644
--- a/website/sandbox/learnpianochords/src/server/Main.hs
+++ b/website/sandbox/learnpianochords/src/server/Main.hs
@@ -2,7 +2,7 @@
 module Main where
 --------------------------------------------------------------------------------
 import RIO
-import Prelude (putStrLn)
+import Prelude (putStr, putStrLn)
 
 import qualified Types as T
 import qualified System.Envy as Envy
@@ -18,8 +18,8 @@ getAppContext = do
     Left err -> pure $ Left err
     Right T.Env{..} -> pure $ Right T.Context
       { contextGoogleClientID = envGoogleClientID
-      , contextClientPort = 8000
-      , contextServerPort = 3000
+      , contextServerPort = envServerPort
+      , contextClientPort = envClientPort
       }
 
 main :: IO ()
@@ -27,4 +27,10 @@ main = do
   mContext <- getAppContext
   case mContext of
     Left err -> putStrLn err
-    Right ctx -> runRIO ctx App.run
+    Right ctx -> do
+      result <- runRIO ctx App.run
+      case result of
+        Left err -> do
+          putStr "Something went wrong when executing the application: "
+          putStrLn $ show err
+        Right _ -> putStrLn "The application successfully executed."
diff --git a/website/sandbox/learnpianochords/src/server/Types.hs b/website/sandbox/learnpianochords/src/server/Types.hs
index a9e6661f6153..2303a752e4ad 100644
--- a/website/sandbox/learnpianochords/src/server/Types.hs
+++ b/website/sandbox/learnpianochords/src/server/Types.hs
@@ -9,11 +9,15 @@ import System.Envy (FromEnv, fromEnv, env)
 -- | Read from .envrc
 data Env = Env
   { envGoogleClientID :: !String
+  , envServerPort :: !Int
+  , envClientPort :: !Int
   } deriving (Eq, Show)
 
 instance FromEnv Env where
   fromEnv _ = do
     envGoogleClientID <- env "GOOGLE_CLIENT_ID"
+    envServerPort <- env "SERVER_PORT"
+    envClientPort <- env "CLIENT_PORT"
     pure Env {..}
 
 -- | Application context: a combination of Env and additional values.
@@ -23,8 +27,18 @@ data Context = Context
   , contextClientPort :: !Int
   }
 
--- | Type synonym for my application monad.
-type App = RIO Context
+-- | Top-level except for our application, as RIO recommends defining.
+type Failure = ()
+
+-- | When our app executes along the "happy path" this is the type of result it
+-- produces.
+type Success = ()
+
+-- | This is our application monad.
+type AppM = RIO Context
+
+-- | The concrete type of our application.
+type App = AppM (Either Failure Success)
 
 data VerifyGoogleSignInRequest = VerifyGoogleSignInRequest
   { idToken :: !Text
@@ -34,3 +48,28 @@ instance FromJSON VerifyGoogleSignInRequest where
   parseJSON = withObject "" $ \x -> do
     idToken <- x .: "idToken"
     pure VerifyGoogleSignInRequest{..}
+
+data GoogleLinkedAccount = GoogleLinkedAccount
+  {
+  -- { googleLinkedAccountUUID :: UUID
+  -- , googleLinkedAccountEmail :: Email
+  -- , googleLinkedAccountTsCreated :: Timestamp
+    googleLinkedAccountGivenName :: !(Maybe Text)
+  , googleLinkedAccountFamilyName :: !(Maybe Text)
+  , googleLinkedAccountFullName :: !(Maybe Text)
+  -- , googleLinkedAccountPictureURL :: URL
+  -- , googleLinkedAccountLocale :: Maybe Locale
+  } deriving (Eq, Show)
+
+data PayingCustomer = PayingCustomer
+  {
+  -- { payingCustomerAccountUUID :: UUID
+  -- , payingCustomerTsCreated :: Timestamp
+  } deriving (Eq, Show)
+
+data Session = Session
+  {
+  -- { sessionUUID :: UUID
+  -- , sessionAccountUUID :: UUID
+  -- , sessionTsCreated :: Timestamp
+  } deriving (Eq, Show)