{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DerivingStrategies    #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeOperators         #-}

module Playground.Server where

import Auth qualified
import Auth.Types (OAuthClientId (OAuthClientId), OAuthClientSecret (OAuthClientSecret))
import Control.Monad.Except (ExceptT, runExceptT, throwError)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Logger (LoggingT, runStderrLoggingT)
import Control.Monad.Reader (ReaderT, runReaderT)
import Data.Aeson (decodeFileStrict)
import Data.Bits (toIntegralSized)
import Data.ByteString.Lazy.Char8 qualified as BSL
import Data.Proxy (Proxy (Proxy))
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Time.Units (Second, toMicroseconds)
import Language.Haskell.Interpreter (InterpreterError (CompilationErrors), InterpreterResult, SourceCode)
import Language.Haskell.Interpreter qualified as Interpreter
import Network.HTTP.Client.Conduit (defaultManagerSettings, managerResponseTimeout, responseTimeoutMicro)
import Network.HTTP.Conduit (newManager)
import Network.Wai.Middleware.Cors (cors, simpleCorsResourcePolicy)
import Playground.Interpreter qualified as PI
import Playground.Types (CompilationResult, Evaluation, EvaluationResult, PlaygroundError)
import Playground.Usecases (vesting)
import Servant (Application, err400, errBody, hoistServer, serve)
import Servant.API (Get, JSON, Post, ReqBody, (:<|>) ((:<|>)), (:>))
import Servant.Client (ClientEnv, mkClientEnv, parseBaseUrl)
import Servant.Server (Handler (Handler), Server, ServerError)
import System.Environment (lookupEnv)
import Web.JWT qualified as JWT

type API
     = "contract" :> ReqBody '[ JSON] SourceCode :> Post '[ JSON] (Either Interpreter.InterpreterError (InterpreterResult CompilationResult))
       :<|> "evaluate" :> ReqBody '[ JSON] Evaluation :> Post '[ JSON] (Either PlaygroundError EvaluationResult)
       :<|> "health" :> Get '[ JSON] ()

type Web = "api" :> (API :<|> Auth.API)

compileSourceCode ::
       ClientEnv
    -> SourceCode
    -> Handler (Either InterpreterError (InterpreterResult CompilationResult))
compileSourceCode :: ClientEnv
-> SourceCode
-> Handler
     (Either InterpreterError (InterpreterResult CompilationResult))
compileSourceCode ClientEnv
clientEnv SourceCode
sourceCode = do
    Either InterpreterError (InterpreterResult CompilationResult)
r <- IO (Either InterpreterError (InterpreterResult CompilationResult))
-> Handler
     (Either InterpreterError (InterpreterResult CompilationResult))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either InterpreterError (InterpreterResult CompilationResult))
 -> Handler
      (Either InterpreterError (InterpreterResult CompilationResult)))
-> (ExceptT
      InterpreterError IO (InterpreterResult CompilationResult)
    -> IO
         (Either InterpreterError (InterpreterResult CompilationResult)))
-> ExceptT
     InterpreterError IO (InterpreterResult CompilationResult)
-> Handler
     (Either InterpreterError (InterpreterResult CompilationResult))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT InterpreterError IO (InterpreterResult CompilationResult)
-> IO
     (Either InterpreterError (InterpreterResult CompilationResult))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT InterpreterError IO (InterpreterResult CompilationResult)
 -> Handler
      (Either InterpreterError (InterpreterResult CompilationResult)))
-> ExceptT
     InterpreterError IO (InterpreterResult CompilationResult)
-> Handler
     (Either InterpreterError (InterpreterResult CompilationResult))
forall a b. (a -> b) -> a -> b
$ ClientEnv
-> SourceCode
-> ExceptT
     InterpreterError IO (InterpreterResult CompilationResult)
forall (m :: * -> *).
(MonadMask m, MonadIO m, MonadError InterpreterError m) =>
ClientEnv -> SourceCode -> m (InterpreterResult CompilationResult)
PI.compile ClientEnv
clientEnv SourceCode
sourceCode
    case Either InterpreterError (InterpreterResult CompilationResult)
