Update IHP to current Version (#6148)

* Update IHP Version

* Update paramReader

frameworks/Haskell/ihp/src/Config/Config.hs

@@ -3,8 +3,12 @@ module Config where
 import IHP.Prelude
 import IHP.Environment
 import IHP.FrameworkConfig
+import IHP.Mail.Types
 
-instance FrameworkConfig where 
-    environment = Production
-    appHostname = "localhost"
-    requestLoggerMiddleware = \application -> application
+config :: ConfigBuilder
+config = do
+    option Production
+    option (AppHostname "localhost")
+    option (RequestLoggerMiddleware $ \application -> application)
+    option (DBPoolIdleTime 10)
+    option (DBPoolMaxConnections 512)

frameworks/Haskell/ihp/src/Config/nix/nixpkgs-config.nix

@@ -2,24 +2,28 @@
 
 let
   dontCheckPackages = [
-    "ghc-mod"
     "cabal-helper"
     "generic-lens"
     "filesystem-conduit"
     "tz"
     "typerep-map"
+    "trifecta"
+    "hackage-security"
   ];
 
   doJailbreakPackages = [
-    "ghc-mod"
     "filesystem-conduit"
     "http-media"
+    "aeson"
+    "wreq"
+    "ghcide"
+    "brittany"
   ];
 
   dontHaddockPackages = [];
 
-  nixPkgsRev = "da7ddd822e32aeebea00e97ab5aeca9758250a40";
-  nixPkgsSha256 = "0zbxbk4m72psbvd5p4qprcpiadndq1j2v517synijwp2vxc7cnv6";
+  nixPkgsRev = "c985bf793e6ab7d54a9182381b4b610fe0ae6936";
+  nixPkgsSha256 = "0zsj9imjbnhkb65r169xxqmjgqd5593insrvncvabg1iqdsrcxz1";
 
   compiler = "ghc883";
 
@@ -47,10 +51,17 @@ let
 
   composeExtensionsList = pkgs.lib.fold pkgs.lib.composeExtensions (_: _: {});
 
+
   # More exotic overrides go here
   manualOverrides = haskellPackagesNew: haskellPackagesOld: {
-    ihp = pkgs.haskell.lib.allowInconsistentDependencies haskellPackagesOld.ihp;
-    time_1_9_3 = pkgs.haskell.lib.dontCheck haskellPackagesOld.time_1_9_3;
+    haskell-language-server = haskellPackagesOld.haskell-language-server.overrideScope ( self: super: { aeson = pkgs.haskell.lib.dontCheck haskellPackagesNew.aeson_1_5_2_0; } );
+    hls-plugin-api = haskellPackagesOld.hls-plugin-api.overrideScope ( self: super: { aeson = pkgs.haskell.lib.dontCheck haskellPackagesNew.aeson_1_5_2_0; } );
+    yaml = haskellPackagesOld.yaml.overrideScope ( self: super: { aeson = pkgs.haskell.lib.dontCheck haskellPackagesNew.aeson_1_5_2_0; } );
+    lsp-test = haskellPackagesOld.lsp-test.overrideScope ( self: super: { aeson = pkgs.haskell.lib.dontCheck haskellPackagesNew.aeson_1_5_2_0; } );
+    haskell-lsp-types = haskellPackagesOld.haskell-lsp-types.overrideScope ( self: super: { aeson = pkgs.haskell.lib.dontCheck haskellPackagesNew.aeson_1_5_2_0; } );
+    haskell-lsp = haskellPackagesOld.haskell-lsp.overrideScope ( self: super: { aeson = pkgs.haskell.lib.dontCheck haskellPackagesNew.aeson_1_5_2_0; } );
+    aeson-pretty = haskellPackagesOld.aeson-pretty.overrideScope ( self: super: { aeson = pkgs.haskell.lib.dontCheck haskellPackagesNew.aeson_1_5_2_0; } );
+    aeson = pkgs.haskell.lib.dontCheck haskellPackagesOld.aeson_1_5_2_0;
   };
 
   #mkDerivation = args: super.mkDerivation (args // {

frameworks/Haskell/ihp/src/Main.hs

@@ -14,4 +14,4 @@ instance FrontController RootApplication where
         ]
 
 main :: IO ()
