Haskell Web Client-Server - Yesod

Application.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Application
    ( getApplicationDev
    , appMain
    , develMain
    , makeFoundation
    , makeLogWare
    -- * for DevelMain
    , getApplicationRepl
    , shutdownApp
    -- * for GHCI
    , handler
    ) where

import Control.Monad.Logger                 (liftLoc)
import Import
import Language.Haskell.TH.Syntax           (qLocation)
import Network.HTTP.Client.TLS              (getGlobalManager)
import Network.Wai (Middleware)
import Network.Wai.Middleware.Cors
import Network.Wai.Handler.Warp             (Settings, defaultSettings,
                                             defaultShouldDisplayException,
                                             runSettings, setHost,
                                             setOnException, setPort, getPort)
import Network.Wai.Middleware.RequestLogger (Destination (Logger),
                                             IPAddrSource (..),
                                             OutputFormat (..), destination,
                                             mkRequestLogger, outputFormat)
import System.Log.FastLogger                (defaultBufSize, newStdoutLoggerSet,
                                             toLogStr)

-- Import all relevant handler modules here.
-- Don't forget to add new modules to your cabal file!
import Handler.Common
import Handler.Home
import Handler.Comment
import Handler.BinStrTx

-- This line actually creates our YesodDispatch instance. It is the second half
-- of the call to mkYesodData which occurs in Foundation.hs. Please see the
-- comments there for more details.
mkYesodDispatch "App" resourcesApp

-- | This function allocates resources (such as a database connection pool),
-- performs initialization and returns a foundation datatype value. This is also
-- the place to put your migrate statements to have automatic database
-- migrations handled by Yesod.
makeFoundation :: AppSettings -> IO App
makeFoundation appSettings = do
    -- Some basic initializations: HTTP connection manager, logger, and static
    -- subsite.
    appHttpManager <- getGlobalManager
    appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
    appStatic <-
        (if appMutableStatic appSettings then staticDevel else static)
        (appStaticDir appSettings)

    -- Return the foundation
    return App {..}

-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
-- applying some additional middlewares.
makeApplication :: App -> IO Application
makeApplication foundation = do
    logWare <- makeLogWare foundation
    -- Create the WAI application and apply middlewares
    appPlain <- toWaiAppPlain foundation
    return $ logWare $ defaultMiddlewaresNoLogging $ simpleCors appPlain

makeLogWare :: App -> IO Middleware
makeLogWare foundation =
    mkRequestLogger def
        { outputFormat =
            if appDetailedRequestLogging $ appSettings foundation
                then Detailed True
                else Apache
                        (if appIpFromHeader $ appSettings foundation
                            then FromFallback
                            else FromSocket)
        , destination = Logger $ loggerSet $ appLogger foundation
        }


-- | Warp settings for the given foundation value.
warpSettings :: App -> Settings
warpSettings foundation =
      setPort (appPort $ appSettings foundation)
    $ setHost (appHost $ appSettings foundation)
    $ setOnException (\_req e ->
        when (defaultShouldDisplayException e) $ messageLoggerSource
            foundation
            (appLogger foundation)
            $(qLocation >>= liftLoc)
            "yesod"
            LevelError
            (toLogStr $ "Exception from Warp: " ++ show e))
      defaultSettings

-- | For yesod devel, return the Warp settings and WAI Application.
getApplicationDev :: IO (Settings, Application)
getApplicationDev = do
    settings <- getAppSettings
    foundation <- makeFoundation settings
    wsettings <- getDevSettings $ warpSettings foundation
    app <- makeApplication foundation
    return (wsettings, app)

getAppSettings :: IO AppSettings
getAppSettings = loadYamlSettings [configSettingsYml] [] useEnv

-- | main function for use by yesod devel
develMain :: IO ()
develMain = develMainHelper getApplicationDev