r of
        Right InterpreterResult CompilationResult
vs -> Either InterpreterError (InterpreterResult CompilationResult)
-> Handler
     (Either InterpreterError (InterpreterResult CompilationResult))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either InterpreterError (InterpreterResult CompilationResult)
 -> Handler
      (Either InterpreterError (InterpreterResult CompilationResult)))
-> (InterpreterResult CompilationResult
    -> Either InterpreterError (InterpreterResult CompilationResult))
-> InterpreterResult CompilationResult
-> Handler
     (Either InterpreterError (InterpreterResult CompilationResult))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InterpreterResult CompilationResult
-> Either InterpreterError (InterpreterResult CompilationResult)
forall a b. b -> Either a b
Right (InterpreterResult CompilationResult
 -> Handler
      (Either InterpreterError (InterpreterResult CompilationResult)))
-> InterpreterResult CompilationResult
-> Handler
     (Either InterpreterError (InterpreterResult CompilationResult))
forall a b. (a -> b) -> a -> b
$ InterpreterResult CompilationResult
vs
        Left (CompilationErrors [CompilationError]
errors) ->
            Either InterpreterError (InterpreterResult CompilationResult)
-> Handler
     (Either InterpreterError (InterpreterResult CompilationResult))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either InterpreterError (InterpreterResult CompilationResult)
 -> Handler
      (Either InterpreterError (InterpreterResult CompilationResult)))
-> (InterpreterError
    -> Either InterpreterError (InterpreterResult CompilationResult))
-> InterpreterError
-> Handler
     (Either InterpreterError (InterpreterResult CompilationResult))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InterpreterError
-> Either InterpreterError (InterpreterResult CompilationResult)
forall a b. a -> Either a b
Left (InterpreterError
 -> Handler
      (Either InterpreterError (InterpreterResult CompilationResult)))
-> InterpreterError
-> Handler
     (Either InterpreterError (InterpreterResult CompilationResult))
forall a b. (a -> b) -> a -> b
$ [CompilationError] -> InterpreterError
CompilationErrors [CompilationError]
errors
        Left InterpreterError
e -> ServerError
-> Handler
     (Either InterpreterError (InterpreterResult CompilationResult))
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ServerError
 -> Handler
      (Either InterpreterError (InterpreterResult CompilationResult)))
-> ServerError
-> Handler
     (Either InterpreterError (InterpreterResult CompilationResult))
forall a b. (a -> b) -> a -> b
$ ServerError
err400 {errBody :: ByteString
errBody = [Char] -> ByteString
BSL.pack ([Char] -> ByteString)
-> (InterpreterError -> [Char]) -> InterpreterError -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InterpreterError -> [Char]
forall a. Show a => a -> [Char]
show (InterpreterError -> ByteString) -> InterpreterError -> ByteString
forall a b. (a -> b) -> a -> b
$ InterpreterError
e}

evaluateSimulation ::
       ClientEnv -> Evaluation -> Handler (Either PlaygroundError EvaluationResult)
evaluateSimulation :: ClientEnv
-> Evaluation -> Handler (Either PlaygroundError EvaluationResult)
evaluateSimulation ClientEnv
clientEnv Evaluation
evaluation = do
    Either PlaygroundError (InterpreterResult EvaluationResult)
result <-
        IO (Either PlaygroundError (InterpreterResult EvaluationResult))
-> Handler
     (Either PlaygroundError (InterpreterResult EvaluationResult))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either PlaygroundError (InterpreterResult EvaluationResult))
 -> Handler
      (Either PlaygroundError (InterpreterResult EvaluationResult)))
-> (ExceptT PlaygroundError IO (InterpreterResult EvaluationResult)
    -> IO
         (Either PlaygroundError (InterpreterResult EvaluationResult)))
-> ExceptT PlaygroundError IO (InterpreterResult EvaluationResult)
-> Handler
     (Either PlaygroundError (InterpreterResult EvaluationResult))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT PlaygroundError IO (InterpreterResult EvaluationResult)