-main = IHP.Server.run
+main = IHP.Server.run config

frameworks/Haskell/ihp/src/Web/Controller/FrameworkBenchmarks.hs

@@ -21,13 +21,16 @@ instance Controller FrameworkBenchmarksController where
         renderJson (toJSON randomWorld)
 
     action QueryAction = do
-        let queries = paramOrDefault @Int 1 "queries" |> toBoundaries
+        let queries = defaultParam (paramOrError @Int "queries") |> toBoundaries
         let fetchRandomWorld i = do
                 randomWorldId :: Id World <- Id <$> randomRIO (1, 10000)
                 fetch randomWorldId
         [1..queries]
             |> Async.mapConcurrently fetchRandomWorld
             >>= renderJson
+        where
+            defaultParam (Right a) = a
+            defaultParam _ = 1
     
     action FortuneAction = do
         allFortunes :: [Fortune] <- query @Fortune |> fetch
@@ -37,7 +40,7 @@ instance Controller FrameworkBenchmarksController where
         renderHtml FortuneView { .. } >>= respondHtml
 
     action UpdatesAction = do
-        let queries = paramOrDefault @Int 1 "queries" |> toBoundaries
+        let queries :: Int = (defaultParam $ paramOrError @Int "queries" ) |> toBoundaries
         let updateRandomWorld i = do
                 randomWorldId :: Id World <- Id <$> randomRIO (1, 10000)
                 newRandom :: Int <- randomRIO (1, 10000)
@@ -48,6 +51,9 @@ instance Controller FrameworkBenchmarksController where
         [1..queries]
             |> Async.mapConcurrently updateRandomWorld
             >>= renderJson
+        where
+            defaultParam (Right a) = a
+            defaultParam _ = 1
     
     action PlaintextAction = do
         renderPlain "Hello, World!"

frameworks/Haskell/ihp/src/Web/FrontController.hs

@@ -1,8 +1,10 @@
 module Web.FrontController where
+import Web.View.Prelude
 import IHP.RouterPrelude
 import IHP.ControllerSupport
 import Generated.Types
 import Web.Types
+import Web.View.Layout (defaultLayout)
 
 -- Controller Imports
 import Web.Controller.FrameworkBenchmarks
@@ -14,4 +16,6 @@ instance FrontController WebApplication where
         -- Generator Marker
         ]
 
-instance InitControllerContext WebApplication
+instance InitControllerContext WebApplication where
+    initContext = do
+        setLayout defaultLayout

frameworks/Haskell/ihp/src/Web/Types.hs

@@ -9,13 +9,6 @@ import Generated.Types
 
 data WebApplication = WebApplication deriving (Eq, Show)
 
-data ViewContext = ViewContext
-    { requestContext :: ControllerSupport.RequestContext
-    , flashMessages :: [IHP.Controller.Session.FlashMessage]
-    , controllerContext :: ControllerSupport.ControllerContext
-    , layout :: Layout
-    }
-
 data FrameworkBenchmarksController
     = JsonAction
     | PlaintextAction

frameworks/Haskell/ihp/src/Web/View/Context.hs

@@ -1,25 +0,0 @@
-module Web.View.Context where
-
-import IHP.Prelude
-import qualified IHP.Controller.Session
-import IHP.ControllerSupport  (RequestContext (RequestContext))
-import qualified IHP.ControllerSupport
-import IHP.ModelSupport
-import Application.Helper.Controller
-import Generated.Types
-import qualified IHP.ViewSupport as ViewSupport
-import Web.View.Layout
-import Web.Types
-
-instance ViewSupport.CreateViewContext ViewContext where
-    type ViewApp ViewContext = WebApplication
-    createViewContext = do
-        flashMessages <- IHP.Controller.Session.getAndClearFlashMessages
-        let viewContext = ViewContext {
-                requestContext = ?requestContext,
-                -- user = currentUserOrNothing,
-                flashMessages,
-                controllerContext = ?controllerContext,
-                layout = let ?viewContext = viewContext in defaultLayout
-            }
-        pure viewContext