-- | The @main@ function for an executable running this site.
appMain :: IO ()
appMain = do
    -- Get the settings from all relevant sources
    settings <- loadYamlSettingsArgs
        -- fall back to compile-time values, set to [] to require values at runtime
        [configSettingsYmlValue]

        -- allow environment variables to override
        useEnv

    -- Generate the foundation from the settings
    foundation <- makeFoundation settings

    -- Generate a WAI Application from the foundation
    app <- makeApplication foundation

    -- Run the application with Warp
    runSettings (warpSettings foundation) app


--------------------------------------------------------------
-- Functions for DevelMain.hs (a way to run the app from GHCi)
--------------------------------------------------------------
getApplicationRepl :: IO (Int, App, Application)
getApplicationRepl = do
    settings <- getAppSettings
    foundation <- makeFoundation settings
    wsettings <- getDevSettings $ warpSettings foundation
    app1 <- makeApplication foundation
    return (getPort wsettings, foundation, app1)

shutdownApp :: App -> IO ()
shutdownApp _ = return ()


---------------------------------------------
-- Functions for use in development with GHCi
---------------------------------------------

-- | Run a handler
handler :: Handler a -> IO a
handler h = getAppSettings >>= makeFoundation >>= flip unsafeHandler h

bin-str-tx.cabal

cabal-version: 1.12

-- This file has been generated from package.yaml by hpack version 0.31.2.
--
-- see: https://github.com/sol/hpack
--
-- hash: 3b3a66a78132971b2a12277e488c8adef493e0fc21e0c559c008c95ae15d06db

name:           bin-str-tx
version:        0.0.0
build-type:     Simple

flag dev
  description: Turn on development settings, like auto-reload templates.
  manual: False
  default: False

flag library-only
  description: Build for use with "yesod devel"
  manual: False
  default: False

library
  exposed-modules:
      Application
      Foundation
      Handler.Comment
      Handler.Common
      Handler.Home
      Handler.BinStrTx
      Import
      Import.NoFoundation
      Settings
      Settings.StaticFiles
  other-modules:
      Paths_bin_str_tx
  hs-source-dirs:
      src
  build-depends:
      aeson >=1.4 && <1.5
    , base >=4.9.1.0 && <5
    , bytestring >=0.10 && <0.11
    , case-insensitive
    , classy-prelude >=1.5 && <1.6
    , classy-prelude-conduit >=1.5 && <1.6
    , classy-prelude-yesod >=1.5 && <1.6
    , conduit >=1.0 && <2.0
    , containers
    , data-default
    , directory >=1.1 && <1.4
    , fast-logger >=2.2 && <3.1
    , file-embed
    , foreign-store
    , hjsmin >=0.1 && <0.3
    , http-client-tls >=0.3 && <0.4
    , http-conduit >=2.3 && <2.4
    , monad-control >=0.3 && <1.1
    , monad-logger >=0.3 && <0.4
    , safe
    , shakespeare >=2.0 && <2.1
    , template-haskell
    , text >=0.11 && <2.0
    , time
    , unordered-containers
    , vector
    , wai
    , wai-cors
    , wai-extra >=3.0 && <3.1
    , wai-logger >=2.2 && <2.4
    , warp >=3.0 && <3.4
    , yaml >=0.11 && <0.12
    , yesod >=1.6 && <1.7
    , yesod-core >=1.6 && <1.7
    , yesod-form >=1.6 && <1.7
    , yesod-static >=1.6 && <1.7
  if (flag(dev)) || (flag(library-only))
    ghc-options: -Wall -fwarn-tabs -O0
    cpp-options: -DDEVELOPMENT
  else
    ghc-options: -Wall -fwarn-tabs -O2
  default-language: Haskell2010

