module IHP.IDE.ToolServer where import IHP.Prelude import qualified Network.Wai as Wai import qualified Network.Wai.Handler.Warp as Warp import IHP.IDE.Types import IHP.IDE.PortConfig import qualified IHP.ControllerSupport as ControllerSupport import qualified IHP.ErrorController as ErrorController import IHP.ApplicationContext import IHP.ModelSupport import IHP.RouterSupport hiding (get) import Network.Wai.Session.ClientSession (clientsessionStore) import qualified Web.ClientSession as ClientSession import qualified Data.Vault.Lazy as Vault import Network.Wai.Middleware.MethodOverridePost (methodOverridePost) import Network.Wai.Middleware.Static hiding ((<|>)) import Network.Wai.Session (withSession) import qualified Network.WebSockets as Websocket import qualified Network.Wai.Handler.WebSockets as Websocket import qualified IHP.FrameworkConfig as Config import IHP.IDE.SchemaDesigner.Controller.EnumValues () import IHP.IDE.SchemaDesigner.Controller.Enums () import IHP.IDE.SchemaDesigner.Controller.Columns () import IHP.IDE.SchemaDesigner.Controller.Policies () import IHP.IDE.SchemaDesigner.Controller.Schema () import IHP.IDE.SchemaDesigner.Controller.Tables () import IHP.IDE.SchemaDesigner.Controller.Migrations () import IHP.IDE.Data.Controller () import IHP.IDE.Logs.Controller () import IHP.IDE.CodeGen.Controller () import IHP.IDE.ToolServer.Types import IHP.IDE.ToolServer.Helper.Controller as Helper import IHP.IDE.ToolServer.Routes () import qualified System.Process as Process import System.Info import qualified System.Environment as Env import qualified IHP.AutoRefresh.Types as AutoRefresh import IHP.Controller.Context import qualified IHP.IDE.ToolServer.Layout as Layout import IHP.Controller.Layout import qualified IHP.LibDir as LibDir import qualified IHP.IDE.LiveReloadNotificationServer as LiveReloadNotificationServer import qualified IHP.Version as Version import qualified IHP.IDE.Types import qualified IHP.PGListener as PGListener startToolServer :: (?context :: Context) => IO () startToolServer :: IO () startToolServer = do let port :: Int port = ?context::Context Context ?context Context -> (Context -> PortConfig) -> PortConfig forall t1 t2. t1 -> (t1 -> t2) -> t2 |> Proxy "portConfig" -> Context -> PortConfig forall model (name :: Symbol) value. (KnownSymbol name, HasField name model value) => Proxy name -> model -> value get IsLabel "portConfig" (Proxy "portConfig") Proxy "portConfig" #portConfig PortConfig -> (PortConfig -> PortNumber) -> PortNumber forall t1 t2. t1 -> (t1 -> t2) -> t2 |> Proxy "toolServerPort" -> PortConfig -> PortNumber forall model (name :: Symbol) value. (KnownSymbol name, HasField name model value) => Proxy name -> model -> value get IsLabel "toolServerPort" (Proxy "toolServerPort") Proxy "toolServerPort" #toolServerPort PortNumber -> (PortNumber -> Int) -> Int forall t1 t2. t1 -> (t1 -> t2) -> t2 |> PortNumber -> Int forall a b. (Integral a, Num b) => a -> b fromIntegral let isDebugMode :: Bool isDebugMode = ?context::Context Context ?context Context -> (Context -> Bool) -> Bool forall t1 t2. t1 -> (t1 -> t2) -> t2 |> Proxy "isDebugMode" -> Context -> Bool forall model (name :: Symbol) value. (KnownSymbol name, HasField name model value) => Proxy name -> model -> value get IsLabel "isDebugMode" (Proxy "isDebugMode") Proxy "isDebugMode" #isDebugMode Async () thread <- IO () -> IO (Async ()) forall a. IO a -> IO (Async a) async ((?context::Context) => Int -> Bool -> IO () Int -> Bool -> IO () startToolServer' Int port Bool isDebugMode) (?context::Context) => Action -> IO () Action -> IO () dispatch (ToolServerState -> Action UpdateToolServerState (ToolServerStarted :: Async () -> ToolServerState ToolServerStarted { Async () $sel:thread:ToolServerNotStarted :: Async () thread :: Async () thread })) startToolServer' :: (?context :: Context) => Int -> Bool -> IO () startToolServer' :: Int -> Bool -> IO () startToolServer' Int port Bool isDebugMode = do FrameworkConfig frameworkConfig <- ConfigBuilder -> IO FrameworkConfig Config.buildFrameworkConfig do AppHostname -> ConfigBuilder forall option. Typeable option => option -> ConfigBuilder Config.option (AppHostname -> ConfigBuilder) -> AppHostname -> ConfigBuilder forall a b. (a -> b) -> a -> b $ Text -> AppHostname Config.AppHostname Text "localhost" AppPort -> ConfigBuilder forall option. Typeable option => option -> ConfigBuilder Config.option (AppPort -> ConfigBuilder) -> AppPort -> ConfigBuilder forall a b. (a -> b) -> a -> b $ Int -> AppPort Config.AppPort Int port AssetVersion -> ConfigBuilder forall option. Typeable option => option -> ConfigBuilder Config.option (AssetVersion -> ConfigBuilder) -> AssetVersion -> ConfigBuilder forall a b. (a -> b) -> a -> b $ Text -> AssetVersion Config.AssetVersion Text Version.ihpVersion Maybe String ihpIdeBaseUrlEnvVar <- IO (Maybe String) -> StateT TMap IO (Maybe String) forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (String -> IO (Maybe String) Env.lookupEnv String "IHP_IDE_BASEURL") case Maybe String ihpIdeBaseUrlEnvVar of Just String baseUrl -> BaseUrl -> ConfigBuilder forall option. Typeable option => option -> ConfigBuilder Config.option (BaseUrl -> ConfigBuilder) -> BaseUrl -> ConfigBuilder forall a b. (a -> b) -> a -> b $ Text -> BaseUrl Config.BaseUrl (String -> Text forall a b. ConvertibleStrings a b => a -> b cs String baseUrl) Maybe String Nothing -> () -> ConfigBuilder forall (f :: * -> *) a. Applicative f => a -> f a pure () Key (Session IO ByteString ByteString) session <- IO (Key (Session IO ByteString ByteString)) forall a. IO (Key a) Vault.newKey SessionStore IO ByteString ByteString store <- (Key -> SessionStore IO ByteString ByteString) -> IO Key -> IO (SessionStore IO ByteString ByteString) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap Key -> SessionStore IO ByteString ByteString forall k v (m :: * -> *). (Serialize k, Serialize v, Eq k, MonadIO m) => Key -> SessionStore m k v clientsessionStore (String -> IO Key ClientSession.getKey String "Config/client_session_key.aes") let Middleware sessionMiddleware :: Wai.Middleware = SessionStore IO ByteString ByteString -> ByteString -> SetCookie -> Key (Session IO ByteString ByteString) -> Middleware forall (m :: * -> *) k v. SessionStore m k v -> ByteString -> SetCookie -> Key (Session m k v) -> Middleware withSession SessionStore IO ByteString ByteString store ByteString "SESSION" (Proxy "sessionCookie" -> FrameworkConfig -> SetCookie forall model (name :: Symbol) value. (KnownSymbol name, HasField name model value) => Proxy name -> model -> value get IsLabel "sessionCookie" (Proxy "sessionCookie") Proxy "sessionCookie" #sessionCookie FrameworkConfig frameworkConfig) Key (Session IO ByteString ByteString) session let modelContext :: ModelContext modelContext = Logger -> ModelContext notConnectedModelContext Logger forall a. HasCallStack => a undefined PGListener pgListener <- ModelContext -> IO PGListener PGListener.init ModelContext modelContext IORef AutoRefreshServer autoRefreshServer <- AutoRefreshServer -> IO (IORef AutoRefreshServer) forall a. a -> IO (IORef a) newIORef (PGListener -> AutoRefreshServer AutoRefresh.newAutoRefreshServer PGListener pgListener) let applicationContext :: ApplicationContext applicationContext = ApplicationContext :: ModelContext -> Key (Session IO ByteString ByteString) -> IORef AutoRefreshServer -> FrameworkConfig -> PGListener -> ApplicationContext ApplicationContext { ModelContext $sel:modelContext:ApplicationContext :: ModelContext modelContext :: ModelContext modelContext, Key (Session IO ByteString ByteString) $sel:session:ApplicationContext :: Key (Session IO ByteString ByteString) session :: Key (Session IO ByteString ByteString) session, IORef AutoRefreshServer $sel:autoRefreshServer:ApplicationContext :: IORef AutoRefreshServer autoRefreshServer :: IORef AutoRefreshServer autoRefreshServer, FrameworkConfig $sel:frameworkConfig:ApplicationContext :: FrameworkConfig frameworkConfig :: FrameworkConfig frameworkConfig, PGListener $sel:pgListener:ApplicationContext :: PGListener pgListener :: PGListener pgListener } let toolServerApplication :: ToolServerApplication toolServerApplication = ToolServerApplication :: Context -> ToolServerApplication ToolServerApplication { $sel:devServerContext:ToolServerApplication :: Context devServerContext = ?context::Context Context ?context } let Application application :: Wai.Application = \Request request Response -> IO ResponseReceived respond -> do let ?applicationContext = applicationContext RequestContext requestContext <- ApplicationContext -> Request -> (Response -> IO ResponseReceived) -> IO RequestContext ControllerSupport.createRequestContext ApplicationContext applicationContext Request request Response -> IO ResponseReceived respond let ?context = requestContext ToolServerApplication -> [Parser (IO ResponseReceived)] -> IO ResponseReceived -> IO ResponseReceived forall app. (?applicationContext::ApplicationContext, ?context::RequestContext, FrontController app) => app -> [Parser (IO ResponseReceived)] -> IO ResponseReceived -> IO ResponseReceived frontControllerToWAIApp ToolServerApplication toolServerApplication [] IO ResponseReceived (?context::RequestContext) => IO ResponseReceived ErrorController.handleNotFound String libDirectory <- Text -> String forall a b. ConvertibleStrings a b => a -> b cs (Text -> String) -> IO Text -> IO String forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> IO Text LibDir.findLibDirectory let Middleware staticMiddleware :: Wai.Middleware = Policy -> Middleware staticPolicy (String -> Policy addBase (String libDirectory String -> String -> String forall a. Semigroup a => a -> a -> a <> String "static/")) let openAppUrl :: IO () openAppUrl = Text -> IO () openUrl (Text "http://localhost:" Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Int -> Text forall a. Show a => a -> Text tshow Int port Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Text "/") let warpSettings :: Settings warpSettings = Settings Warp.defaultSettings Settings -> (Settings -> Settings) -> Settings forall t1 t2. t1 -> (t1 -> t2) -> t2 |> Int -> Settings -> Settings Warp.setPort Int port Settings -> (Settings -> Settings) -> Settings forall t1 t2. t1 -> (t1 -> t2) -> t2 |> IO () -> Settings -> Settings Warp.setBeforeMainLoop IO () openAppUrl let logMiddleware :: Middleware logMiddleware = if Bool isDebugMode then Proxy "requestLoggerMiddleware" -> FrameworkConfig -> Middleware forall model (name :: Symbol) value. (KnownSymbol name, HasField name model value) => Proxy name -> model -> value get IsLabel "requestLoggerMiddleware" (Proxy "requestLoggerMiddleware") Proxy "requestLoggerMiddleware" #requestLoggerMiddleware FrameworkConfig frameworkConfig else Middleware forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a IHP.Prelude.id LiveReloadNotificationServerState liveReloadNotificationServerState <- ?context::Context Context ?context Context -> (Context -> IORef AppState) -> IORef AppState forall t1 t2. t1 -> (t1 -> t2) -> t2 |> Proxy "appStateRef" -> Context -> IORef AppState forall model (name :: Symbol) value. (KnownSymbol name, HasField name model value) => Proxy name -> model -> value get IsLabel "appStateRef" (Proxy "appStateRef") Proxy "appStateRef" #appStateRef IORef AppState -> (IORef AppState -> IO AppState) -> IO AppState forall t1 t2. t1 -> (t1 -> t2) -> t2 |> IORef AppState -> IO AppState forall a. IORef a -> IO a readIORef IO AppState -> (AppState -> IO LiveReloadNotificationServerState) -> IO LiveReloadNotificationServerState forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= LiveReloadNotificationServerState -> IO LiveReloadNotificationServerState forall (f :: * -> *) a. Applicative f => a -> f a pure (LiveReloadNotificationServerState -> IO LiveReloadNotificationServerState) -> (AppState -> LiveReloadNotificationServerState) -> AppState -> IO LiveReloadNotificationServerState forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k). Category cat => cat b c -> cat a b -> cat a c . Proxy "liveReloadNotificationServerState" -> AppState -> LiveReloadNotificationServerState forall model (name :: Symbol) value. (KnownSymbol name, HasField name model value) => Proxy name -> model -> value get IsLabel "liveReloadNotificationServerState" (Proxy "liveReloadNotificationServerState") Proxy "liveReloadNotificationServerState" #liveReloadNotificationServerState Settings -> Application -> IO () Warp.runSettings Settings warpSettings (Application -> IO ()) -> Application -> IO () forall a b. (a -> b) -> a -> b $ Middleware staticMiddleware Middleware -> Middleware forall a b. (a -> b) -> a -> b $ Middleware logMiddleware Middleware -> Middleware forall a b. (a -> b) -> a -> b $ Middleware methodOverridePost Middleware -> Middleware forall a b. (a -> b) -> a -> b $ Middleware sessionMiddleware Middleware -> Middleware forall a b. (a -> b) -> a -> b $ ConnectionOptions -> ServerApp -> Middleware Websocket.websocketsOr ConnectionOptions Websocket.defaultConnectionOptions (LiveReloadNotificationServerState -> ServerApp LiveReloadNotificationServer.app LiveReloadNotificationServerState liveReloadNotificationServerState) Application application stopToolServer :: ToolServerState -> IO () stopToolServer ToolServerStarted { Async () thread :: Async () $sel:thread:ToolServerNotStarted :: ToolServerState -> Async () thread } = Async () -> IO () forall a. Async a -> IO () uninterruptibleCancel Async () thread stopToolServer ToolServerState ToolServerNotStarted = () -> IO () forall (f :: * -> *) a. Applicative f => a -> f a pure () openUrl :: Text -> IO () openUrl :: Text -> IO () openUrl Text url = do Maybe String selectedBrowser <- String -> IO (Maybe String) Env.lookupEnv String "IHP_BROWSER" let defaultOSBrowser :: String defaultOSBrowser = case String os of String "linux" -> String "xdg-open" String "darwin" -> String "open" let browser :: String browser = Maybe String selectedBrowser Maybe String -> (Maybe String -> String) -> String forall t1 t2. t1 -> (t1 -> t2) -> t2 |> String -> Maybe String -> String forall a. a -> Maybe a -> a fromMaybe String defaultOSBrowser IO () -> IO (Async ()) forall a. IO a -> IO (Async a) async (IO () -> IO (Async ())) -> IO () -> IO (Async ()) forall a b. (a -> b) -> a -> b $ String -> IO () Process.callCommand (String browser String -> String -> String forall a. Semigroup a => a -> a -> a <> String " " String -> String -> String forall a. Semigroup a => a -> a -> a <> Text -> String forall a b. ConvertibleStrings a b => a -> b cs Text url) () -> IO () forall (f :: * -> *) a. Applicative f => a -> f a pure () instance FrontController ToolServerApplication where controllers :: [Parser (IO ResponseReceived)] controllers = [ forall application. (?applicationContext::ApplicationContext, ?context::RequestContext, Controller SchemaController, CanRoute SchemaController, InitControllerContext application, ?application::application, Typeable application, Data SchemaController) => Parser (IO ResponseReceived) forall controller application. (?applicationContext::ApplicationContext, ?context::RequestContext, Controller controller, CanRoute controller, InitControllerContext application, ?application::application, Typeable application, Data controller) => Parser (IO ResponseReceived) parseRoute @SchemaController , forall application. (?applicationContext::ApplicationContext, ?context::RequestContext, Controller TablesController, CanRoute TablesController, InitControllerContext application, ?application::application, Typeable application, Data TablesController) => Parser (IO ResponseReceived) forall controller application. (?applicationContext::ApplicationContext, ?context::RequestContext, Controller controller, CanRoute controller, InitControllerContext application, ?application::application, Typeable application, Data controller) => Parser (IO ResponseReceived) parseRoute @TablesController , forall application. (?applicationContext::ApplicationContext, ?context::RequestContext, Controller ColumnsController, CanRoute ColumnsController, InitControllerContext application, ?application::application, Typeable application, Data ColumnsController) => Parser (IO ResponseReceived) forall controller application. (?applicationContext::ApplicationContext, ?context::RequestContext, Controller controller, CanRoute controller, InitControllerContext application, ?application::application, Typeable application, Data controller) => Parser (IO ResponseReceived) parseRoute @ColumnsController , forall application. (?applicationContext::ApplicationContext, ?context::RequestContext, Controller PoliciesController, CanRoute PoliciesController, InitControllerContext application, ?application::application, Typeable application, Data PoliciesController) => Parser (IO ResponseReceived) forall controller application. (?applicationContext::ApplicationContext, ?context::RequestContext, Controller controller, CanRoute controller, InitControllerContext application, ?application::application, Typeable application, Data controller) => Parser (IO ResponseReceived) parseRoute @PoliciesController , forall application. (?applicationContext::ApplicationContext, ?context::RequestContext, Controller EnumsController, CanRoute EnumsController, InitControllerContext application, ?application::application, Typeable application, Data EnumsController) => Parser (IO ResponseReceived) forall controller application. (?applicationContext::ApplicationContext, ?context::RequestContext, Controller controller, CanRoute controller, InitControllerContext application, ?application::application, Typeable application, Data controller) => Parser (IO ResponseReceived) parseRoute @EnumsController , forall application. (?applicationContext::ApplicationContext, ?context::RequestContext, Controller EnumValuesController, CanRoute EnumValuesController, InitControllerContext application, ?application::application, Typeable application, Data EnumValuesController) => Parser (IO ResponseReceived) forall controller application. (?applicationContext::ApplicationContext, ?context::RequestContext, Controller controller, CanRoute controller, InitControllerContext application, ?application::application, Typeable application, Data controller) => Parser (IO ResponseReceived) parseRoute @EnumValuesController , forall application. (?applicationContext::ApplicationContext, ?context::RequestContext, Controller LogsController, CanRoute LogsController, InitControllerContext application, ?application::application, Typeable application, Data LogsController) => Parser (IO ResponseReceived) forall controller application. (?applicationContext::ApplicationContext, ?context::RequestContext, Controller controller, CanRoute controller, InitControllerContext application, ?application::application, Typeable application, Data controller) => Parser (IO ResponseReceived) parseRoute @LogsController , forall application. (?applicationContext::ApplicationContext, ?context::RequestContext, Controller DataController, CanRoute DataController, InitControllerContext application, ?application::application, Typeable application, Data DataController) => Parser (IO ResponseReceived) forall controller application. (?applicationContext::ApplicationContext, ?context::RequestContext, Controller controller, CanRoute controller, InitControllerContext application, ?application::application, Typeable application, Data controller) => Parser (IO ResponseReceived) parseRoute @DataController , forall application. (?applicationContext::ApplicationContext, ?context::RequestContext, Controller CodeGenController, CanRoute CodeGenController, InitControllerContext application, ?application::application, Typeable application, Data CodeGenController) => Parser (IO ResponseReceived) forall controller application. (?applicationContext::ApplicationContext, ?context::RequestContext, Controller controller, CanRoute controller, InitControllerContext application, ?application::application, Typeable application, Data controller) => Parser (IO ResponseReceived) parseRoute @CodeGenController , forall application. (?applicationContext::ApplicationContext, ?context::RequestContext, Controller MigrationsController, CanRoute MigrationsController, InitControllerContext application, ?application::application, Typeable application, Data MigrationsController) => Parser (IO ResponseReceived) forall controller application. (?applicationContext::ApplicationContext, ?context::RequestContext, Controller controller, CanRoute controller, InitControllerContext application, ?application::application, Typeable application, Data controller) => Parser (IO ResponseReceived) parseRoute @MigrationsController , TablesController -> Parser (IO ResponseReceived) forall action application. (Controller action, InitControllerContext application, ?application::application, ?applicationContext::ApplicationContext, ?context::RequestContext, Typeable application, Typeable action) => action -> Parser (IO ResponseReceived) startPage TablesController TablesAction ] instance ControllerSupport.InitControllerContext ToolServerApplication where initContext :: IO () initContext = do AvailableApps availableApps <- [Text] -> AvailableApps AvailableApps ([Text] -> AvailableApps) -> IO [Text] -> IO AvailableApps forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> IO [Text] findApplications WebControllers webControllers <- [Text] -> WebControllers WebControllers ([Text] -> WebControllers) -> IO [Text] -> IO WebControllers forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> IO [Text] findWebControllers let defaultAppUrl :: Text defaultAppUrl = Text "http://localhost:" Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> PortNumber -> Text forall a. Show a => a -> Text tshow PortNumber (?context::ControllerContext) => PortNumber Helper.appPort Text appUrl :: Text <- Text -> Maybe Text -> Text forall a. a -> Maybe a -> a fromMaybe Text defaultAppUrl (Maybe Text -> Text) -> (Maybe String -> Maybe Text) -> Maybe String -> Text forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (String -> Text) -> Maybe String -> Maybe Text forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap String -> Text forall a b. ConvertibleStrings a b => a -> b cs (Maybe String -> Text) -> IO (Maybe String) -> IO Text forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> String -> IO (Maybe String) Env.lookupEnv String "IHP_BASEURL" AvailableApps -> IO () forall value. (?context::ControllerContext, Typeable value) => value -> IO () putContext AvailableApps availableApps WebControllers -> IO () forall value. (?context::ControllerContext, Typeable value) => value -> IO () putContext WebControllers webControllers AppUrl -> IO () forall value. (?context::ControllerContext, Typeable value) => value -> IO () putContext (Text -> AppUrl AppUrl Text appUrl) (?context::ControllerContext) => ((?context::ControllerContext) => Layout) -> IO () ((?context::ControllerContext) => Layout) -> IO () setLayout (?context::ControllerContext) => Layout Html -> Html Layout.toolServerLayout Bool databaseNeedsMigration <- IO Bool (?context::ControllerContext) => IO Bool readDatabaseNeedsMigration DatabaseNeedsMigration -> IO () forall value. (?context::ControllerContext, Typeable value) => value -> IO () putContext (Bool -> DatabaseNeedsMigration DatabaseNeedsMigration Bool databaseNeedsMigration) readDatabaseNeedsMigration :: (?context :: ControllerContext) => IO Bool readDatabaseNeedsMigration :: IO Bool readDatabaseNeedsMigration = do Context context <- IO Context (?context::ControllerContext) => IO Context theDevServerContext AppState state <- IORef AppState -> IO AppState forall a. IORef a -> IO a readIORef (Proxy "appStateRef" -> Context -> IORef AppState forall model (name :: Symbol) value. (KnownSymbol name, HasField name model value) => Proxy name -> model -> value get IsLabel "appStateRef" (Proxy "appStateRef") Proxy "appStateRef" #appStateRef Context context) IORef Bool -> IO Bool forall a. IORef a -> IO a readIORef (Proxy "databaseNeedsMigration" -> AppState -> IORef Bool forall model (name :: Symbol) value. (KnownSymbol name, HasField name model value) => Proxy name -> model -> value get IsLabel "databaseNeedsMigration" (Proxy "databaseNeedsMigration") Proxy "databaseNeedsMigration" #databaseNeedsMigration AppState state)