-> IO (Either PlaygroundError (InterpreterResult EvaluationResult))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT PlaygroundError IO (InterpreterResult EvaluationResult)
 -> Handler
      (Either PlaygroundError (InterpreterResult EvaluationResult)))
-> ExceptT PlaygroundError IO (InterpreterResult EvaluationResult)
-> Handler
     (Either PlaygroundError (InterpreterResult EvaluationResult))
forall a b. (a -> b) -> a -> b
$
        ClientEnv
-> Evaluation
-> ExceptT PlaygroundError IO (InterpreterResult EvaluationResult)
forall (m :: * -> *).
(MonadMask m, MonadIO m, MonadError PlaygroundError m) =>
ClientEnv -> Evaluation -> m (InterpreterResult EvaluationResult)
PI.evaluateSimulation ClientEnv
clientEnv Evaluation
evaluation
    Either PlaygroundError EvaluationResult
-> Handler (Either PlaygroundError EvaluationResult)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either PlaygroundError EvaluationResult
 -> Handler (Either PlaygroundError EvaluationResult))
-> Either PlaygroundError EvaluationResult
-> Handler (Either PlaygroundError EvaluationResult)
forall a b. (a -> b) -> a -> b
$ InterpreterResult EvaluationResult -> EvaluationResult
forall a. InterpreterResult a -> a
Interpreter.result (InterpreterResult EvaluationResult -> EvaluationResult)
-> Either PlaygroundError (InterpreterResult EvaluationResult)
-> Either PlaygroundError EvaluationResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either PlaygroundError (InterpreterResult EvaluationResult)
result

checkHealth :: ClientEnv -> Handler ()
checkHealth :: ClientEnv -> Handler ()
checkHealth ClientEnv
clientEnv =
    ClientEnv
-> SourceCode
-> Handler
     (Either InterpreterError (InterpreterResult CompilationResult))
compileSourceCode ClientEnv
clientEnv SourceCode
vesting Handler
  (Either InterpreterError (InterpreterResult CompilationResult))
-> (Either InterpreterError (InterpreterResult CompilationResult)
    -> Handler ())
-> Handler ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left InterpreterError
e  -> ServerError -> Handler ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ServerError -> Handler ()) -> ServerError -> Handler ()
forall a b. (a -> b) -> a -> b
$ ServerError
err400 {errBody :: ByteString
errBody = [Char] -> ByteString
BSL.pack ([Char] -> ByteString)
-> (InterpreterError -> [Char]) -> InterpreterError -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InterpreterError -> [Char]
forall a. Show a => a -> [Char]
show (InterpreterError -> ByteString) -> InterpreterError -> ByteString
forall a b. (a -> b) -> a -> b
$ InterpreterError
e}
        Right InterpreterResult CompilationResult
_ -> () -> Handler ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

liftedAuthServer :: Auth.GithubEndpoints -> Auth.Config -> Server Auth.API
liftedAuthServer :: GithubEndpoints -> Config -> Server API
liftedAuthServer GithubEndpoints
githubEndpoints Config
config =
  Proxy API
-> (forall x.
    ReaderT
      (GithubEndpoints, Config) (LoggingT (ExceptT ServerError IO)) x
    -> Handler x)
-> ServerT
     API
     (ReaderT
        (GithubEndpoints, Config) (LoggingT (ExceptT ServerError IO)))
-> Server API
forall api (m :: * -> *) (n :: * -> *).
HasServer api '[] =>
Proxy api
-> (forall x. m x -> n x) -> ServerT api m -> ServerT api n
hoistServer (Proxy API
forall k (t :: k). Proxy t
Proxy @Auth.API) forall x.
ReaderT
  (GithubEndpoints, Config) (LoggingT (ExceptT ServerError IO)) x
-> Handler x
liftAuthToHandler ServerT
  API
  (ReaderT
     (GithubEndpoints, Config) (LoggingT (ExceptT ServerError IO)))
forall (m :: * -> *).
(MonadNow m, MonadWeb m, MonadLogger m, MonadError ServerError m,
 MonadIO m, MonadReader (GithubEndpoints, Config) m) =>
