Welcome back. As we have getting our feeds literally wet with Yesod and have seen how to implement the basics of a blog and make use of the Scaffolding, there may be still some things we like to learn. Yeah, that's why we are here - in this post we will walk through an useful example and deepen our understandings.

But before that, let me put up another analogy. I am a big fan of old heavy-duty LandCruisers. They are fantastic examples of engineering, at least you will experience what I am saying if you get your hands on one and come to the point where you have to repair it. It is made for that. Even in, let's say, techless environments, you have a good chance to do so. It is build in a very robust way without being to heavy. Their lifespan is fantastic. Most of all: they are by default simple machines.

This reminds me on how we (in a future) may be able to create software. Robust, modular, repair- and maintainable. At the moment we are learning mechanics, putting pieces together. But close is that we will be able to adapt something that is made by somebody else to our own special needs. Big step ahead oho!

I have written the last Blogpost quite a while ago and it might be time to update our Ghc/Stack environment. At least I have done so in between. You may skip this section but due to the release of interesting software, like the new Haskell-Language-Server which I use in NVim, it might be a good idea to do so. Sooner or later we have to anyway.

https://www.haskell.org/ghcup/

You still may have curl installed to download Ghcup. Take care that the ghcup-binary is located in your PATH.

In a Terminal

ghcup --help

show us different options, where

ghcup list

displays a list of available versions.

I choose'd

ghcup install 8.8.4

which at time of writing is the recommended version. As you already imagine this take some time. Now there are at least 2 version of Ghc installed, 8.6.5 and 8.8.4, so

ghcup set 8.8.4

completes the installation. There might be some error about "allow-newer: true", so you want to comment/uncomment it in ~/.stack/config.yaml and retry.

On https://www.stackage.org/ we check for the last LTS-Release (by now 16.27) and may change our ~.stack/global-project/stack.yaml according to. That is now valid for every new project we init with Stack.

Go to your ~/blog folder and please clone the blogandmore repo.

Elsewise you may work based on your yesodblog; naming here will be blogandmore.

stack build 

will need some time - in between we might create an alias like

alias b4='cd /home/ye/blog/blogandmore'

in our .bashrc.

yesod devel

will connect us with the overall friendly Ghc. Yes, OK sorry: he is well known as the ceremony master here.

Uuh, sometimes I tend to forget things, so a quick look at the preliminaries article will result in:

CREATE USER blogandmore WITH PASSWORD 'blogandmore';
CREATE DATABASE blogandmore;
GRANT ALL PRIVILEGES ON DATABASE blogandmore TO blogandmore;

followed by

stack build

and

yesod devel

will get us where we want to go.

One thing you might notice here is that our site doesn't load google-fonts anymore. If you want to change that behavior, you should check static/css/bootstrap.css and have a look at the first line of the file. I don't think for our purposes we need some external fonts, so I comment it out and use some standards.

OK, anyway. Before we continue let's

our project. Still inside the root of blog/blogandmore we do

git init
git add .
git commit -m "first Commit"

if your git-instance is remote you may have to insert something like

git remote add origin https://git.onepigayear.de/ye/blogandmore.git

and finally

git push -u origin master

We now have a master branch, that we want to use as a safe base for our doing. To create a new (workbench-)branch I use

git checkout -b 'workbench'
git status

and when done some changes

git add .
git commit -m "describing the commit"
git push origin workbench

If and only if my changes are substantial, tested and I am happy, I do a pull request inside the repo to merge it into master.

Also if I have babbled about cars, let me remind you that we walk by feet here and have learned - working through the last episodes of this Blog - that traveling and corresponding discovery's are correlated and pace dependent. So for the moment, we try to enjoy all the little bits and pieces, but certainly want to dig in deeper and discuss how to implement some more functionality.

First thing to do is to add a new page to our project. It will combine a map with some information about our doing - say, we are a small hackerspace and want to display location and opening hours.

As we are not always open and the space not always available, we have to update our opening hours on the fly. Oh yeah, how to do that? We come up with a simple solution: what, if we update opening hours like we publish new blogposts?

But should only one of us change that openings? No, we have to have also a multi user login. Things getting even more complex if we follow the idea that pictures tell more than words and want to have a visual thematic announcement of the hot topic of the week? Make sure you are in 'workbench', stay cool and hit

yesod add-handler

in your Terminal.

We will be asked for the name of the route (without trailing R):

