Improve Fortunes bench performance for Servant (#4553)

* Switch to `type-of-html` for better performance.

* Backport `b74090b` to hasql bench.

* Replace redundant alias with unqualified import.

https://github.com/TechEmpower/FrameworkBenchmarks/pull/4553#discussion_r266223443

* Move around files to re-use stack and dockerfile.

* Re-use docker image+layers to speed up builds.

- follow up to previous commit; actually update all refs to make them build.
- added little debug statement to manually test that the right executable is launched matching test name.

frameworks/Haskell/servant/benchmark_config.json

@@ -14,14 +14,15 @@
       "database": "Postgres",
       "framework": "Servant",
       "language": "Haskell",
-      "flavor": "GHC710",
+      "flavor": "GHC863",
       "orm": "Raw",
       "platform": "Wai",
       "webserver": "Warp",
       "os": "Linux",
       "database_os": "Linux",
       "display_name": "servant+hasql",
-      "notes": "Uses libpq system dependency."
+      "notes": "Uses libpq system dependency.",
+      "dockerfile": "servant.dockerfile"
     },
     "mysql-haskell": {
       "json_url": "/json",
@@ -43,7 +44,8 @@
       "os": "Linux",
       "database_os": "Linux",
       "display_name": "servant+mysql-haskell",
-      "notes": "Pure Haskell."
+      "notes": "Pure Haskell.",
+      "dockerfile": "servant.dockerfile"
     }
   }]
 }

frameworks/Haskell/servant/hasql/servant-bench.cabal → frameworks/Haskell/servant/hasql/servant-hasql.cabal

@@ -1,7 +1,7 @@
--- Initial servant-bench.cabal generated by cabal init.  For further
+-- Initial servant-hasql.cabal generated by cabal init.  For further
 -- documentation, see http://haskell.org/cabal/users-guide/
 
-name:                servant-bench
+name:                servant-hasql
 version:             0.1.0.0
 -- synopsis:
 -- description:
@@ -22,8 +22,7 @@ library
   build-depends:       base >=4.8
                      , servant >= 0.7
                      , servant-server >= 0.7
-                     , servant-lucid >= 0.7
-                     , lucid
+                     , type-of-html
                      , aeson >= 0.11
                      , hasql >= 0.19
                      , hasql-pool >= 0.4
@@ -37,11 +36,11 @@ library
   hs-source-dirs:      src
   default-language:    Haskell2010
 
-executable servant-exe
+executable servant-hasql
   main-is:             Main.hs
   ghc-options:         -Wall -threaded -rtsopts -O2
   build-depends:       base
-                     , servant-bench
+                     , servant-hasql
                      , bytestring
                      , hasql
   hs-source-dirs:      driver

frameworks/Haskell/servant/hasql/src/ServantBench.hs

