passhte.lhs

---
title:  passhte  
author: David Baynard  
date:   22 May 2017  
fontfamily:   libertine
csl:    chemical-engineering-science.csl
link-citations: true
abstract: |  
    Paste over ssh
...

This library works around weird hterm issues.

1.  Run this server.
2.  Forward port over ssh.
3.  Point to forwarded port with browser.
4.  Paste text in form and, hit submit.
5.  Paste from system clipboard, on the other side of the ssh tunnel.

```haskell
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE AllowAmbiguousTypes #-}

import "base" Control.Applicative
import "base" Control.Monad
import "base" Control.Monad.IO.Class
import "base" Data.Proxy
import "mmorph" Control.Monad.Morph
import "text" Data.Text (Text)
import qualified "text" Data.Text as T
import "tagged" Data.Tagged
import "base" GHC.TypeLits

import "Hclip" System.Hclip

import "servant-server" Servant
import "servant-lucid" Servant.HTML.Lucid

import "digestive-functors" Text.Digestive
import "digestive-functors-lucid" Text.Digestive.Lucid.Html5 (ifSingleton)

import "lucid" Lucid

import "warp" Network.Wai.Handler.Warp
```

```{.haskell . ignore}
import "wai-extra" Network.Wai.Middleware.RequestLogger
```

```haskell
import "http-api-data" Web.FormUrlEncoded (FromForm, ToForm)
import qualified "http-api-data" Web.FormUrlEncoded as W

import "optparse-generic" Options.Generic

instance forall s . KnownSymbol s => ToForm (Tagged (s :: Symbol) Text) where
    toForm = W.toForm . pure @[] . (T.pack $ symbolVal @s Proxy,) . untag
instance forall s . KnownSymbol s => FromForm (Tagged (s :: Symbol) Text) where
    fromForm = fmap Tagged . W.parseUnique (T.pack $ symbolVal @s Proxy)

main :: IO ()
main = do
        port <- getRecord "Accept text to clipboard over server."
        run port $ Proxy @API `serve` server

data Page = Clipboard

type API
    = Get '[HTML] Page
    :<|> ReqBody '[FormUrlEncoded] ("clipboard" `Tagged` Text) :> Post '[HTML] Page

server :: Server API
server = pure Clipboard :<|> writeClipboard

writeClipboard :: "clipboard" `Tagged` Text -> Handler Page
writeClipboard = (fmap . const $ Clipboard) . liftIO . setClipboard . T.unpack . untag @"clipboard"

instance ToHtml Page where
    toHtml Clipboard = clipboard
    toHtmlRaw = toHtml

clipboard :: Monad m => HtmlT m ()
clipboard = do
        head_ $ do
            title_ "Clipboard paster"
        body_ $ do
            unwrap $ theForm <$> getForm "clipboard" makeForm

makeForm :: Monad m => Form (HtmlT m ()) m Text
makeForm = "clipboard" .: text Nothing

theForm :: Monad m => View (HtmlT m ()) -> HtmlT m ()
theForm v = form v "" $ do
        inputTextArea Nothing Nothing "clipboard" v
        inputSubmit @"POST" "" "Copy to clipboard"
```

# Making up for deficiencies of `digestive-functors`

```haskell
form
    :: forall m html .
       ( Monad m
       , html ~ HtmlT m ()
       )
    => View html
    -> Text
    -> html
    -> html
form view action = form_
    [ method_  "POST"
    , enctype_ (T.pack . show $ viewEncType view)
    , action_  action
    ]

inputTextArea
    ::  Monad m
    => Maybe Int         -- ^ Rows
    -> Maybe Int         -- ^ Columns
    -> Text              -- ^ Form path
    -> View (HtmlT m ()) -- ^ View
    -> HtmlT m ()        -- ^ Resulting HTML
inputTextArea r c ref view = textarea_
    ([ id_     ref
     , name_   ref
     ] ++ rows' r ++ cols' c) $
        toHtmlRaw $ fieldInputText ref view
  where
    rows' (Just x) = [rows_ . T.pack . show $ x]
    rows' _        = []
    cols' (Just x) = [cols_ . T.pack . show $ x]
    cols' _        = []


inputText :: Monad m => Text -> View v -> HtmlT m ()
inputText ref view = input_
    [ type_    "text"
    , id_      ref
    , name_    ref
    , value_ $ fieldInputText ref view
    ]
```

We need a better radio input rendering.

```haskell
inputRadio
    :: (Monad m, html ~ HtmlT m ()) => Text -> View html -> html
inputRadio ref view = do
        forM_ choices $ \(val, c, sel) -> do
            section_ [ class_ "radio item" ] $ do
                input_ $ [type_ "radio", value_ val, id_ val, name_ ref]
                           ++ ifSingleton sel checked_
                label_ [for_ val] c
    where
        choices = fieldInputChoice ref view

inputHidden :: Monad m => Text -> View v -> HtmlT m ()
inputHidden ref view = input_
    [ type_    "hidden"
    , id_      ref
    , name_    ref
    , value_ $ fieldInputText ref view
    ]

inputSelect :: Monad m => Text -> View (HtmlT m ()) -> HtmlT m ()
inputSelect ref view = select_
    [ id_   ref
    , name_ ref
    ] $ forM_ choices $ \(val, c, sel) -> option_
          (value_ val : ifSingleton sel (selected_ "selected")) c
  where
    choices = fieldInputChoice ref view

inputSubmit :: forall s m . (KnownSymbol s, Monad m) => Text -> HtmlT m () -> HtmlT m ()
inputSubmit action = button_
    [ type_  "submit"
    , class_ "submit"
    , name_  "_method"
    , value_ . T.pack $ symbolVal @s Proxy
    , formaction_ action
    ]

```

Unwrap a layer of not quite lifted Monad.

```haskell
unwrap :: (MonadTrans t, Monad m, Monad (t m)) => m (t m a) -> t m a
unwrap = join . lift
```