ServerT API m
Auth.server
  where
    liftAuthToHandler ::
      ReaderT (Auth.GithubEndpoints, Auth.Config) (LoggingT (ExceptT ServerError IO)) a ->
      Handler a
    liftAuthToHandler :: ReaderT
  (GithubEndpoints, Config) (LoggingT (ExceptT ServerError IO)) a
-> Handler a
liftAuthToHandler =
      ExceptT ServerError IO a -> Handler a
forall a. ExceptT ServerError IO a -> Handler a
Handler (ExceptT ServerError IO a -> Handler a)
-> (ReaderT
      (GithubEndpoints, Config) (LoggingT (ExceptT ServerError IO)) a
    -> ExceptT ServerError IO a)
-> ReaderT
     (GithubEndpoints, Config) (LoggingT (ExceptT ServerError IO)) a
-> Handler a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoggingT (ExceptT ServerError IO) a -> ExceptT ServerError IO a
forall (m :: * -> *) a. MonadIO m => LoggingT m a -> m a
runStderrLoggingT (LoggingT (ExceptT ServerError IO) a -> ExceptT ServerError IO a)
-> (ReaderT
      (GithubEndpoints, Config) (LoggingT (ExceptT ServerError IO)) a
    -> LoggingT (ExceptT ServerError IO) a)
-> ReaderT
     (GithubEndpoints, Config) (LoggingT (ExceptT ServerError IO)) a
-> ExceptT ServerError IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReaderT
   (GithubEndpoints, Config) (LoggingT (ExceptT ServerError IO)) a
 -> (GithubEndpoints, Config)
 -> LoggingT (ExceptT ServerError IO) a)
-> (GithubEndpoints, Config)
-> ReaderT
     (GithubEndpoints, Config) (LoggingT (ExceptT ServerError IO)) a
-> LoggingT (ExceptT ServerError IO) a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT
  (GithubEndpoints, Config) (LoggingT (ExceptT ServerError IO)) a
-> (GithubEndpoints, Config) -> LoggingT (ExceptT ServerError IO) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (GithubEndpoints
githubEndpoints, Config
config)

mkHandlers :: MonadIO m => AppConfig -> m (Server Web)
mkHandlers :: AppConfig -> m (Server Web)
mkHandlers AppConfig {Config
ClientEnv
clientEnv :: AppConfig -> ClientEnv
authConfig :: AppConfig -> Config
clientEnv :: ClientEnv
authConfig :: Config
..} = do
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"Interpreter ready"
    GithubEndpoints
