Validated Hamlet Textarea Form Field

Here is my custom textarea field that validates correct hamlet content

in the Form:
...
  (hamletHtmlResult, hamletHtmlView) <- mreq validatedHamletTextareaField
...

the field:

validatedHamletTextareaField :: Field (HandlerFor App) Textarea
validatedHamletTextareaField = checkM isValidHamlet textareaField
  where
    isValidHamlet :: Textarea -> Handler (Either AppMessage Textarea)
    isValidHamlet textarea@(Textarea text) = do
      eitherParsedTemplate <- tryParse text
      return $
        case eitherParsedTemplate of
          Left _ -> Left MsgGlobalInvalidHamlet
          Right _ -> Right $ Textarea text
      where
        tryParse :: Text -> Handler (Either SomeException HamletTemplate)
        tryParse text = try $ parseHamletTemplate defaultHamletSettings $ unpack text

NixOS haskell infrastructure setup

User's Guide to the Haskell Infrastructure
Haskell/Yesod from scratch with Nix on Mac OS X

haskell LDAP TLS

import Ldap.Client as Ldap
import qualified Ldap.Client.Bind as Ldap

ldapTest :: App -> IO Text
ldapTest app = do
  let ldapHost = .....
  let ldapPort = .....
  let ldapBindDn = .....
  let ldapBindPassword = .....
  let tlsSettings = if .....
                    then Ldap.defaultTlsSettings
                    else Ldap.insecureTlsSettings
  res <- Ldap.with (Ldap.Tls ldapHost tlsSettings) (fromInteger ldapPort) $ \l -> do
    Ldap.bind l
      (Dn ldapBindDn)
      (Password $ encodeUtf8 ldapBindPassword)
    Ldap.search l
      (Dn "dc=.....")
      (typesOnly False)
      (And [ Attr "objectCategory" := "Person"
           , Attr "objectClass" := "user"
           , Attr "sAMAccountName" := encodeUtf8 "xyzuser"
           ])
      []
  case res of
    Left  e -> return $ pack $ "ERROR: " ++ show e
    Right t -> return $ pack $ "OK: " ++ show t

haskell package release

https://taylor.fausak.me/2016/12/05/haskell-package-checklist/
https://functor.tokyo/blog/2018-07-16-release-haskell-packages-to-hackage

transfer github repo and change committers email

mixture of these:

https://help.github.com/articles/importing-a-git-repository-using-the-command-line/
https://help.github.com/articles/changing-author-info/#platform-linux/



1. clone the old repo with bare

git clone --bare https://external-host.com/extuser/repo.git foo
cd foo

2. use this github script

https://help.github.com/articles/changing-author-info/#platform-linux
and change the variables

3. create a new github repo

4. push to the new repo

git push --mirror https://github.com/ghuser/repo.git

CommandBuilder-Monad as EDSL (sort of WriterMonad)