frameworks/Haskell/ihp/src/Web/View/FrameworkBenchmarks/Fortune.hs

@@ -3,8 +3,8 @@ import Web.View.Prelude
 
 data FortuneView = FortuneView { fortunes :: [Fortune] }
 
-instance View FortuneView ViewContext where
-    beforeRender (context, view) = (context { layout = \v -> v }, view)
+instance View FortuneView where
+    beforeRender _ = setLayout \v -> v
     html FortuneView { .. } = preEscapedToHtml ("<!DOCTYPE html>" :: Text) <> [hsx|
         <html>
             <head><title>Fortunes</title></head>

frameworks/Haskell/ihp/src/Web/View/FrameworkBenchmarks/Index.hs

@@ -3,7 +3,7 @@ import Web.View.Prelude
 
 data FortuneView = FortuneView { fortunes :: [Fortune] }
 
-instance View FortuneView ViewContext where
+instance View FortuneView where
     html FortuneView { .. } = [hsx|
         <nav>
             <ol class="breadcrumb">

frameworks/Haskell/ihp/src/Web/View/Layout.hs

@@ -9,8 +9,6 @@ import Web.Routes
 import qualified IHP.FrameworkConfig as FrameworkConfig
 import Config ()
 
-type Html = HtmlWithContext ViewContext
-
 defaultLayout :: Html -> Html
 defaultLayout inner = H.docTypeHtml ! A.lang "en" $ [hsx|
 <head>
@@ -29,18 +27,20 @@ defaultLayout inner = H.docTypeHtml ! A.lang "en" $ [hsx|
 </body>
 |]
 
+stylesheets :: Html
 stylesheets = do
-    when (isDevelopment FrameworkConfig.environment) [hsx|
+    when isDevelopment [hsx|
         <link rel="stylesheet" href="/vendor/bootstrap.min.css"/>
         <link rel="stylesheet" href="/vendor/flatpickr.min.css"/>
         <link rel="stylesheet" href="/app.css"/>
     |]
-    when (isProduction FrameworkConfig.environment) [hsx|
+    when isProduction [hsx|
         <link rel="stylesheet" href="/prod.css"/>
     |]
 
+scripts :: Html
 scripts = do
-    when (isDevelopment FrameworkConfig.environment) [hsx|
+    when isDevelopment [hsx|
         <script id="livereload-script" src="/livereload.js"></script>
         <script src="/vendor/jquery-3.2.1.slim.min.js"></script>
         <script src="/vendor/timeago.js"></script>
@@ -50,11 +50,11 @@ scripts = do
         <script src="/helpers.js"></script>
         <script src="/vendor/morphdom-umd.min.js"></script>
     |]
-    when (isProduction FrameworkConfig.environment) [hsx|
+    when isProduction [hsx|
         <script src="/prod.js"></script>
     |]
 
-
+metaTags :: Html
 metaTags = [hsx|
     <meta charset="utf-8"/>
     <meta name="viewport" content="width=device-width, initial-scale=1, shrink-to-fit=no"/>

frameworks/Haskell/ihp/src/Web/View/Prelude.hs

@@ -3,7 +3,6 @@ module Web.View.Prelude
 , module Web.View.Layout
 , module Generated.Types
 , module Web.Types
-, module Web.View.Context
 , module Application.Helper.View
 ) where
 
@@ -12,5 +11,4 @@ import Web.View.Layout
 import Generated.Types
 import Web.Types
 import Web.Routes ()
-import Web.View.Context
 import Application.Helper.View

frameworks/Haskell/ihp/src/default.nix

@@ -1,7 +1,7 @@
 let
     ihp = builtins.fetchGit {
         url = "https://github.com/digitallyinduced/ihp.git";
-        rev = "a12a1ce8f16814b802aae39eb26a9d3247192c12";
+        rev = "d02a0699220a87d32889ff2a7b87ad81f8bc8195";
     };
     haskellEnv = import "${ihp}/NixSupport/default.nix" {
         ihp = ihp;