githubEndpoints <- IO GithubEndpoints -> m GithubEndpoints
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO GithubEndpoints
Auth.mkGithubEndpoints
    (((SourceCode
   -> Handler
        (Either InterpreterError (InterpreterResult CompilationResult)))
  :<|> ((Evaluation
         -> Handler (Either PlaygroundError EvaluationResult))
        :<|> Handler ()))
 :<|> ((((Maybe Text -> Handler AuthStatus)
         :<|> Handler (Headers '[Header "Location" Text] NoContent))
        :<|> (Maybe Text
              -> Handler [Gist]
                 :<|> ((NewGist -> Handler Gist)
                       :<|> ((GistId -> Handler Gist)
                             :<|> (GistId -> NewGist -> Handler Gist)))))
       :<|> (Maybe OAuthCode
             -> Handler
                  (Headers
                     '[Header "Set-Cookie" SetCookie, Header "Location" Text]
                     NoContent))))
-> m (((SourceCode
        -> Handler
             (Either InterpreterError (InterpreterResult CompilationResult)))
       :<|> ((Evaluation
              -> Handler (Either PlaygroundError EvaluationResult))
             :<|> Handler ()))
      :<|> ((((Maybe Text -> Handler AuthStatus)
              :<|> Handler (Headers '[Header "Location" Text] NoContent))
             :<|> (Maybe Text
                   -> Handler [Gist]
                      :<|> ((NewGist -> Handler Gist)
                            :<|> ((GistId -> Handler Gist)
                                  :<|> (GistId -> NewGist -> Handler Gist)))))
            :<|> (Maybe OAuthCode
                  -> Handler
                       (Headers
                          '[Header "Set-Cookie" SetCookie, Header "Location" Text]
                          NoContent))))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((((SourceCode
    -> Handler
         (Either InterpreterError (InterpreterResult CompilationResult)))
   :<|> ((Evaluation
          -> Handler (Either PlaygroundError EvaluationResult))
         :<|> Handler ()))
  :<|> ((((Maybe Text -> Handler AuthStatus)
          :<|> Handler (Headers '[Header "Location" Text] NoContent))
         :<|> (Maybe Text
               -> Handler [Gist]
                  :<|> ((NewGist -> Handler Gist)
                        :<|> ((GistId -> Handler Gist)
                              :<|> (GistId -> NewGist -> Handler Gist)))))
        :<|> (Maybe OAuthCode
              -> Handler
                   (Headers
                      '[Header "Set-Cookie" SetCookie, Header "Location" Text]
                      NoContent))))
 -> m (((SourceCode
         -> Handler
              (Either InterpreterError (InterpreterResult CompilationResult)))
        :<|> ((Evaluation
               -> Handler (Either PlaygroundError EvaluationResult))
              :<|> Handler ()))
       :<|> ((((Maybe Text -> Handler AuthStatus)
               :<|> Handler (Headers '[Header "Location" Text] NoContent))
              :<|> (Maybe Text
                    -> Handler [Gist]
                       :<|> ((NewGist -> Handler Gist)
                             :<|> ((GistId -> Handler Gist)
                                   :<|> (GistId -> NewGist -> Handler Gist)))))
             :<|> (Maybe OAuthCode
                   -> Handler
                        (Headers
                           '[Header "Set-Cookie" SetCookie, Header "Location" Text]
                           NoContent)))))
-> (((SourceCode
      -> Handler
           (Either InterpreterError (InterpreterResult CompilationResult)))
     :<|> ((Evaluation
            -> Handler (Either PlaygroundError EvaluationResult))
           :<|> Handler ()))
    :<|> ((((Maybe Text -> Handler AuthStatus)
            :<|> Handler (Headers '[Header "Location" Text] NoContent))
           :<|> (Maybe Text
                 -> Handler [Gist]
                    :<|> ((NewGist -> Handler Gist)
                          :<|> ((GistId -> Handler Gist)
                                :<|> (GistId -> NewGist -> Handler Gist)))))
          :<|> (Maybe OAuthCode
                -> Handler
                     (Headers
                        '[Header "Set-Cookie" SetCookie, Header "Location" Text]
                        NoContent))))
-> m (((SourceCode
        -> Handler
             (Either InterpreterError (InterpreterResult CompilationResult)))
       :<|> ((Evaluation
              -> Handler (Either PlaygroundError EvaluationResult))
             :<|> Handler ()))
      :<|> ((((Maybe Text -> Handler AuthStatus)
              :<|> Handler (Headers '[Header "Location" Text] NoContent))
             :<|> (Maybe Text
                   -> Handler [Gist]
                      :<|> ((NewGist -> Handler Gist)
                            :<|> ((GistId -> Handler Gist)
                                  :<|> (GistId -> NewGist -> Handler Gist)))))
            :<|> (Maybe OAuthCode
                  -> Handler
                       (Headers
                          '[Header "Set-Cookie" SetCookie, Header "Location" Text]
                          NoContent))))
forall a b. (a -> b) -> a -> b
$ (ClientEnv
-> SourceCode
-> Handler
     (Either InterpreterError (InterpreterResult CompilationResult))
compileSourceCode ClientEnv
clientEnv (SourceCode
 -> Handler
      (Either InterpreterError (InterpreterResult CompilationResult)))
-> ((Evaluation
     -> Handler (Either PlaygroundError EvaluationResult))
    :<|> Handler ())
-> (SourceCode
    -> Handler
         (Either InterpreterError (InterpreterResult CompilationResult)))
   :<|> ((Evaluation
          -> Handler (Either PlaygroundError EvaluationResult))
         :<|> Handler ())
forall a b. a -> b -> a :<|> b
:<|> ClientEnv
-> Evaluation -> Handler (Either PlaygroundError EvaluationResult)
evaluateSimulation ClientEnv
clientEnv (Evaluation -> Handler (Either PlaygroundError EvaluationResult))
-> Handler ()
-> (Evaluation
    -> Handler (Either PlaygroundError EvaluationResult))
   :<|> Handler ()
forall a b. a -> b -> a :<|> b
:<|> ClientEnv -> Handler ()
checkHealth ClientEnv
clientEnv) ((SourceCode
  -> Handler
       (Either InterpreterError (InterpreterResult CompilationResult)))
 :<|> ((Evaluation
        -> Handler (Either PlaygroundError EvaluationResult))
       :<|> Handler ()))
-> ((((Maybe Text -> Handler AuthStatus)
      :<|> Handler (Headers '[Header "Location" Text] NoContent))
     :<|> (Maybe Text
           -> Handler [Gist]
              :<|> ((NewGist -> Handler Gist)
                    :<|> ((GistId -> Handler Gist)
                          :<|> (GistId -> NewGist -> Handler Gist)))))
    :<|> (Maybe OAuthCode
          -> Handler
               (Headers
                  '[Header "Set-Cookie" SetCookie, Header "Location" Text]
                  NoContent)))
-> ((SourceCode
     -> Handler
          (Either InterpreterError (InterpreterResult CompilationResult)))
    :<|> ((Evaluation
           -> Handler (Either PlaygroundError EvaluationResult))
          :<|> Handler ()))
   :<|> ((((Maybe Text -> Handler AuthStatus)
           :<|> Handler (Headers '[Header "Location" Text] NoContent))
          :<|> (Maybe Text
                -> Handler [Gist]
                   :<|> ((NewGist -> Handler Gist)
                         :<|> ((GistId -> Handler Gist)
                               :<|> (GistId -> NewGist -> Handler Gist)))))
         :<|> (Maybe OAuthCode
               -> Handler
                    (Headers
                       '[Header "Set-Cookie" SetCookie, Header "Location" Text]
                       NoContent)))
forall a b. a -> b -> a :<|> b
:<|> GithubEndpoints -> Config -> Server API
liftedAuthServer GithubEndpoints
githubEndpoints Config
authConfig

app :: Server Web -> Application
app :: Server Web -> Application
app Server Web
handlers =
  (Request -> Maybe CorsResourcePolicy) -> Middleware
cors (Maybe CorsResourcePolicy -> Request -> Maybe CorsResourcePolicy
forall a b. a -> b -> a
const (Maybe CorsResourcePolicy -> Request -> Maybe CorsResourcePolicy)
-> Maybe CorsResourcePolicy -> Request -> Maybe CorsResourcePolicy
forall a b. (a -> b) -> a -> b
$ CorsResourcePolicy -> Maybe CorsResourcePolicy
forall a. a -> Maybe a
Just CorsResourcePolicy
policy) Middleware -> Middleware
forall a b. (a -> b) -> a -> b
$ Proxy Web -> Server Web -> Application
forall api.
HasServer api '[] =>
Proxy api -> Server api -> Application
serve (Proxy Web
forall k (t :: k). Proxy t
Proxy @Web) Server Web
handlers
  where
    policy :: CorsResourcePolicy
policy =
      CorsResourcePolicy
simpleCorsResourcePolicy

data AppConfig = AppConfig { AppConfig -> Config
authConfig :: Auth.Config, AppConfig -> ClientEnv
clientEnv :: ClientEnv }

initializeServerContext :: MonadIO m => Second -> Maybe FilePath -> m AppConfig
initializeServerContext :: Second -> Maybe [Char] -> m AppConfig
initializeServerContext Second
maxInterpretationTime Maybe [Char]
secrets = IO AppConfig -> m AppConfig
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO AppConfig -> m AppConfig) -> IO AppConfig -> m AppConfig
forall a b. (a -> b) -> a -> b
$ do
  [Char] -> IO ()
putStrLn [Char]
"Initializing Context"
  Config
authConfig <- Maybe [Char] -> IO Config
forall (m :: * -> *). MonadIO m => Maybe [Char] -> m Config
mkAuthConfig Maybe [Char]
secrets
  Maybe [Char]
mWebghcURL <- [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"WEBGHC_URL"
  BaseUrl
webghcURL <- case Maybe [Char]
mWebghcURL of
    Just [Char]
url -> [Char] -> IO BaseUrl
forall (m :: * -> *). MonadThrow m => [Char] -> m BaseUrl
parseBaseUrl [Char]
url
    Maybe [Char]
Nothing -> do
      let localhost :: [Char]
localhost = [Char]
"http://localhost:8009"
      [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"WEBGHC_URL not set, using " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
localhost
      [Char] -> IO BaseUrl
forall (m :: * -> *). MonadThrow m => [Char] -> m BaseUrl
parseBaseUrl [Char]
localhost
  Manager
manager <- ManagerSettings -> IO Manager
newManager (ManagerSettings -> IO Manager) -> ManagerSettings -> IO Manager
forall a b. (a -> b) -> a -> b
$ ManagerSettings
defaultManagerSettings
    { managerResponseTimeout :: ResponseTimeout
managerResponseTimeout = ResponseTimeout
-> (Int -> ResponseTimeout) -> Maybe Int -> ResponseTimeout
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      (ManagerSettings -> ResponseTimeout
managerResponseTimeout ManagerSettings
defaultManagerSettings)
      Int -> ResponseTimeout
responseTimeoutMicro (Maybe Int -> ResponseTimeout)
-> (Integer -> Maybe Int) -> Integer -> ResponseTimeout
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Maybe Int
forall a b.
(Integral a, Integral b, Bits a, Bits b) =>
a -> Maybe b
toIntegralSized
      (Integer -> ResponseTimeout) -> Integer -> ResponseTimeout
forall a b. (a -> b) -> a -> b
$ Second -> Integer
forall a. TimeUnit a => a -> Integer
toMicroseconds Second
maxInterpretationTime
    }
  let clientEnv :: ClientEnv
clientEnv = Manager -> BaseUrl -> ClientEnv
mkClientEnv Manager
manager BaseUrl
webghcURL
  AppConfig -> IO AppConfig
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AppConfig -> IO AppConfig) -> AppConfig -> IO AppConfig
forall a b. (a -> b) -> a -> b
$ Config -> ClientEnv -> AppConfig
AppConfig Config
authConfig ClientEnv
clientEnv

mkAuthConfig :: MonadIO m => Maybe FilePath -> m Auth.Config
mkAuthConfig :: Maybe [Char] -> m Config
mkAuthConfig (Just [Char]
path) = do
  Maybe Config
mConfig <- IO (Maybe Config) -> m (Maybe Config)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Config) -> m (Maybe Config))
-> IO (Maybe Config) -> m (Maybe Config)
forall a b. (a -> b) -> a -> b
$ [Char] -> IO (Maybe Config)
forall a. FromJSON a => [Char] -> IO (Maybe a)
decodeFileStrict [Char]
path
  case Maybe Config
mConfig of
    Just Config
config -> Config -> m Config
forall (f :: * -> *) a. Applicative f => a -> f a
pure Config
config
    Maybe Config
Nothing -> do
      IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"failed to decode " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
path
      Maybe [Char] -> m Config
forall (m :: * -> *). MonadIO m => Maybe [Char] -> m Config
mkAuthConfig Maybe [Char]
forall a. Maybe a
Nothing
mkAuthConfig Maybe [Char]
Nothing = IO Config -> m Config
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Config -> m Config) -> IO Config -> m Config
forall a b. (a -> b) -> a -> b
$ do
  [Char] -> IO ()
putStrLn [Char]
"Initializing Context"
  Text
githubClientId <- [Char] -> IO Text
getEnvOrEmpty [Char]
"GITHUB_CLIENT_ID"
  Text
githubClientSecret <- [Char] -> IO Text
getEnvOrEmpty [Char]
"GITHUB_CLIENT_SECRET"
  Text
jwtSignature <- [Char] -> IO Text
getEnvOrEmpty [Char]
"JWT_SIGNATURE"
  Text
frontendURL <- [Char] -> IO Text
getEnvOrEmpty [Char]
"FRONTEND_URL"
  Text
cbPath <- [Char] -> IO Text
getEnvOrEmpty [Char]
"GITHUB_CALLBACK_PATH"
  Config -> IO Config
forall (f :: * -> *) a. Applicative f => a -> f a
pure Config :: EncodeSigner
-> Text -> Text -> OAuthClientId -> OAuthClientSecret -> Config
Auth.Config
          { _configJWTSignature :: EncodeSigner
_configJWTSignature = Text -> EncodeSigner
JWT.hmacSecret Text
jwtSignature,
            _configFrontendUrl :: Text
_configFrontendUrl = Text
frontendURL,
            _configGithubCbPath :: Text
_configGithubCbPath = Text
cbPath,
            _configGithubClientId :: OAuthClientId
_configGithubClientId = Text -> OAuthClientId
OAuthClientId Text
githubClientId,
            _configGithubClientSecret :: OAuthClientSecret
_configGithubClientSecret = Text -> OAuthClientSecret
OAuthClientSecret Text
githubClientSecret
          }

getEnvOrEmpty :: String -> IO Text
getEnvOrEmpty :: [Char] -> IO Text
getEnvOrEmpty [Char]
name = do
  Maybe [Char]
mEnv <- [Char] -> IO (Maybe [Char])
lookupEnv [Char]
name
  case Maybe [Char]
mEnv of
    Just [Char]
env -> Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
Text.pack [Char]
env
    Maybe [Char]
Nothing -> do
      [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Warning: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
name [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" not set"
      Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
forall a. Monoid a => a
mempty

initializeApplication :: AppConfig -> IO Application
initializeApplication :: AppConfig -> IO Application
initializeApplication AppConfig
config = do
  ((SourceCode
  -> Handler
       (Either InterpreterError (InterpreterResult CompilationResult)))
 :<|> ((Evaluation
        -> Handler (Either PlaygroundError EvaluationResult))
       :<|> Handler ()))
:<|> ((((Maybe Text -> Handler AuthStatus)
        :<|> Handler (Headers '[Header "Location" Text] NoContent))
       :<|> (Maybe Text
             -> Handler [Gist]
                :<|> ((NewGist -> Handler Gist)
                      :<|> ((GistId -> Handler Gist)
                            :<|> (GistId -> NewGist -> Handler Gist)))))
      :<|> (Maybe OAuthCode
            -> Handler
                 (Headers
                    '[Header "Set-Cookie" SetCookie, Header "Location" Text]
                    NoContent)))
handlers <- AppConfig -> IO (Server Web)
forall (m :: * -> *). MonadIO m => AppConfig -> m (Server Web)
mkHandlers AppConfig
config
  Application -> IO Application
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Application -> IO Application) -> Application -> IO Application
forall a b. (a -> b) -> a -> b
$ Server Web -> Application
app ((SourceCode
  -> Handler
       (Either InterpreterError (InterpreterResult CompilationResult)))
 :<|> ((Evaluation
        -> Handler (Either PlaygroundError EvaluationResult))
       :<|> Handler ()))
:<|> ((((Maybe Text -> Handler AuthStatus)
        :<|> Handler (Headers '[Header "Location" Text] NoContent))
       :<|> (Maybe Text
             -> Handler [Gist]
                :<|> ((NewGist -> Handler Gist)
                      :<|> ((GistId -> Handler Gist)
                            :<|> (GistId -> NewGist -> Handler Gist)))))
      :<|> (Maybe OAuthCode
            -> Handler
                 (Headers
                    '[Header "Set-Cookie" SetCookie, Header "Location" Text]
                    NoContent)))
Server Web
handlers