Openings

Enter route pattern (ex: /entry/#EntryId):

/openings

and should enter space-separated list of methods (ex: GET POST): Which we do by entering

GET

Ghc compiles but gives us a warning:

/home/ye/cava/blog/blogpost/src/Foundation.hs:170:5: warning: [-Wincomplete-patterns]
Pattern match(es) are non-exhaustive
In an equation for ‘isAuthorized’:
    Patterns not matched: OpeningsR _
    |
170 |     isAuthorized (AuthR _) _ = return Authorized
    |     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^...

If we open

localhost:3000/openings

the error is confirmed like

Internal Server Error
src/Foundation.hs:(175,5)-(184,45): Non-exhaustive patterns in function isAuthorized

OK, let's get it done directly and add

isAuthorized OpeningsR _ = return Authorized

to scr/Foundation.hs.

Also we may want to define a menu entry in src/Foundation.hs before the Login MenuItem and set menuItemAcessCallback to "true". If you go up in that file, around line 46 you may have a look at the declaration for the data structure MenuItem.

In default-layout.hamlet the menuItem label route _ <- navbarLeftFilteredMenuItems is around line 14 inserted in the general navbar structure. Does this remember you at our BlogPost datastructure? - sure it does. Study the thing a bit and try to imagine how you would add a new MenuType for, let's say, a dropdownmenu.

You still have yesod devel running, do you? If we check our new menu entry we see something like

Not yet implemented: getOpeningsR
CallStack (from HasCallStack):

displayed on that page.

Accessing the src/Handler/Openings.hs file, give it a title and the according widgetFile (which we also have to create) results in

/home/ye/cava/web/blog/blogandmore/src/Handler/Openings.hs:7:21: error:
    • Couldn't match type ‘()’ with ‘WidgetFor App ()’
      Expected type: Language.Haskell.TH.Syntax.Q
                       Language.Haskell.TH.Syntax.Exp
                     -> WidgetFor App ()
        Actual type: Language.Haskell.TH.Syntax.Q
                       Language.Haskell.TH.Syntax.Exp
                     -> ()
    • The first argument of ($) takes one argument,
      its type is ‘m0 ()’,
      it is specialized to ‘Language.Haskell.TH.Syntax.Q
                              Language.Haskell.TH.Syntax.Exp
                            -> ()’
      In the second argument of ‘($)’, namely
        ‘do setTitle "Openings" $ (widgetFile "openings")’
      In a stmt of a 'do' block:
        defaultLayout $ do setTitle "Openings" $ (widgetFile "openings")
  |
7 |     defaultLayout $ do
  |                     ^^...

...

/home/ye/cava/web/blog/blogandmore/src/Handler/Openings.hs:8:18: error:
    • Couldn't match type ‘[Char]’
                     with ‘blaze-markup-0.8.2.7:Text.Blaze.Internal.MarkupM ()’
      Expected type: Html
        Actual type: [Char]
    • In the first argument of ‘setTitle’, namely ‘"Openings"’
      In a stmt of a 'do' block: setTitle "Openings"
      In the expression: do setTitle "Openings"
  |
8 |         setTitle "Openings"
  |                  ^^^^^^^^^^

As all new relationships in a special way are sensitive, we're still a bit surprised about Ghc and how he is, let's say merciless. But have a look at the line Expected type: Language.Haskell.TH.Syntax.Q which let me think of the Template Haskell Language pragma. You may have read about Template Haskell (TH) as an important technique of Yesod.

https://wiki.haskell.org/Template_Haskell

Mmh, as there is still some road to go, we directly enhance our src/Handler/Openings.hs with

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}

and get things going again. Note how Ghc confirms by outputting again merciless:

...
[13 of 14] Compiling Handler.Openings
[14 of 14] Compiling Application [TH]
...

So now we have in src/Handler/Openings.hs something like

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module Handler.Openings where
import Import
getOpeningsR :: Handler Html
getOpeningsR = do
    defaultLayout $ do
        setTitle "Openings"
        $(widgetFile "openings")

In config/models... we begin to lay out things by creating a new section like..., let's think again: we want a simple inputform with the opening hours, maybe a nick of the one of us who will be there, some time structuring and a theme pic. We fit this all together in one data-structure

Open
    filename Text
    contenType Text
    topic Text
    hours Text
    person Text
    created UTCTime
    content ByteString
    deriving Show

