Merge pull request #2218 from digitallyinduced/add-request-implicit-parameter

Add (?request :: Request) implicit parameter alongside ?context

Author: mpscholten

ihp-ide/IHP/IDE/Prelude.hs

@@ -31,10 +31,11 @@ import qualified IHP.Modal.ControllerFunctions as Modal
 import IHP.ViewSupport (View)
 import qualified IHP.ViewSupport as ViewSupport
 import IHP.ValidationSupport
+import qualified Network.Wai
 
 -- | Renders a view and stores it as modal HTML in the context for later rendering.
 --
 -- > setModal MyModalView { .. }
 --
-setModal :: (?context :: ControllerContext, View view) => view -> IO ()
-setModal view = Modal.setModal (let ?view = view in ViewSupport.html view)
+setModal :: (?context :: ControllerContext, ?request :: Network.Wai.Request, View view) => view -> IO ()
+setModal view = let ?view = view in Modal.setModal (ViewSupport.html view)

ihp-ide/IHP/IDE/SchemaDesigner/Controller/Helper.hs

@@ -8,6 +8,7 @@ import qualified IHP.IDE.SchemaDesigner.Compiler as SchemaCompiler
 import IHP.IDE.SchemaDesigner.View.Schema.Error
 import IHP.IDE.ToolServer.Helper.Controller
 import IHP.RequestBodyMiddleware (Respond)
+import qualified Network.Wai
 
 instance ParamReader PostgresType where
     readParameter byteString = case Megaparsec.runParser Parser.sqlType "" (cs byteString) of
@@ -29,6 +30,7 @@ readSchema ::
     , ?modelContext::ModelContext
     , ?theAction::controller
     , ?respond::Respond
+    , ?request :: Network.Wai.Request
     ) => IO [Statement]
 readSchema = Parser.parseSchemaSql >>= \case
         Left error -> do render ErrorView { error }; pure []
@@ -44,6 +46,7 @@ updateSchema ::
     , ?modelContext::ModelContext
     , ?theAction::controller
     , ?respond::Respond
+    , ?request :: Network.Wai.Request
     ) => ([Statement] -> [Statement]) -> IO ()
 updateSchema updateFn = do
     statements <- readSchema

ihp-job-dashboard/IHP/Job/Dashboard.hs

@@ -41,6 +41,7 @@ import IHP.Pagination.Types
 import qualified Database.PostgreSQL.Simple.Types as PG
 import qualified Database.PostgreSQL.Simple.FromField as PG
 import qualified Database.PostgreSQL.Simple.ToField as PG
+import qualified Network.Wai as Wai
 import Network.Wai (requestMethod)
 import Network.HTTP.Types.Method (methodPost)
 
@@ -112,32 +113,32 @@ class ( job ~ GetModelByTableName (GetTableName job)
 -- so you'll get a compile error if you try and include a type that is not a job.
 class JobsDashboard (jobs :: [Type]) where
     -- | Creates the entire dashboard by recursing on the type list and calling 'makeDashboardSection' on each type.
-    makeDashboard :: (?context :: ControllerContext, ?modelContext :: ModelContext) => IO SomeView
+    makeDashboard :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?request :: Wai.Request) => IO SomeView
 
     includedJobTables :: [Text]
 
     -- | Renders the index page, which is the view returned from 'makeDashboard'.
-    indexPage :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond) => IO ()
+    indexPage :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Wai.Request) => IO ()
 
-    listJob :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond) => Text -> IO ()
-    listJob' :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond) => Bool -> IO ()
+    listJob :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Wai.Request) => Text -> IO ()
+    listJob' :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Wai.Request) => Bool -> IO ()
 
     -- | Renders the detail view page. Rescurses on the type list to find a type with the
     -- same table name as the "tableName" query parameter.
-    viewJob :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond) => Text -> UUID -> IO ()
-    viewJob' :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond) => Bool -> IO ()
+    viewJob :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Wai.Request) => Text -> UUID -> IO ()
+    viewJob' :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Wai.Request) => Bool -> IO ()
 
     -- | If performed in a POST request, creates a new job depending on the "tableName" query parameter.
     -- If performed in a GET request, renders the new job from depending on said parameter.
-    newJob :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond) => Text -> IO ()
-    newJob' :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond) => Bool -> IO ()
+    newJob :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Wai.Request) => Text -> IO ()
+    newJob' :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Wai.Request) => Bool -> IO ()
 
     -- | Deletes a job from the database.
-    deleteJob :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond) => Text -> UUID -> IO ()
-    deleteJob' :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond) => Bool -> IO ()
+    deleteJob :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Wai.Request) => Text -> UUID -> IO ()
+    deleteJob' :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Wai.Request) => Bool -> IO ()
 
-    retryJob :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond) => Text -> UUID -> IO ()
-    retryJob' :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond) => IO ()
+    retryJob :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Wai.Request) => Text -> UUID -> IO ()
+    retryJob' :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Wai.Request) => IO ()
 
 -- If no types are passed, try to get all tables dynamically and render them as BaseJobs
 instance JobsDashboard '[] where