executable bin-str-tx
  main-is: main.hs
  other-modules:
      DevelMain
      Paths_bin_str_tx
  hs-source-dirs:
      app
  ghc-options: -threaded -rtsopts -with-rtsopts=-N
  build-depends:
      aeson >=1.4 && <1.5
    , base >=4.9.1.0 && <5
    , bin-str-tx
    , bytestring >=0.10 && <0.11
    , case-insensitive
    , classy-prelude >=1.5 && <1.6
    , classy-prelude-conduit >=1.5 && <1.6
    , classy-prelude-yesod >=1.5 && <1.6
    , conduit >=1.0 && <2.0
    , containers
    , data-default
    , directory >=1.1 && <1.4
    , fast-logger >=2.2 && <3.1
    , file-embed
    , foreign-store
    , hjsmin >=0.1 && <0.3
    , http-client-tls >=0.3 && <0.4
    , http-conduit >=2.3 && <2.4
    , monad-control >=0.3 && <1.1
    , monad-logger >=0.3 && <0.4
    , safe
    , shakespeare >=2.0 && <2.1
    , template-haskell
    , text >=0.11 && <2.0
    , time
    , unordered-containers
    , vector
    , wai
    , wai-cors
    , wai-extra >=3.0 && <3.1
    , wai-logger >=2.2 && <2.4
    , warp >=3.0 && <3.4
    , yaml >=0.11 && <0.12
    , yesod >=1.6 && <1.7
    , yesod-core >=1.6 && <1.7
    , yesod-form >=1.6 && <1.7
    , yesod-static >=1.6 && <1.7
  if flag(library-only)
    buildable: False
  default-language: Haskell2010

test-suite bin-str-tx-test
  type: exitcode-stdio-1.0
  main-is: Spec.hs
  other-modules:
      Handler.CommonSpec
      Handler.HomeSpec
      TestImport
      Paths_bin_str_tx
  hs-source-dirs:
      test
  ghc-options: -Wall
  build-depends:
      aeson >=1.4 && <1.5
    , base >=4.9.1.0 && <5
    , bin-str-tx
    , bytestring >=0.10 && <0.11
    , case-insensitive
    , classy-prelude >=1.5 && <1.6
    , classy-prelude-conduit >=1.5 && <1.6
    , classy-prelude-yesod >=1.5 && <1.6
    , conduit >=1.0 && <2.0
    , containers
    , data-default
    , directory >=1.1 && <1.4
    , fast-logger >=2.2 && <3.1
    , file-embed
    , foreign-store
    , hjsmin >=0.1 && <0.3
    , hspec >=2.0.0
    , http-client-tls >=0.3 && <0.4
    , http-conduit >=2.3 && <2.4
    , monad-control >=0.3 && <1.1
    , monad-logger >=0.3 && <0.4
    , safe
    , shakespeare >=2.0 && <2.1
    , template-haskell
    , text >=0.11 && <2.0
    , time
    , unordered-containers
    , vector
    , wai
    , wai-cors
    , wai-extra >=3.0 && <3.1
    , wai-logger >=2.2 && <2.4
    , warp >=3.0 && <3.4
    , yaml >=0.11 && <0.12
    , yesod >=1.6 && <1.7
    , yesod-core >=1.6 && <1.7
    , yesod-form >=1.6 && <1.7
    , yesod-static >=1.6 && <1.7
    , yesod-test
  default-language: Haskell2010

BinStrTx.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Handler.BinStrTx where

import qualified Import as Im
--import Yesod
--import qualified Data.Aeson as Ae