and get a confirmation that our database is prepared. And Yeah, let's see - your first draft for the visual announcing is as usual: fantastic!

Before we dive deeper into the HackToDay challenge I strongly recommend to take a breath here and go to

https://www.schoolofhaskell.com/school/advanced-haskell/building-a-file-hosting-service-in-yesod

where you get a lot of insight into the framework itself. Michael Steel, the author of the tutorial, explains consistent and very beginner friendly. Part 1-4 will guide to handle the complexity of file-uploads and treat questions that may come up. It is the github repo for the fifth part

https://github.com/mikesteele81/soh-file-server-tutorial-project

and the corresponding tutorial

https://www.schoolofhaskell.com/school/to-infinity-and-beyond/competition-winners/part-5

on which our doing here heavily based on.

In general we may distinguish between uploads to the database and a file server served by a folder structure. There is also a third way by uploading small pictures (thumbs) as text, I believe. For our usecase we push stuff to our database via a form and serve from there.

Again we do

yesod add-handler

followed by

CreateOpenings
/createOpenings
GET POST

We know how to handle the isAuthorized warning already. But this time, as not everyone should be able to update our openings, we make it "isAuthenticated" and insert a new menu entry accordingly with the menuItemAccessCallback = isJust muser.

In the building-a-blog-with-yesod-part-3 article we have covered login credentials.

To be redundant let's lay out our proceeding again, what in principle is still the same technique as creating a blogpost:

• Update the config/models... file as done above,
• write the openingsForm and the getCreateOpenings Handler,
• write the postCreateOpenings Handler,
• write/complete the getOpenings Handler,
• adjust config/routes if necessary.

It is a good idea to emerge some workflow habits here and it is an essential part of our progress in learning. Adapting from the mikesteeltutorial to our src/Handler/CreateOpenings.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module Handler.CreateOpenings where
import Import
openForm :: Html -> MForm Handler (FormResult (FileInfo, Text, Text, Text, UTCTime), Widget)
openForm = renderDivs $ (,,,,) 
    <$> fileAFormReq "file" 
    <*> areq textField "topic" Nothing 
    <*> areq textField "hours" Nothing 
    <*> areq textField "person" Nothing
    <*> lift (liftIO getCurrentTime)

where our approach is to combine FileInfo with the information we had layout in our config/models.... The 'created' (getCurrentTime) entry will help us to sort things later. You may also notice that we use a MForm - instead of the AForm Handler we are used to. The Form Chapter of the Yesodbook gives more explanation about it.

While inserting the Get Handler like so

getCreateOpeningsR :: Handler Html
getCreateOpeningsR = do
    (formWidget, formEncType) <- generateFormPost openForm
    opens <- getList
    defaultLayout $ do
        setTitle "CreateOpenings"
        $(widgetFile "createopenings")

Ghc tells us that getList is not in scope. In the tutorial we find it in src/Foundation.hs. But why don't we use it directly in here? Easy answer is to put it in src/Foundation makes it project-wide.

getList :: Handler [Entity Open]
getList = runDB $ selectList [] []

Ghc give us warnings about 'formWidget and formEncType' and 'opens' constructed by getList. We will use each of them in our Templates so they might disappear.

Time to create the Post Handler, what we do with

postCreateOpeningsR :: Handler Html
postCreateOpeningsR = do
    ((result, _), _) <- runFormPost openForm
    case result
    -- fi is a 'FileInfo'
          of
        FormSuccess (fi, topic, hours, person, created)
         -> do
            fileBytes <- runResourceT $ fileSource fi $$ sinkLbs
            addFile $
                Open
                    (fileName fi)
                    (fileContentType fi)
                    topic
                    hours
                    person
                    created
                    (S.pack . L.unpack $ fileBytes)
        _ -> return ()
    redirect CreateOpeningsR

Ghc reminds us that 'S.pack' and 'L.unpack' come from Data.Bytestring and Data.Bytestring.Lazy, which we

import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L

like so. For 'sinkLbs' https://hoogle.haskell.org/?hoogle=sinkLbs point us to

import Data.Conduit.Binary

from the conduit-extra package what Ghc already knows so quietly we adapt our package.yaml or .cabal file.

Declaring addFile in src/Foundatione.hs like so

addFile :: Open -> Handler ()
addFile file = runDB $ insert_ file

will let our application compile again. The deprecated '$$' warning will be - after looking into here - resolved by using