@@ -347,7 +348,7 @@ extractText = \(Only t) -> t
 getNotIncludedTableNames includedNames = map extractText <$> sqlQuery
     "SELECT table_name FROM information_schema.tables WHERE table_name LIKE '%_jobs' AND table_name NOT IN ?"
     (Only $ In $ includedNames)
-buildBaseJobTable :: (?modelContext :: ModelContext, ?context :: ControllerContext) => Text -> IO SomeView
+buildBaseJobTable :: (?modelContext :: ModelContext, ?context :: ControllerContext, ?request :: Wai.Request) => Text -> IO SomeView
 buildBaseJobTable tableName = do
     baseJobs <- sqlQuery (PG.Query $ cs $ queryString) (Only tableName)
     baseJobs

ihp-job-dashboard/IHP/Job/Dashboard/Auth.hs

@@ -14,6 +14,7 @@ module IHP.Job.Dashboard.Auth (
 import IHP.Prelude
 import IHP.ControllerPrelude
 import qualified IHP.EnvVar as EnvVar
+import qualified Network.Wai as Wai
 
 -- | Defines one method, 'authenticate', called before every action. Use to authenticate user.
 --
@@ -24,7 +25,7 @@ import qualified IHP.EnvVar as EnvVar
 --
 -- Define your own implementation to use custom authentication for production.
 class AuthenticationMethod a where
-    authenticate :: (?context :: ControllerContext, ?modelContext :: ModelContext) => IO ()
+    authenticate :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?request :: Wai.Request) => IO ()
 
 -- | Don't use any authentication for jobs.
 data NoAuth

ihp-ssc/IHP/ServerSideComponent/ControllerFunctions.hs

@@ -10,6 +10,7 @@ import IHP.ControllerPrelude
 import IHP.ServerSideComponent.Types as SSC
 
 import qualified Network.WebSockets as WebSocket
+import qualified Network.Wai as Wai
 import qualified Text.Blaze.Html.Renderer.Text as Blaze
 
 import qualified Data.Aeson as Aeson