-- Binary string transmitter  (Hutton, p. 82)
-- {-# LANGUAGE NoImplicitPrelude #-}
-- I changed "iterate" to "iterateC", as required by import Import (classy-prelude)
--  see stackage.org/haddock classy-prelude  ClassyPrelude.Yesod

import Data.Char
--import Data.Text (Text)
--import qualified Data.Text as T

--newtype TxText = TxText Text

type Bit = Int

bin2int' :: [Bit] -> Int
bin2int' bits = sum [w*b | (w,b) <- zip weights bits]
               where weights = iterate (*2) 1

bin2int :: [Bit] -> Int
bin2int = foldr (\x y -> x + 2*y) 0

int2bin :: Int -> [Bit]
int2bin 0 = []
int2bin n = n `mod` 2 : int2bin (n `div` 2)

make8 :: [Bit] -> [Bit]
make8 bits = take 8 (bits ++ repeat 0)

-- Transmission

encode :: String -> [Bit]
encode = concat . map (make8 . int2bin . ord)

chop8 :: [Bit] -> [[Bit]]
chop8 [] = []
chop8 bits = take 8 bits : chop8 (drop 8 bits)

decode :: [Bit] -> String
decode = map (chr . bin2int) . chop8

transmit :: String -> String
transmit = decode . channel . encode

channel :: [Bit] -> [Bit]
channel = id

-- OLD this works
{-
getBinStrTxR :: Im.Handler Im.Html
getBinStrTxR = do
    $(Im.logDebug) "Trying to do getBinStrTxR"
    let result = transmit "secret message" :: String
    --Im.defaultLayout [Im.whamlet|<p>transmit test!|]
    Im.defaultLayout [Im.whamlet|<p>result is #{result}!|]
-}

getBinStrTxR :: String -> Im.Handler Im.Html
getBinStrTxR message = do
    $(Im.logDebug) "Trying to do getBinStrTxR"
    let result = transmit message
    Im.defaultLayout [Im.whamlet|<p>result is #{result}!|]

routes

-- By default this file is used by `parseRoutesFile` in Foundation.hs
-- Syntax for this file here: https://www.yesodweb.com/book/routing-and-handlers

/static StaticR Static appStatic

/favicon.ico FaviconR GET
/robots.txt RobotsR GET

/ HomeR GET POST

/comments CommentR POST

/transmit/#String BinStrTxR GET

xholonWorkbook.xml

<?xml version="1.0" encoding="UTF-8"?>
<!--Xholon Workbook http://www.primordion.com/Xholon/gwt/ MIT License, Copyright (C) Ken Webb, Thu May 14 2020 11:10:22 GMT-0400 (Eastern Daylight Time)-->
<XholonWorkbook>

<Notes><![CDATA[
Xholon
------
Title: Haskell Web Client-Server - Yesod
Description: 
Url: http://www.primordion.com/Xholon/gwt/
InternalName: da59c4d1196cfd797e8b1149cf95ed95
Keywords: 

My Notes
--------
May 12, 2020

Experiment with the Yesod framework.
It provides a Web server and environment written in Haskell.

http://127.0.0.1:8888/wb/editwb.html?app=Haskell+Web+Client-Server+-+Yesod&src=lstr
http://127.0.0.1:8888/Xholon.html?app=Haskell+Web+Client-Server+-+Yesod&src=lstr&gui=clsc
http://localhost:8888/Xholon.html?app=Haskell+Web+Client-Server+-+Yesod&src=lstr&gui=clsc
- if I use "localhost", I see nothing in Yesod terminal log, and nothing in Dev Tools Network
- but if I use "127.0.0.1", then in Dev Tools Network I see:
 "Cross-Origin Request Blocked: The Same Origin Policy disallows reading the remote resource at http://localhost:3000/. (Reason: CORS header ‘Access-Control-Allow-Origin’ missing)."

TODO
- do something similar to my Robot workbook [ref 15]
- use "Haskell - Hutton - Binary string transmitter" as a test [ref 16]

To run Haskell/Yesod server:
--------------------
ken@ken-Lenovo-Yoga-3-14:~/haskellspace_stack/my-project$ ...
(base) ken@ken-Lenovo-Yoga-3-14:~/haskellspace_stack/kenz-yesodtest03$ stack exec -- yesod devel

Quick Test
----------
http://localhost:3000
http://127.0.0.1:3000/test

Process:
-------
1. get things set up
2. run Haskell/Yesod
    stack runghc helloworld.hs
    stack exec -- yesod devel
3. start Xholon app:
    http://127.0.0.1:8888/Xholon.html?app=Haskell+Web+Client-Server+-+Yesod&src=lstr&gui=clsc
4. send request to server:
    in Xholon app, press "S" for step

This works (Wed May 13 2020)
----------
- see Yesod book, "Basics" chapter, "Links" example
(base) ken@ken-Lenovo-Yoga-3-14:~/haskellspace_stack/kenz-yesodtest02$ stack runghc links.hs

- restart this Xholon app, and press Step
- Dev Tools Console
Cross-Origin Request Blocked: The Same Origin Policy disallows reading the remote resource at http://127.0.0.1:3000/page1. (Reason: CORS header ‘Access-Control-Allow-Origin’ missing).
- BUT I still get a response

- Yesod log
127.0.0.1 - - [13/May/2020:06:32:01 -0400] "GET /page1 HTTP/1.1" 200 126 "http://127.0.0.1:8888/Xholon.html?app=Haskell+Web+Client-Server+-+Yesod&src=lstr&gui=clsc" "Mozilla/5.0

- response payload as viewed in Dev Tools Network
<!DOCTYPE html>
<html><head><title></title></head><body><a href="http://127.0.0.1:3000/page2">Go to page 2!</a>
</body></html>

- TODO
- see how I solved the CORS problem in "Python Robot - Dash"
 - I had to add code to the Python program
--------------------------------

May 13, 2020
new Yesod project - bin-str-tx
------------------------------
- Graham Hutton's "Binary string transmitter" [ref 18]
cd ~/haskellspace_stack   _
stack new bin-str-tx yesodweb/simple
cd bin-str-tx
- fix the generated scaffolding to support CORS
 - see the Yesod cookbook file that I printed
- create a Handler for route /transmit
 - src/Handler/BinStrTx.hs
- fix files to support new Handler
  bin-str-tx.cabal
  Application.hs
  BinStrTx.hs
- edited config/routes
stack exec -- yesod devel


References
----------
(1) https://www.yesodweb.com
    Yesod Web Framework
    Yesod is a Haskell web framework for productive development of type-safe, RESTful, high performance web applications.

(2) https://www.yesodweb.com/page/quickstart
    Yesod quick start guide

(3) https://github.com/yesodweb/yesod-scaffold
    The Yesod scaffolding, with branches for different versions.

(4) http://hackage.haskell.org/package/warp
    warp: A fast, light-weight web server for WAI applications.

(5) https://www.stackage.org/package/warp
    Warp is a server library for HTTP/1.x and HTTP/2 based WAI(Web Application Interface in Haskell).

(6) https://www.aosabook.org/en/yesod.html
(7) https://www.aosabook.org/en/posa/warp.html

(8) https://github.com/yesodweb/yesod
    

(9) https://github.com/yesodweb/wai

(10) https://www.yesodweb.com/book
    Yesod Web Framework Book- Version 1.6
    Available from O'Reilly, and as html pages at this web site.

(11) https://github.com/yesodweb/yesod-cookbook/blob/master/Cookbook.md
    The Yesod Cookbook contains small snippets of code for solving practical problems with Yesod.

(12) https://github.com/snoyberg
    Michael Snoyman
    main author of Yesod, including the book
    VP, fpcomplete.com
    many github repos

(13) https://github.com/mfine/heroku-buildpack-stack
 ) https://elements.heroku.com/buildpacks/mfine/heroku-buildpack-stack
    Heroku buildpack
    Haskell Stack support for Heroku

(14) https://github.com/yesodweb/yesod-cookbook/blob/master/cookbook/Using-Ajax-with-a-Scaffolded-Site.md
    Using Ajax with a Scaffolded Site
    

(15) https://www.primordion.com/Xholon/gwt/wb/editwb.html?app=96da9e285876f9acc88625c962854df9&src=gist
    Python Robot - Dash
    uses vanilla ajax to connect to a Python server

(16) https://www.primordion.com/Xholon/gwt/wb/editwb.html?app=7eea6b043213653408b492f6a2de329c&src=gist
    Haskell - Hutton - Binary string transmitter

(17) https://en.wikipedia.org/wiki/Yesod_(web_framework)

(18) Graham Huttton, Programming in Haskell, Second Edition
    a book

]]></Notes>  

<_-.XholonClass>
  <PhysicalSystem/>
  
  <Yesod/>
  
</_-.XholonClass>

<xholonClassDetails>
  
</xholonClassDetails>

<PhysicalSystem>
  
  <Yesod/>
  
</PhysicalSystem>

<Yesodbehavior implName="org.primordion.xholon.base.Behavior_gwtjs"><![CDATA[
function reqListener () {
  //$wnd.console.log(this.responseText);
  $wnd.xh.root().println(this.responseText);
  //$doc.append(this.responseText);
  var node = $doc.createElement("DIV");
  node.innerHTML = this.responseText;
  $doc.querySelector("body").appendChild(node);
}

// progress on transfers from the server to the client (downloads)
function updateProgress (oEvent) {
  if (oEvent.lengthComputable) {
    var percentComplete = oEvent.loaded / oEvent.total * 100;
    $wnd.xh.root().println("Progress percentComplete: " + percentComplete);
  } else {
    // Unable to compute progress information since the total size is unknown
  }
}

function transferComplete(evt) {
  $wnd.xh.root().println("The transfer is complete.");
}

function transferFailed(evt) {
  $wnd.xh.root().println("An error occurred while transferring the file.");
}

function transferCanceled(evt) {
  $wnd.xh.root().println("The transfer has been canceled by the user.");
}

var me, oReq, counter, beh = {
postConfigure: function() {
  me = this.cnode.parent();
  oReq = new $wnd.XMLHttpRequest();
  //oReq.addEventListener("load", reqListener);
  oReq.addEventListener("progress", updateProgress);
  oReq.addEventListener("load", transferComplete);
  oReq.addEventListener("error", transferFailed);
  oReq.addEventListener("abort", transferCanceled);
  //oReq.open("GET", "http://127.0.0.1:3000");
  // server: GET /
  //   Accept: */*
  //   Status: 200 OK 0.019616607s
  //oReq.send();
  me.println("XMLHttpRequest new ...");
  counter = 0;
},
act: function() {
  var route = "transmit"; // test comments page1 transmit
  var input = null;
  switch (counter) {
  case 0: input = "This is my secret message."; break;
  case 1: input = "un deux trois"; break;
  case 2: input = "one two three"; break;
  case 3: input = "uno dos tres"; break;
  default: input = "The End."; break;
  }
  var restRoute = route + "/" + input;
  oReq.addEventListener("load", reqListener);
  oReq.open("GET", "http://127.0.0.1:3000/" + restRoute);
  oReq.send();
  me.println("XMLHttpRequest " + restRoute + " ...");
  counter++;
}
}
//# sourceURL=Yesodbehavior.js
]]></Yesodbehavior>

<SvgClient><Attribute_String roleName="svgUri"><![CDATA[data:image/svg+xml,
<svg width="100" height="50" xmlns="http://www.w3.org/2000/svg">
  <g>
    <title>Yesod</title>
    <rect id="PhysicalSystem/Yesod" fill="#98FB98" height="50" width="50" x="25" y="0"/>
    <g>
      <title>???</title>
      <rect id="PhysicalSystem/Yesod/*" fill="#6AB06A" height="50" width="10" x="80" y="0"/>
    </g>
  </g>
</svg>
]]></Attribute_String><Attribute_String roleName="setup">${MODELNAME_DEFAULT},${SVGURI_DEFAULT}</Attribute_String></SvgClient>

</XholonWorkbook>