fileBytes <- runConduit $ fileSource fi .| sinkLbs

instead.

Time for the entry form in templates/createopenings.hamlet

<div .container>
<div .jumbotron>
    <h2>Submit new Opening
    <form method=post action=@{CreateOpeningsR} enctype=#{formEncType}>
        ^{formWidget}
        <input .btn type="submit" value="Upload">
$if null opens
    <p>No files have been uploaded yet.
$else
    <ul>
        $forall (Entity ident (Open filename contentType topic hours person created _)) <- opens
            <li>
                <a href=@{OpeningsR ident}>#{topic} by #{person}

where we make use of 'formWidget and formEncType' and with a deep gut feeling also use of 'opens' and check our upload functionality. Great.

In src/Foundation.hs we should replicate the getList action and declare that clone like so

getLast :: Handler [Entity Open]
getLast = runDB $ selectList [] [Desc OpenCreated, LimitTo 1]

to make use of the 'created' entry by displaying only the newest opening.

Back in src/Handler/Openings.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
module Handler.Openings
    ( getOpeningsR
    , getDisplayR
    ) where    
import Control.Exception hiding (Handler)
import Data.ByteString as SB
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Import hiding (evaluate, try)
getOpeningsR :: Key Open -> Handler Html
getOpeningsR ident = do
    openy <- getLast
    defaultLayout $ do
        setTitle ""
        $(widgetFile "openings")        
getDisplayR :: Key Open -> Handler TypedContent
getDisplayR ident = do
    Open filename contentType topic hours person created content <- getById ident
    addHeader "Content-Disposition" $ Text.concat ["inline;"]
    sendResponse (Text.encodeUtf8 contentType, toContent content)

there are two things to note. 'openy' will represent our openings in templates/openings.hamlet fed by 'DisplayR ident'. See below.

And by checking https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Content-Disposition we learn that we may display an image 'inline' instead of using 'attachment' for downloading the same.

Ghc guides us to implement the 'getById' action in src/Foundation.hs

getById :: Key Open -> Handler Open
getById ident = do
    mfile <- runDB $ get ident
    case mfile of
        Nothing -> notFound
        Just file -> return file

and to modify the config/routes... as

-- 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
/auth   AuthR   Auth   getAuth
/favicon.ico FaviconR GET
/robots.txt RobotsR GET
/ HomeR GET
/profile ProfileR GET POST
/posts/#Slug PostDetailsR GET
/createOpenings CreateOpeningsR GET POST
/createOpenings/#OpenId/display DisplayR GET
!/openings/#OpenId OpeningsR GET
/openings/1 ShowallR GET

where we see directly that unusual, OK let's say somehow hacky way, to solve a routing problem. As I wanted to keep the Menu of the Scaffolding, changing the entry for OpeningsR and the other two new Handlers to

isAuthorized (OpeningsR _) _ = return Authorized
isAuthorized (DisplayR _) _ = return Authorized
isAuthorized ShowallR _ = return Authorized

in src/Foundation.hs, Ghc responds with

/home/ye/cava/web/blog/blogandmore/src/Foundation.hs:142:41: error:
    • Couldn't match expected type ‘Route App’
                  with actual type ‘OpenId -> Route App’
    • In the ‘menuItemRoute’ field of a record
      In the second argument of ‘($)’, namely
        ‘MenuItem
           {menuItemLabel = "Openings", menuItemRoute = OpeningsR,
            menuItemAccessCallback = True}’
      In the expression:
        NavbarRight
          $ MenuItem
              {menuItemLabel = "Openings", menuItemRoute = OpeningsR,
               menuItemAccessCallback = True}
    |
142 |                       , menuItemRoute = OpeningsR
    |                                         ^^^^^^^^^

and I wasn't able to solve this! After a while I decided that ShowallR should work as a placeholder in the Menu and be an empty Handler like so:

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
module Handler.Showall where
import Import
getShowallR :: Handler Html
getShowallR = error "nothing implemented yet"

If you have a solution here, please let me know! I will update the content according to.

In src/Foundation.hs we change the MenuItem to

, NavbarRight $
  MenuItem
      { menuItemLabel = "Openings"
      , menuItemRoute = ShowallR
      , menuItemAccessCallback = True
      }

fill templates/openings.hamlet with something like