@@ -4,6 +4,9 @@
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE TemplateHaskell       #-}
 {-# LANGUAGE TypeOperators         #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE UndecidableInstances  #-}
+
 module ServantBench (run) where
 
 import           Control.Exception          (bracket)
@@ -11,7 +14,7 @@ import           Control.Monad              (replicateM)
 import           Control.Monad.IO.Class     (liftIO)
 import           Data.Aeson                 hiding (json)
 import qualified Data.ByteString            as BS
-import           Data.ByteString.Lazy
+import           Data.ByteString.Lazy       (ByteString)
 import qualified Data.ByteString.Lazy.Char8 as LBSC
 import           Data.Functor.Contravariant (contramap)
 import           Data.Either                (fromRight, partitionEithers)
@@ -20,6 +23,7 @@ import           Data.List                  (sortOn)
 import           Data.Maybe                 (maybe)
 import           Data.Monoid                ((<>))
 import qualified Data.Text                  as Text
+import           Data.Text                  (Text)
 import           GHC.Exts                   (IsList (fromList))
 import           GHC.Generics               (Generic)
 import qualified Hasql.Decoders             as HasqlDec
@@ -27,19 +31,20 @@ import qualified Hasql.Encoders             as HasqlEnc
 import           Hasql.Pool                 (Pool, acquire, release, use)
 import qualified Hasql.Statement            as HasqlStatement
 import           Hasql.Session              (statement)
-import           Lucid
+import qualified Html
+import           Html ((#), type (#), type (>))
 import qualified Network.Wai.Handler.Warp   as Warp
-import           Network.HTTP.Media         ((//))
+import           Network.HTTP.Media         ((//), (/:))
 import           Servant
-import           Servant.HTML.Lucid         (HTML)
 import           System.Random.MWC          (GenIO, createSystemRandom,
                                              uniformR)
+import qualified Data.List.NonEmpty as NE
 
 type API =
        "json" :> Get '[JSON] Value
   :<|> "db" :> Get '[JSON] World
   :<|> "queries" :> QueryParam "queries" QueryId :> Get '[JSON] [World]
-  :<|> "fortune" :> Get '[HTML] (Html ())
+  :<|> "fortune" :> Get '[HTML] FortunesHtml
   :<|> "updates" :> QueryParam "queries" QueryId :> Get '[JSON] [World]
   :<|> "plaintext" :> Get '[Plain] ByteString
 
@@ -57,6 +62,7 @@ server pool gen =
 
 run :: Warp.Port -> BS.ByteString -> IO ()
 run port dbSettings = do
+  putStrLn "Launching servant hasql"
   gen <- createSystemRandom
   bracket (acquire settings) release $ \pool ->
     Warp.run port $ serve api $ server pool gen
@@ -99,6 +105,17 @@ instance Accept Plain where contentType _ = "text" // "plain"
 instance MimeRender Plain ByteString where
   mimeRender _ = id
   {-# INLINE mimeRender #-}
+  
+-- * HTML
+-- TODO: package the following block of code into a library akin to 'servant-lucid'
+
+data HTML
+instance Accept HTML where
+    contentTypes _ =
+      "text" // "html" /: ("charset", "utf-8") NE.:|
+      ["text" // "html"]
+instance Html.Document a => MimeRender HTML a where
+    mimeRender _ = Html.renderByteString
 
 ------------------------------------------------------------------------------
 
@@ -148,6 +165,30 @@ multipleDb pool gen mQueryId = do
 
 -- * Test 4: Fortunes
 
+type FortunesHtml
+  = (('Html.DOCTYPE Html.> ())
+  # ('Html.Html
+    > (('Html.Head > ('Html.Title > Html.Raw Text))
+      # ('Html.Body
+        > ('Html.Table
+          > (
+              ('Html.Tr
+              > ( ('Html.Th > Html.Raw Text)
+                # ('Html.Th > Html.Raw Text)
+                )
+              )
+            # ['Html.Tr
+              > ( ('Html.Td > Int)
+                # ('Html.Td > Text)
+                )
+              ]
+            )
+          )
+        )
+      )
+    )
+  )
+
 selectFortunes :: HasqlStatement.Statement () [Fortune]
 selectFortunes = HasqlStatement.Statement q encoder decoder True
   where
@@ -157,23 +198,25 @@ selectFortunes = HasqlStatement.Statement q encoder decoder True
    decoder = HasqlDec.rowList $ Fortune <$> intValDec <*> HasqlDec.column HasqlDec.text
 {-# INLINE selectFortunes #-}
 
-fortunes :: Pool -> Handler (Html ())
+fortunes :: Pool -> Handler FortunesHtml
 fortunes pool = do
   r <- liftIO $ use pool (statement () selectFortunes)
   case r of
     Left e -> throwError err500 { errBody = LBSC.pack . show $ e }
     Right fs -> return $ do
       let new = Fortune 0 "Additional fortune added at request time."
-      doctypehtml_ $ do
-        head_ $ title_ "Fortunes"
-        body_ $ do
-          table_ $ do
-            tr_ $ do
-              th_ "id"
-              th_ "message"
-            mapM_ (\f -> tr_ $ do
-              td_ (toHtml . show $ fId f)
-              td_ (toHtml $ fMessage f)) (sortOn fMessage (new : fs))
+      let header = Html.tr_ $ Html.th_ (Html.Raw "id") # Html.th_ (Html.Raw "message")
+      let mkRow f = Html.tr_ $ Html.td_ (fromIntegral $ fId f) # Html.td_ (fMessage f)
+      let rows = fmap mkRow $ sortOn fMessage (new : fs)
+      Html.doctype_ #
+        Html.html_ (
+          Html.head_ (
+            Html.title_ (Html.Raw "Fortunes")
+          ) #
+          Html.body_ ( Html.table_ $
+            header # rows
+          )
+        )
 {-# INLINE fortunes #-}
 
 

frameworks/Haskell/servant/hasql/stack.yaml

@@ -1,7 +0,0 @@
-resolver: lts-13.10
-packages:
-- '.'
-
-# the following flags are meant for use with ../servant-mysql-haskell.dockerfile
-compiler: ghc-8.6.3 # this MUST match the resolver's GHC; minor hack to ensure GHC isn't downloaded into sandbox.
-allow-different-user: true # carryover from hasql sibling test dir

frameworks/Haskell/servant/mysql-haskell/servant-mysql-haskell.cabal

@@ -21,8 +21,7 @@ executable servant-mysql-haskell
       base >= 4.7 && < 5
     , servant >= 0.7
     , servant-server >= 0.7
-    , servant-lucid >= 0.7
-    , lucid
+    , type-of-html
     , aeson >= 0.11
     , resource-pool
     , mysql-haskell

frameworks/Haskell/servant/mysql-haskell/src/Main.hs

@@ -4,6 +4,8 @@
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE TemplateHaskell       #-}
 {-# LANGUAGE TypeOperators         #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE UndecidableInstances  #-}
 
 module Main (main) where
 
@@ -25,21 +27,22 @@ import           GHC.Generics               (Generic)
 import qualified Data.Pool                  as Pool
 import qualified Database.MySQL.Base        as MySQL
 import qualified System.IO.Streams          as Streams
-import qualified Lucid
+import qualified Html
+import           Html ((#), type (#), type (>))
 import qualified Network.Wai.Handler.Warp   as Warp
-import           Network.HTTP.Media         ((//))
+import           Network.HTTP.Media         ((//), (/:))
 import           Servant
-import           Servant.HTML.Lucid         (HTML)
 import           System.Random.MWC          (GenIO, createSystemRandom,
                                              uniformR)
 import qualified GHC.Conc
 import           System.Environment (getArgs)
+import qualified Data.List.NonEmpty as NE
 
 type API =
        "json" :> Get '[JSON] Aeson.Value
   :<|> "db" :> Get '[JSON] World
   :<|> "queries" :> QueryParam "queries" Count :> Get '[JSON] [World]
-  :<|> "fortune" :> Get '[HTML] (Lucid.Html ())
+  :<|> "fortune" :> Get '[HTML] FortunesHtml
   :<|> "updates" :> QueryParam "queries" Count :> Get '[JSON] [World]
   :<|> "plaintext" :> Get '[Plain] LBS.ByteString
 
@@ -57,6 +60,7 @@ server pool gen =
 
 run :: Warp.Port -> MySQL.ConnectInfo -> IO ()
 run port dbSettings = do
+  putStrLn "Launching servant mysql-hasql"
   gen <- createSystemRandom
   numCaps <- GHC.Conc.getNumCapabilities
   let mkPool = Pool.createPool (MySQL.connect dbSettings) MySQL.close numCaps 10 512
@@ -130,6 +134,17 @@ instance Accept Plain where contentType _ = "text" // "plain"
 instance MimeRender Plain LBS.ByteString where
   mimeRender _ = id
   {-# INLINE mimeRender #-}
+  
+-- * HTML
+-- TODO: package the following block of code into a library akin to 'servant-lucid'
+
+data HTML
+instance Accept HTML where
+    contentTypes _ =
+      "text" // "html" /: ("charset", "utf-8") NE.:|
+      ["text" // "html"]
+instance Html.Document a => MimeRender HTML a where
+    mimeRender _ = Html.renderByteString
 
 ------------------------------------------------------------------------------
 
@@ -204,23 +219,49 @@ selectFortunes conn = do
     _ -> Left err
 {-# INLINE selectFortunes #-}
 
-fortunes :: DbPool -> Handler (Lucid.Html ())
+type FortunesHtml
+  = (('Html.DOCTYPE Html.> ())
+  # ('Html.Html
+    > (('Html.Head > ('Html.Title > Html.Raw Text))
+      # ('Html.Body
+        > ('Html.Table
+          > (
+              ('Html.Tr
+              > ( ('Html.Th > Html.Raw Text)
+                # ('Html.Th > Html.Raw Text)
+                )
+              )
+            # ['Html.Tr
+              > ( ('Html.Td > Int)
+                # ('Html.Td > Text)
+                )
+              ]
+            )
+          )
+        )
+      )
+    )
+  )
+
+fortunes :: DbPool -> Handler FortunesHtml
 fortunes pool = do
   r <- liftIO $ Pool.withResource pool selectFortunes
   case r of
     Left e -> throwError err500 { errBody = LBS.fromStrict . TextEnc.encodeUtf8 . Text.pack . show $ e }
     Right fs -> return $ do
       let new = Fortune 0 "Additional fortune added at request time."
-      Lucid.doctypehtml_ $ do
-        Lucid.head_ $ Lucid.title_ "Fortunes"
-        Lucid.body_ $ do
-          Lucid.table_ $ do
-            Lucid.tr_ $ do
-              Lucid.th_ "id"
-              Lucid.th_ "message"
-            mapM_ (\f -> Lucid.tr_ $ do
-              Lucid.td_ (Lucid.toHtml . show $ fId f)
-              Lucid.td_ (Lucid.toHtml $ fMessage f)) (sortOn fMessage (new : fs))
+      let header = Html.tr_ $ Html.th_ (Html.Raw "id") # Html.th_ (Html.Raw "message")
+      let mkRow f = Html.tr_ $ Html.td_ (fromIntegral $ fId f) # Html.td_ (fMessage f)
+      let rows = fmap mkRow $ sortOn fMessage (new : fs)
+      Html.doctype_ #
+        Html.html_ (
+          Html.head_ (
+            Html.title_ (Html.Raw "Fortunes")
+          ) #
+          Html.body_ ( Html.table_ $
+            header # rows
+          )
+        )
 {-# INLINE fortunes #-}
 
 -- * Test 5: Updates

frameworks/Haskell/servant/mysql-haskell/stack.yaml

@@ -1,7 +0,0 @@
-resolver: lts-13.11
-packages:
-- '.'
-
-# the following flags are meant for use with ../servant-mysql-haskell.dockerfile
-compiler: ghc-8.6.3 # this MUST match the resolver's GHC; minor hack to ensure GHC isn't downloaded into sandbox.
-allow-different-user: true # carryover from hasql sibling test dir

frameworks/Haskell/servant/servant-mysql-haskell.dockerfile

@@ -1,13 +0,0 @@
-FROM haskell:8.6.3
-
-WORKDIR /servant
-
-COPY ./mysql-haskell/stack.yaml .
-COPY ./mysql-haskell/servant-mysql-haskell.cabal .
-RUN stack setup
-RUN stack install --dependencies-only
-
-ADD ./mysql-haskell/ .
-RUN stack build --pedantic
-
-CMD stack exec servant-mysql-haskell -- tfb-database +RTS -A32m -N$(nproc)

frameworks/Haskell/servant/servant.dockerfile

@@ -3,14 +3,19 @@ FROM haskell:8.6.3
 RUN apt update -yqq && apt install -yqq xz-utils make
 RUN apt install -yqq libpq-dev
 
-WORKDIR /servant
+WORKDIR /app
 
-COPY ./hasql/stack.yaml .
-COPY ./hasql/servant-bench.cabal .
+COPY ./stack.yaml .
+COPY ./hasql/servant-hasql.cabal ./hasql/
+COPY ./mysql-haskell/servant-mysql-haskell.cabal ./mysql-haskell/
 RUN stack setup
 RUN stack install --dependencies-only
 
-ADD ./hasql/ .
-RUN stack build --pedantic
+ADD ./hasql/ ./hasql/
+ADD ./mysql-haskell/ ./mysql-haskell/
+RUN stack build --pedantic --copy-bins
+RUN ln -s ~/.local/bin/servant-hasql ~/.local/bin/servant
 
-CMD stack --allow-different-user exec servant-exe -- tfb-database +RTS -A32m -N$(nproc)
+ARG TFB_TEST_NAME
+ENV TFB_TEST_NAME=${TFB_TEST_NAME}
+CMD stack exec $TFB_TEST_NAME -- tfb-database +RTS -A32m -N$(nproc)

frameworks/Haskell/servant/stack.yaml

@@ -0,0 +1,8 @@
+resolver: lts-13.13
+packages:
+- './hasql'
+- './mysql-haskell'
+
+# the following flags are meant for use with servant.dockerfile
+compiler: ghc-8.6.3 # this MUST match the resolver's GHC; minor hack to ensure GHC isn't downloaded into sandbox.
+allow-different-user: true