diff options
| -rw-r--r-- | website/sandbox/learnpianochords/src/server/App.hs | 18 | ||||
| -rw-r--r-- | website/sandbox/learnpianochords/src/server/Main.hs | 14 | ||||
| -rw-r--r-- | website/sandbox/learnpianochords/src/server/Types.hs | 43 |
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) |