<h2>All Creatures Welcome
<div .pic>
    $forall (Entity ident (Open filename contentType topic hours person created _)) <- openy
        <img src=@{DisplayR ident}>
        <h4>
            <ul>
                <li>
                    what: #{topic}
                <li>
                    when: #{hours}
                <li>
                    yourhost: #{person}
<div #mapid>
<h6>This is an OpenStreetMap, implemented with leaflet.

add

Handler.Showall

to blogandmore.cabal and as 'import' to src/Application.hs.

Oho! Well done! By uploading the first content, we may notice that there is still some room for beautify things.

I am a big fan of a decentralized web, or better, I think it is neccessary to care about it in a direct, tangible way - so let's put the open source solution first.

For to implement a Osm map download the latest stable release from here: https://leafletjs.com/download.html unpack it and move 'leaflet.css' the 'images' folder and 'leaflet.js' to the corresponding folder in static. Note that 'images' ought to be a subfolder of static/css.

The 'pc <- widgetToPageContent' section of our src/Foundation.hs we should declare

addStylesheet $ StaticR css_leaflet_css
addScript $ StaticR js_leaflet_js

In templates/openings.julius for a simple map we might enter something like

var mymap = L.map('mapid').setView([41.91123, 12.50153], 14);
L.tileLayer('https://{s}.tile.openstreetmap.org/{z}/{x}/{y}.png', {
    attribution: '&copy; <a href="https://www.openstreetmap.org/copyright">OpenStreetMap</a>  contributors'
}).addTo(mymap);
var marker = L.marker([41.91123, 12.50153]).addTo(mymap)
    .bindPopup('HackToDay')
    .openPopup();

give the '#mapid' some height in templates/openings.lucius and remember that we have already inserted '#mapid' in our .hamlet file.

We may have to

touch src/Settings/StaticFiles.hs

and

stack build

to make Yesod know of the new files.

I use a Google map in another project, which I made a while ago, like so:

Create a Widget in src/Foundation.hs

addMapAPI :: Widget
addMapAPI = addScriptRemote "https://maps.google.com/maps/api/js?key=YourKey"

at the very end of that file. In src/Application.hs add it to the Application module.

...
, addMapAPI
...

insert this javascript

var map;
function initialize() {
  var mapOptions = {
    zoom: 16,
    center: new google.maps.LatLng(41.91123, 12.50153),
     mapTypeId: google.maps.MapTypeId.HYBRID,
          labels:true
  };
        var map = new google.maps.Map(document.getElementById('map_canvas'),
            mapOptions);            
        var marker = new google.maps.Marker({
          position: map.getCenter(),
          map: map,
          title: 'Click to zoom'
        });        
        google.maps.event.addListener(marker, 'click', function() {
          if (map.getZoom() == 16) {
            map.setZoom(8);
          } else {
            map.setZoom(16);
          }
        });        
  var infowindow = new google.maps.InfoWindow({ 
  content: 'HackToDay',
        size: new google.maps.Size(30,30),
        position: myLatlng,
  });
  infowindow.open(map)  
  map = new google.maps.Map(document.getElementById('map_canvas'), mapOptions);
}
google.maps.event.addDomListener(window, 'load', initialize);

in templates/openings.julius and write some wrapper div in templates/openings.hamlet.

Note: this is working for an old project, but may not fit to Googles actual politics/requirements.

By running

stack build

you may be bold red getting something like

-- WARNING: GHCi does not notice changes made to your template files.
-- If you change a template, you'll need to either exit GHCi and reload,
-- or manually @touch@ another Haskell module.’
  |
9 | -- $ stack ghci blogandmore:lib --no-load --work-dir .stack-work-devel
  | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^...

which can be suppressed by putting the whole comment section in the beginning of the file in curly brackets. It describes a faster way (inside Ghci) of reloading your code.

I prefer to have the template files checked also, so I stay with 'yesod devel'.

On some Linux systems (here Debian 10), by running 'yesod devel' you might get an

no space left on device - error

which can be solved with

sudo sysctl fs.inotify.max_user_watches=1048576

For diving deeper into that topic: https://unix.stackexchange.com/questions/444998/how-to-set-and-understand-fs-notify-max-user-watches

Sources are on https://git.onepigayear.de/ye/blogandmore.git where 'workbench' is not merged into 'master' so the difference this article make is trace- and compareable to your own doing.

Thanks for reading so far. The next post will handle multi user authorization with Auth.HashDB.