@@ -23,7 +24,7 @@ $(Aeson.deriveJSON Aeson.defaultOptions { sumEncoding = defaultTaggedObject { ta
 $(Aeson.deriveJSON Aeson.defaultOptions { sumEncoding = defaultTaggedObject { tagFieldName = "type" }} ''Node)
 $(Aeson.deriveJSON Aeson.defaultOptions { sumEncoding = defaultTaggedObject { tagFieldName = "type" }} ''NodeOperation)
 
-setState :: (?instanceRef :: IORef (ComponentInstance state), ?connection :: WebSocket.Connection, Component state action, ?context :: ControllerContext) => state -> IO ()
+setState :: (?instanceRef :: IORef (ComponentInstance state), ?connection :: WebSocket.Connection, Component state action, ?context :: ControllerContext, ?request :: Wai.Request) => state -> IO ()
 setState state = do
     oldState <- (.state) <$> readIORef ?instanceRef
     let oldHtml = oldState

ihp/IHP/AuthSupport/Controller/Sessions.hs

@@ -20,13 +20,15 @@ import Data.Data
 import qualified IHP.AuthSupport.Lockable as Lockable
 import System.IO.Unsafe (unsafePerformIO)
 import IHP.RequestBodyMiddleware (Respond)
+import qualified Network.Wai
 
 -- | Displays the login form.
 --
 -- In case the user is already logged in, redirects to the home page ('afterLoginRedirectPath').
 newSessionAction :: forall record action.
     ( ?theAction :: action
     , ?context :: ControllerContext
+    , ?request :: Network.Wai.Request
     , ?respond :: Respond
     , HasNewSessionUrl record
     , ?modelContext :: ModelContext
@@ -53,6 +55,7 @@ newSessionAction = do
 createSessionAction :: forall record action.
     (?theAction :: action
     , ?context :: ControllerContext
+    , ?request :: Network.Wai.Request
     , ?respond :: Respond
     , ?modelContext :: ModelContext
     , Data action
@@ -107,6 +110,7 @@ createSessionAction = do
 deleteSessionAction :: forall record action id.
     ( ?theAction :: action
     , ?context :: ControllerContext
+    , ?request :: Network.Wai.Request
     , ?respond :: Respond
     , ?modelContext :: ModelContext
     , Data action

ihp/IHP/AutoRefresh.hs

@@ -39,6 +39,7 @@ autoRefresh :: (
     , Controller action
     , ?modelContext :: ModelContext
     , ?context :: ControllerContext
+    , ?request :: Request
     ) => ((?modelContext :: ModelContext) => IO ()) -> IO ()
 autoRefresh runAction = do
     autoRefreshState <- fromContext @AutoRefreshState
@@ -135,7 +136,7 @@ instance WSApp AutoRefreshWSApp where
 
             async $ forever do
                 MVar.takeMVar event
-                let currentRequest = ?context.request
+                let currentRequest = ?request
                 -- Create a dummy respond function that does nothing, since actual response
                 -- is handled by the handleResponseException handler
                 let dummyRespond _ = error "AutoRefresh: respond should not be called directly"
@@ -188,7 +189,7 @@ registerNotificationTrigger touchedTablesVar autoRefreshServer = do
     pure ()
 
 -- | Returns the ids of all sessions available to the client based on what sessions are found in the session cookie
-getAvailableSessions :: (?context :: ControllerContext) => IORef AutoRefreshServer -> IO [UUID]
+getAvailableSessions :: (?request :: Request) => IORef AutoRefreshServer -> IO [UUID]
 getAvailableSessions autoRefreshServer = do
     allSessions <- (.sessions) <$> readIORef autoRefreshServer
     text <- fromMaybe "" <$> getSession "autoRefreshSessions"

ihp/IHP/Controller/AccessDenied.hs

@@ -16,7 +16,6 @@ import qualified Text.Blaze.Html.Renderer.Utf8 as Blaze
 import qualified Data.ByteString.Lazy as LBS
 import IHP.HSX.QQ (hsx)
 import qualified System.Directory as Directory
-import IHP.Controller.Context
 import IHP.Controller.Response (respondAndExit)
 
 
@@ -31,7 +30,7 @@ import IHP.Controller.Response (respondAndExit)
 -- >     renderHtml EditView { .. }
 --
 -- This will throw an error and prevent the view from being rendered when the current user is not the author of the post.
-accessDeniedWhen :: (?context :: ControllerContext) => Bool -> IO ()
+accessDeniedWhen :: Bool -> IO ()
 accessDeniedWhen condition = when condition renderAccessDenied
 
 -- | Stops the action execution with an access denied message (403) when the access condition is False.
@@ -45,7 +44,7 @@ accessDeniedWhen condition = when condition renderAccessDenied
 -- >     renderHtml EditView { .. }
 --
 -- This will throw an error and prevent the view from being rendered when the current user is not the author of the post.
-accessDeniedUnless :: (?context :: ControllerContext) => Bool -> IO ()
+accessDeniedUnless :: Bool -> IO ()
 accessDeniedUnless condition = unless condition renderAccessDenied
 
 -- | Renders a 403 access denied response. If a static/403.html exists, that is rendered instead of the IHP access denied page.
@@ -153,7 +152,7 @@ customAccessDeniedResponse = do
 --
 -- You can override the default access denied page by creating a new file at @static/403.html@. Then IHP will render that HTML file instead of displaying the default IHP access denied page.
 --
-renderAccessDenied :: (?context :: ControllerContext) => IO ()
+renderAccessDenied :: IO ()
 renderAccessDenied = do
     response <- buildAccessDeniedResponse
     respondAndExit response

ihp/IHP/Controller/BasicAuth.hs

@@ -8,7 +8,7 @@ module IHP.Controller.BasicAuth (basicAuth) where
 import IHP.Prelude
 import IHP.ControllerSupport
 import Network.HTTP.Types (status401)
-import Network.Wai (responseLBS)
+import Network.Wai (responseLBS, Request)
 import Network.Wai.Middleware.HttpAuth (extractBasicAuth)
 import Network.HTTP.Types.Header (hWWWAuthenticate)
 
@@ -19,7 +19,7 @@ import Network.HTTP.Types.Header (hWWWAuthenticate)
 -- 
 -- > beforeAction = basicAuth ... 
 -- 
-basicAuth :: (?context :: ControllerContext) => Text -> Text -> Text -> IO ()
+basicAuth :: (?request :: Request) => Text -> Text -> Text -> IO ()
 basicAuth uid pw realm = do
     let mein = Just (cs uid, cs pw)
     let cred = join $ fmap extractBasicAuth (getHeader "Authorization")

ihp/IHP/Controller/Cookie.hs

@@ -10,6 +10,7 @@ import IHP.ControllerSupport
 import Web.Cookie
 import qualified Data.Binary.Builder as Binary
 import qualified Data.ByteString.Lazy as LBS
+import qualified Network.Wai
 
 -- | Sets a @Set-Cookie@ header
 --
@@ -34,11 +35,11 @@ setCookie cookie = setHeader ("Set-Cookie", cookieString)
 -- > getCookie "fbc"
 -- Just "1234"
 --
-getCookie :: (?context :: ControllerContext) => Text -> Maybe Text
+getCookie :: (?request :: Network.Wai.Request) => Text -> Maybe Text
 getCookie name =
     lookup name allCookies
 
 -- | Returns all cookies sent with the current request
-allCookies :: (?context :: ControllerContext) => [(Text, Text)]
+allCookies :: (?request :: Network.Wai.Request) => [(Text, Text)]
 allCookies =
     maybe [] parseCookiesText $ lookup "Cookie" request.requestHeaders