{-# LANGUAGE OverloadedStrings #-}
module Main where

import Control.Applicative
import Control.Monad
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.List as L

main :: IO ()
main = do
  putStrLn "build actions"
  let actions = do
        fooAction
        barAction "aaa"
        barAction "bbb"
        do
          fooAction
          barAction "ccc"
          barAction "ddd"
        fooAction
        barAction "eee"
        barAction "fff"
  putStrLn "execute actions"                                                                                                 
  let results = execute actions
  forM_ results T.putStrLn

fooAction :: Builder
fooAction = build $ Action "foo action"

barAction :: Text -> Builder
barAction text = build $ Action $ T.concat ["bar action (", text, ")"]                                                       


build :: Action -> Builder
build action = BuilderM () [action]

execute :: Builder -> [Text]
execute (BuilderM _ actions) = L.map actionText actions

actionText :: Action -> Text
actionText (Action text) = text

data Action = Action Text
  deriving Show

data BuilderM a = BuilderM a [Action]
  deriving Show

type Builder = BuilderM ()

instance Functor BuilderM where
  fmap = liftM

instance Applicative BuilderM where
  pure  = return
  (<*>) = ap

instance Monad BuilderM where
  return a            = BuilderM a []
  BuilderM a xs >>= f = let BuilderM b ys = f a
                        in  BuilderM b (xs++ys)

$ stack build && stack exec ...                                                       
build actions
execute actions
foo action
bar action (aaa)
bar action (bbb)
foo action
bar action (ccc)
bar action (ddd)
foo action
bar action (eee)
bar action (fff)

Cache GIT password for some time

# Set git to use the credential memory cache
git config --global credential.helper cache

# Set the cache to timeout after 1 hour (setting is in seconds)
git config --global credential.helper 'cache --timeout=3600'

multiple monitors .xsession

xrandr --output HDMI2 --mode 1280x1024
xrandr --output HDMI1 --mode 1920x1080 --right-of HDMI2
xrandr --output DP1 --mode 1680x1050 --right-of HDMI1

xsetroot -solid grey &

cwm

check git project status (only first level)

#!/bin/sh                                                                                                                                                                     

clear
for d in `find . -name .git | sed -e 's|^./||' -e 's|/.git$||' | grep -v '/'`; do
    echo
    cd $d
    echo "================================================="
    pwd
    git pull
    git st
    cd -
done

Adbocker settings with FF Custom Style Script

https://www.wetteronline.de/
#topcontainer,
#premium_webcam,
#contentcontainer > div:first-of-type,
#sidebar > div:nth-of-type(2),
#sidebar > a,
#header,
#video_rotation,
.ticker-widget,
#news_slider,
#content_headline,
iframe
{display: none;}


div.boxContainer, div.pageHeaderLogo, .pageNavigation, .userNotice, ul.messageStatus, div.userRank , .messageSidebar .userAvatar {display: none;}
.pageHeaderFacade > .layoutBoundary {padding-top: 0px; padding-bottom: 0px;}
.main {padding: 20px 0;}


https://www.heise.de
.newsticker-archiv .archiv-liste__item a {border-bottom: .0625rem #c7c7c7;}
.header-main, .aufmacherbild, .ad-container,
.apester-element, #mitte_rechts, .ho .recommendations, .bottom_up,
.buehnenteaser, .akwa-ad-container, .main-footer, .beitragsfooter,
nav.a-nav, span.akwa-article-meta__item.media-icon.media-icon--comments,
div.heisetopnavi.heisetopnavi.v14,
iframe, footer, #vpaid-container
{display: none;}


https://old.reddit.com/r/haskell/
.content .infobar, .organic-listing, .side, div.footer-parent {display: 
none;}


http://www.sueddeutsche.de/
#iqd_mainAd, ul.article-sidebar-wrapper , .teaserable-layout, 
.endofarticle, div.ad.ad_iqadtile16 {display: none;}


http://www.wetter24.de/
aside.span4, header, ul.clearfix, div.span2.mg_box_simple,
div.row.footer_line, div.row.footer_block, header, h2, iframe {display: none;}



https://www.google.com/
div.rc div:nth-child(3), div#resultStats, div#extrares.med, div#footcnt, span.csb {display: none;}

Ways to stream yesod data to the client

model:

Rawdata
  bytes ByteString


way 1:

  addHeader "Content-Disposition" $
    T.concat ["attachment; filename=\"", filename, "\""]
  rawdata <- runDB $ get404 rawdataId                                                                                                                                         
  let bytes = rawdataBytes rawdata                                                                                                                                            
  sendResponse (TE.encodeUtf8 mimetype, toContent bytes)                                                                                                                      


way 2:

  let bytesSource = selectSource [RawdataId ==. rawdataId] []                                                                                                                 
  respondSourceDB (TE.encodeUtf8 mimetype) $ bytesSource $= awaitForever toBuilder'                                                                                           
  where                                                                                                                                                                       
    toBuilder' (Entity _ rawdata) = do                                                                                                                                        
      sendChunkBS $ rawdataBytes rawdata                                                                                                                                      
      sendFlush                                                                                                                                                               


way 3:

  let bytesSource = E.selectSource $ E.from $ \rd -> do
        E.where_ (rd E.^. RawdataId E.==. E.val rawdataId)
        return $ rd E.^. RawdataBytes
  respondSourceDB (TE.encodeUtf8 mimetype) $ bytesSource $= awaitForever toBuilder'
  where
    toBuilder' (E.Value bytes) = do
      sendChunkBS bytes
      sendFlush

put 2 images side by side

montage *.JPG -tile 2x -geometry +0+0 result $(basename `pwd`).jpg

NixOS harddisk partitioning for 18.03

# Write random data to the disk with
dd if=/dev/urandom of=/dev/sda bs=4M status=progress

fdisk -l

fdisk /dev/sda

n
p
1
default
+420G
a

n
p
2
default
+4G
t
2
82  Linux swap

nixos haskell yesod package with overrides

create a new file my-stack-project.nix:

let
  pkgs = import  {};
  pkg = pkgs.haskellPackages.callCabal2nix "my-stack-project" ./. {};
in
  pkgs.haskell.lib.overrideCabal pkg (_: {
    doHaddock = false;
    postInstall = ''
      cp -r ./static $out/bin
      cp -r ./config $out/bin
    '';
  })

nixos haskell package without default.nix

create a new file my-stack-project.nix:

let
  pkgs = import  {};
in
  pkgs.haskellPackages.callCabal2nix "my-stack-project" ./. {}

nixos haskell package with default.nix

generate the default.nix with

cd my-stack-project
cabal2nix . > default.nix

create a new file my-stack-project.nix:

let
  pkgs = import  {};
in
  pkgs.haskellPackages.callPackage ./default.nix {}

sieve forward all mails

require ["envelope"];
if anyof (address :is ["to", "cc"] "info@mydomain.de",
          envelope "to" "info@mydomain.de")
{
    redirect "person1@mydomain.de";
    redirect "person2@mydomain.de";
    discard;
}

BTW quote good examples are here: https://support.tigertech.net/sieve

strato hidrive - no matching cipher found.

in case you get  errors like...

rsync -a myfile user@rsync.hidrive.strato.com:users/user 
Unable to negotiate with 85.214.3.70 port 22: no matching cipher found. Their offer: aes128-cbc,3des-cbc,blowfish-cbc
rsync: connection unexpectedly closed (0 bytes received so far) [sender]
rsync error: error in rsync protocol data stream (code 12) at io.c(226) [sender=3.1.2]

or

scp myfile user@scp.hidrive.strato.com:users/user
Unable to negotiate with 85.214.3.70 port 22: no matching cipher found. Their offer: aes128-cbc,3des-cbc,blowfish-cbc
lost connection

put this into you ~/.ssh/config

host strato-scp
        hostname scp.hidrive.strato.com
        Ciphers aes128-cbc
        MACs hmac-sha1
        KexAlgorithms diffie-hellman-group1-sha1
        HostKeyAlgorithms ssh-rsa
host strato-rsync
        hostname rsync.hidrive.strato.com
        Ciphers aes128-cbc
        MACs hmac-sha1
        KexAlgorithms diffie-hellman-group1-sha1
        HostKeyAlgorithms ssh-rsa

And then connect with

rsync -a myfile user@strato-rsync:users/user
scp myfile user@strato-scp:users/user

haskell set file modes

import System.Posix.Files (setFileMode, groupReadMode)
import System.Directory (getDirectoryContents)

tmpFilePaths <- liftIO $ getDirectoryContents staticDir
forM_ tmpFilePaths (\path -> do
                               liftIO $ setFileMode path groupReadMode
                   )

Yesod embed json in html

getPersonListR :: Handler Html
getPersonListR = do
  urlRender <- getUrlRender
  personEnts <- runDB $ selectList [] [Asc PersonId]
  let jData = map (\(Entity personId person) ->
                      JPerson { jPersonPerson = person
                              , jPersonEditFormUrl = urlRender $ PersonEditFormR personId }
                  ) personEnts
  jsonData <- returnJson jData >>= return . toJsonText
  defaultLayout $ do
    toWidgetBody [julius|var data = #{rawJS jsonData}|]
    $(widgetFile "person_list")

data JPerson = JPerson
  { jPersonPerson :: Person
  , jPersonEditFormUrl :: Text
  }