diff --git a/IHP/ErrorController.hs b/IHP/ErrorController.hs
index bdf9b5cce..eef3cb6cf 100644
--- a/IHP/ErrorController.hs
+++ b/IHP/ErrorController.hs
@@ -1,4 +1,14 @@
-module IHP.ErrorController (displayException, handleNoResponseReturned, handleNotFound) where
+{-|
+Module: IHP.ErrorController
+Description: Provides web-based error screens for runtime errors in IHP
+Copyright: (c) digitally induced GmbH, 2020
+-}
+module IHP.ErrorController
+( displayException
+, handleNoResponseReturned
+, handleNotFound
+, handleRouterException
+) where
import IHP.Prelude hiding (displayException)
import qualified Control.Exception as Exception
@@ -19,10 +29,8 @@ import qualified Database.PostgreSQL.Simple.FromField as PG
import qualified Data.ByteString.Char8 as ByteString
import IHP.HtmlSupport.QQ (hsx)
-
import Database.PostgreSQL.Simple.FromField (ResultError (..))
-
handleNoResponseReturned :: (Show controller, ?requestContext :: RequestContext) => controller -> IO ResponseReceived
handleNoResponseReturned controller = do
let codeSample :: Text = "render MyView { .. }"
@@ -45,6 +53,19 @@ handleNotFound = do
let (RequestContext _ respond _ _ _) = ?requestContext
respond $ responseBuilder status404 [(hContentType, "text/html")] (Blaze.renderHtmlBuilder (renderError title errorMessage))
+handleRouterException :: (?requestContext :: RequestContext) => SomeException -> IO ResponseReceived
+handleRouterException exception = do
+ let errorMessage = [hsx|
+ Routing failed with: {tshow exception}
+
+ Possible Solutions
+ Are you using AutoRoute but some of your fields are not UUID? In that case please see the documentation on Parameter Types
+ |]
+ let title = H.text "Routing failed"
+ let (RequestContext _ respond _ _ _) = ?requestContext
+ respond $ responseBuilder status500 [(hContentType, "text/html")] (Blaze.renderHtmlBuilder (renderError title errorMessage))
+
+
displayException :: (Show action, ?requestContext :: RequestContext) => SomeException -> action -> Text -> IO ResponseReceived
displayException exception action additionalInfo = do
let allHandlers = [ postgresHandler, patternMatchFailureHandler ]
@@ -139,6 +160,28 @@ renderError errorTitle view = H.docTypeHtml ! A.lang "en" $ [hsx|
margin: 0;
font-family: -apple-system, BlinkMacSystemFont, "Segoe UI", "Roboto", "Helvetica Neue", Arial, sans-serif;
}
+
+ body a {
+ color: hsla(196, 13%, 80%, 1);
+ }
+
+ .ihp-error-other-solutions {
+ margin-top: 2rem;
+ padding-top: 0.5rem;
+ font-size: 1rem;
+ color: hsla(196, 13%, 80%, 1);
+ border-top: 1px solid hsla(196, 13%, 60%, 0.4);
+ }
+
+ .ihp-error-other-solutions a {
+ color: hsla(196, 13%, 80%, 0.9);
+ text-decoration: none !important;
+ margin-right: 1rem;
+ font-size: 0.8rem;
+ }
+ .ihp-error-other-solutions a:hover {
+ color: hsla(196, 13%, 80%, 1);
+ }
@@ -148,6 +191,12 @@ renderError errorTitle view = H.docTypeHtml ! A.lang "en" $ [hsx|
{view}
+
+
diff --git a/IHP/HaskellSupport.hs b/IHP/HaskellSupport.hs
index 8ed2a3e52..0e9fba6e7 100644
--- a/IHP/HaskellSupport.hs
+++ b/IHP/HaskellSupport.hs
@@ -21,6 +21,7 @@ module IHP.HaskellSupport (
, isToday
, isToday'
, forEach
+, forEachWithIndex
, textToInt
, isWeekend
, todayIsWeekend
@@ -174,6 +175,13 @@ forEach :: (MonoFoldable mono, Applicative m) => mono -> (Element mono -> m ())
forEach elements function = forM_ elements function
{-# INLINE forEach #-}
+
+-- | Example:
+-- forEachWithIndex users \(index, user) -> putStrLn (tshow user)
+forEachWithIndex :: (Applicative m) => [a] -> ((Int, a) -> m ()) -> m ()
+forEachWithIndex elements function = forM_ (ClassyPrelude.zip [0..] elements) function
+{-# INLINE forEachWithIndex #-}
+
-- | Parses a text to an int. Returns @Nothing@ on failure.
--
-- __Example:__
diff --git a/IHP/IDE/Logs/Controller.hs b/IHP/IDE/Logs/Controller.hs
index ba28d63d9..0c921b073 100644
--- a/IHP/IDE/Logs/Controller.hs
+++ b/IHP/IDE/Logs/Controller.hs
@@ -1,6 +1,7 @@
module IHP.IDE.Logs.Controller where
import IHP.ControllerPrelude
+import IHP.IDE.ToolServer.Helper.Controller
import IHP.IDE.ToolServer.Types
import IHP.IDE.ToolServer.ViewContext
import IHP.IDE.Logs.View.Logs
@@ -37,6 +38,14 @@ instance Controller LogsController where
render LogsView { .. }
+ action OpenEditorAction = do
+ let path = param @Text "path"
+ let line = paramOrDefault @Int 0 "line"
+ let col = paramOrDefault @Int 0 "col"
+ openEditor path line col
+
+ renderPlain ""
+
readDevServerState :: (?controllerContext :: ControllerContext) => IO DevServer.AppState
readDevServerState = theDevServerContext
|> get #appStateRef
diff --git a/IHP/IDE/StatusServer.hs b/IHP/IDE/StatusServer.hs
index 39a2f4a62..581f5af7e 100644
--- a/IHP/IDE/StatusServer.hs
+++ b/IHP/IDE/StatusServer.hs
@@ -15,7 +15,10 @@ import qualified Network.HTTP.Types as HTTP
import qualified Data.ByteString.Char8 as ByteString
import IHP.IDE.Types
import IHP.IDE.PortConfig
+import IHP.IDE.ToolServer.Types
+import IHP.IDE.ToolServer.Routes
import ClassyPrelude (async, uninterruptibleCancel, catch, forever)
+import qualified Network.URI as URI
startStatusServer :: (?context :: Context) => IO ()
startStatusServer = do
@@ -47,15 +50,7 @@ continueStatusServer StatusServerPaused { .. } = do
where
statusServerApp :: (IORef ByteString, IORef ByteString) -> Wai.Application
statusServerApp (standardOutput, errorOutput) req respond = do
- devServerState <- ?context
- |> get #appStateRef
- |> readIORef
-
- let isCompiling = case (get #appGHCIState devServerState) of
- AppGHCILoading { } -> True
- _ -> False
-
-
+ isCompiling <- getCompilingStatus
currentStandardOutput <- readIORef standardOutput
currentErrorOutput <- readIORef errorOutput
let responseBody = Blaze.renderHtmlBuilder (renderErrorView currentStandardOutput currentErrorOutput isCompiling)
@@ -68,18 +63,18 @@ stopStatusServer StatusServerStarted { serverRef } = do
pure ()
stopStatusServer _ = putStrLn "StatusServer: Cannot stop as not running"
-clearStatusServer :: StatusServerState -> IO ()
+clearStatusServer :: (?context :: Context) => StatusServerState -> IO ()
clearStatusServer StatusServerStarted { .. } = do
writeIORef standardOutput ""
writeIORef errorOutput ""
- async (notifyOutput clients "clear")
+ async (notifyOutput (standardOutput, errorOutput) clients)
pure ()
clearStatusServer StatusServerPaused { .. } = do
writeIORef standardOutput ""
writeIORef errorOutput ""
clearStatusServer StatusServerNotStarted = pure ()
-notifyBrowserOnApplicationOutput :: StatusServerState -> OutputLine -> IO ()
+notifyBrowserOnApplicationOutput :: (?context :: Context) => StatusServerState -> OutputLine -> IO ()
notifyBrowserOnApplicationOutput StatusServerStarted { serverRef, clients, standardOutput, errorOutput } line = do
let shouldIgnoreLine = (line == ErrorOutput "Warning: -debug, -threaded and -ticky are ignored by GHCi")
unless shouldIgnoreLine do
@@ -89,7 +84,7 @@ notifyBrowserOnApplicationOutput StatusServerStarted { serverRef, clients, stand
let payload = case line of
StandardOutput line -> "stdout" <> line
ErrorOutput line -> "stderr" <> line
- async (notifyOutput clients payload)
+ async (notifyOutput (standardOutput, errorOutput) clients)
pure ()
notifyBrowserOnApplicationOutput StatusServerPaused { serverRef, clients, standardOutput, errorOutput } line = do
case line of
@@ -98,58 +93,172 @@ notifyBrowserOnApplicationOutput StatusServerPaused { serverRef, clients, standa
pure ()
notifyBrowserOnApplicationOutput _ _ = putStrLn "StatusServer: Cannot notify clients as not in running state"
-renderErrorView :: ByteString -> ByteString -> Bool -> Html5.Html
+
+data CompilerError = CompilerError { errorMessage :: [ByteString], isWarning :: Bool } deriving (Show)
+
+renderErrorView :: (?context :: Context) => ByteString -> ByteString -> Bool -> Html5.Html
renderErrorView standardOutput errorOutput isCompiling = [hsx|
{title}
-
+
-
- {inner}
-
-
{errorOutput}
-
{standardOutput}
-
+
{inner}
+
{forEach (parseErrorOutput errorOutput) renderError}
+
+
+
+
{standardOutput}
+
Is compiling
|]
- else [hsx|Error while compiling
|]
-
- websocketHandler = preEscapedToHtml [plain|
- var socket = new WebSocket("ws://localhost:" + window.location.port);
- socket.onclose = function () { setTimeout(() => window.location.reload(), 500); }
- socket.onmessage = function (event) {
- if (event.data === 'clear') {
- stdout.innerText = '';
- stderr.innerText = '';
- } else {
- var c = (event.data.substr(0, 6) === 'stdout' ? stdout : stderr);
- c.innerText = c.innerText + "\\n" + event.data.substr(6);
- }
- }
- |]
+ then [hsx|Is compiling|]
+ else [hsx|Problems found while compiling|]
- style = preEscapedToHtml [plain|
- body {
- font-size: 16px;
- font-family: -apple-system, Roboto, "Helvetica Neue", Arial, sans-serif;
- }
- |]
+ renderError CompilerError { errorMessage, isWarning } = [hsx|
+
+ {forEachWithIndex errorMessage renderLine}
+ {mconcat (renderTroubleshooting errorMessage)}
+
+ |]
+
+ renderLine (0, line) = [hsx|
+ {filePath}
+
+ |]
+ where
+ (filePath, rest) = ByteString.breakSubstring ": " line
+ openEditor = "http://localhost:" <> tshow toolServerPort <> (pathTo OpenEditorAction) <> "?path=" <> cs plainFilePath <> "&line=" <> cs fileLine <> "&col=" <> cs fileCol
+ (plainFilePath, fileLine, fileCol) = case ByteString.split ':' filePath of
+ [path, line, col] -> (path, line, col)
+ [path, line] -> (path, line, "0")
+ otherwise -> (filePath, "0", "0")
+ renderLine (i, line) = [hsx|{line}
|]
-notifyOutput :: IORef [Websocket.Connection] -> ByteString -> IO ()
-notifyOutput stateRef output = do
+ renderTroubleshooting :: [ByteString] -> [Html5.Html]
+ renderTroubleshooting lines = [ modelContextTroubleshooting ]
+ |> map (\f -> f lines)
+ |> catMaybes
+
+ toolServerPort = ?context
+ |> get #portConfig
+ |> get #toolServerPort
+
+notifyOutput :: (?context :: Context) => (IORef ByteString, IORef ByteString) -> IORef [Websocket.Connection] -> IO ()
+notifyOutput (standardOutputRef, errorOutputRef) stateRef = do
clients <- readIORef stateRef
- forM_ clients $ \connection -> ((Websocket.sendTextData connection output) `catch` (\(e :: SomeException) -> pure ()))
+ let ignoreException (e :: SomeException) = pure ()
+
+ isCompiling <- getCompilingStatus
+ standardOutput <- readIORef standardOutputRef
+ errorOutput <- readIORef errorOutputRef
+
+ forM_ clients $ \connection -> do
+ let errorContainer = renderErrorView standardOutput errorOutput isCompiling
+ let html = Blaze.renderHtml errorContainer
+ (Websocket.sendTextData connection html) `catch` ignoreException
app :: IORef [Websocket.Connection] -> Websocket.ServerApp
app stateRef pendingConnection = do
@@ -160,3 +269,29 @@ app stateRef pendingConnection = do
Websocket.sendTextData connection ("pong" :: Text)
Concurrent.threadDelay (1000000)
pure ()
+
+
+modelContextTroubleshooting :: [ByteString] -> Maybe Html5.Html
+modelContextTroubleshooting lines =
+ lines
+ |> map (\line -> "Unbound implicit parameter (?modelContext::" `ByteString.isInfixOf` line)
+ |> or
+ |> \case
+ True -> Just [hsx|
+
+ |]
+ False -> Nothing
+
+
+getCompilingStatus :: (?context :: Context) => IO Bool
+getCompilingStatus = do
+ devServerState <- ?context
+ |> get #appStateRef
+ |> readIORef
+
+ pure case (get #appGHCIState devServerState) of
+ AppGHCILoading { } -> True
+ _ -> False
diff --git a/IHP/IDE/ToolServer/Helper/Controller.hs b/IHP/IDE/ToolServer/Helper/Controller.hs
index 13dcc46cc..8de537d3a 100644
--- a/IHP/IDE/ToolServer/Helper/Controller.hs
+++ b/IHP/IDE/ToolServer/Helper/Controller.hs
@@ -3,7 +3,7 @@ Module: IHP.IDE.ToolServer.Helper.Controller
Description: Provides helpers for controllers of the ToolServer
Copyright: (c) digitally induced GmbH, 2020
-}
-module IHP.IDE.ToolServer.Helper.Controller (appPort) where
+module IHP.IDE.ToolServer.Helper.Controller (appPort, openEditor) where
import IHP.Prelude
import IHP.ControllerSupport
@@ -13,6 +13,9 @@ import IHP.IDE.ToolServer.Layout
import qualified IHP.IDE.PortConfig as PortConfig
import IHP.IDE.Types
import qualified Network.Socket as Socket
+import qualified System.Process as Process
+import System.Info (os)
+import qualified System.Environment as Env
-- | Returns the port used by the running app. Usually returns @8000@.
appPort :: (?controllerContext :: ControllerContext) => Socket.PortNumber
@@ -21,3 +24,28 @@ appPort = (fromControllerContext @ToolServerApplication)
|> get #portConfig
|> get #appPort
+openEditor :: Text -> Int -> Int -> IO ()
+openEditor path line col = do
+ (supportsLineAndCol, editor) <- findEditor
+ let command =
+ editor <> " " <> path <> if supportsLineAndCol then ":" <> tshow line <> ":" <> tshow col else ""
+ _ <- Process.system (cs command)
+ unless supportsLineAndCol (putStrLn "Pro Tip: Set the env var IHP_EDITOR to your favorite editor. Then all your files will be opened at the right line and column where the error is reported.")
+ pure ()
+
+-- | Returns the editor command for the user and also whether the command supports line and col notation
+--
+-- Line and col notation means that calling @editor myfile.hs:10:5@ works. Tools like @xdg-open@ or on macOS @open@
+-- don't support this notation and thus need to be called like @xdg-open myfile.hs@ instead of @xdg-open myfile.hs:10:5@
+--
+-- Looks for a the env vars IHP_EDITOR or EDITOR. As fallback it uses @open@ or @xdg-open@ (depends on OS).
+--
+findEditor :: IO (Bool, Text)
+findEditor = do
+ ihpEditorEnv <- Env.lookupEnv "IHP_EDITOR"
+ editorEnv <- Env.lookupEnv "EDITOR"
+ pure case catMaybes [ihpEditorEnv, editorEnv] of
+ (editor:_) -> (True, cs editor)
+ [] -> case os of
+ "linux" -> (False, "xdg-open")
+ "darwin" -> (False, "open")
\ No newline at end of file
diff --git a/IHP/IDE/ToolServer/Types.hs b/IHP/IDE/ToolServer/Types.hs
index 49abfbbb8..3dc3d00cd 100644
--- a/IHP/IDE/ToolServer/Types.hs
+++ b/IHP/IDE/ToolServer/Types.hs
@@ -87,6 +87,7 @@ data DataController
data LogsController
= AppLogsAction
| PostgresLogsAction
+ | OpenEditorAction
deriving (Eq, Show, Data)
data CodeGenController
diff --git a/IHP/RouterSupport.hs b/IHP/RouterSupport.hs
index aa4d48917..912fc77b8 100644
--- a/IHP/RouterSupport.hs
+++ b/IHP/RouterSupport.hs
@@ -58,6 +58,8 @@ import Control.Monad.Fail
import Data.String.Conversions (ConvertibleStrings (convertString), cs)
import qualified Text.Blaze.Html5 as Html5
import qualified IHP.FrameworkConfig as FrameworkConfig
+import qualified IHP.ErrorController as ErrorController
+import qualified Control.Exception as Exception
class FrontController application where
controllers :: (?applicationContext :: ApplicationContext, ?application :: application, ?requestContext :: RequestContext) => [Parser (IO ResponseReceived)]
@@ -410,14 +412,16 @@ withPrefix prefix routes = string prefix >> choice (map (\r -> r <* endOfInput)
{-# INLINE runApp #-}
runApp :: (?applicationContext :: ApplicationContext, ?requestContext :: RequestContext) => Parser (IO ResponseReceived) -> IO ResponseReceived -> IO ResponseReceived
-runApp routes notFoundAction =
- let
- path = ?requestContext
+runApp routes notFoundAction = do
+ let path = ?requestContext
|> getField @"request"
|> rawPathInfo
- in case parseOnly (routes <* endOfInput) path of
- Left message -> notFoundAction
- Right action -> action
+ handleException exception = pure $ Right (ErrorController.handleRouterException exception)
+
+ routedAction <- (evaluate $ parseOnly (routes <* endOfInput) path) `Exception.catch` handleException
+ case routedAction of
+ Left message -> notFoundAction
+ Right action -> action
{-# INLINE frontControllerToWAIApp #-}
frontControllerToWAIApp :: forall app parent config controllerContext. (Eq app, ?applicationContext :: ApplicationContext, ?requestContext :: RequestContext, FrontController app) => app -> IO ResponseReceived -> IO ResponseReceived
diff --git a/IHP/ViewSupport.hs b/IHP/ViewSupport.hs
index 2b7d2cb77..93d9e9fde 100644
--- a/IHP/ViewSupport.hs
+++ b/IHP/ViewSupport.hs
@@ -310,4 +310,4 @@ renderFlashMessages =
renderFlashMessage (Session.SuccessFlashMessage message) = [hsx|{message}
|]
renderFlashMessage (Session.ErrorFlashMessage message) = [hsx|{message}
|]
in
- forEach flashMessages renderFlashMessage
+ forEach flashMessages renderFlashMessage
\ No newline at end of file