restman-0.7.1.1: src/Lib.hs

{-# language OverloadedStrings #-}
{-# language RecordWildCards #-}
{-|
Description: RESTman as a library

For the data inclined, I recommend starting with 'AppS', which is all the internal RESTman state.
For the logic inclined, I recommen starting with 'handleEvent', which is the main way the state is
manipulated over time.  The application handles command-line parsing and then calls into
'someFunc', which we never renamed from the stack template at it is responsible for building the
record of function required for a Bick application, also a reasonable starting place.
-}
module Lib
    ( chooseCursor
    , draw
    , focusRing
    , growWith
    , handleEvent
    , doRequest
    , defaultHeadersEditorName
    , responseBodyViewportName
    ) where

-- base
import Data.Foldable (for_)
import Data.List (nub)
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Void (Void, absurd)

-- bytestring
import Data.ByteString.Lazy (toStrict)
import qualified Data.ByteString.Lazy as LBS

-- brick
import Brick.Focus
  ( FocusRing
  , focusGetCurrent
  , focusNext
  , focusPrev
  , focusRing
  , focusRingCursor
  , withFocusRing
  )
import Brick.Main
  ( hScrollBy
  , halt
  , lookupExtent
  , showCursorNamed
  , suspendAndResume
  , vScrollBy
  , vScrollPage
  , viewportScroll
  )
import Brick.Types
  ( BrickEvent(AppEvent, MouseDown, MouseUp, VtyEvent)
  , CursorLocation
  , Direction(Down, Up)
  , EventM
  , Extent
  , HScrollBarOrientation(OnBottom)
  , VScrollBarOrientation(OnRight)
  , ViewportType(Both)
  , Widget(render)
  , extentSize
  , extentUpperLeft
  , imageL
  , nestEventM
  )
import Brick.Widgets.Border (borderWithLabel)
import qualified Brick.Widgets.Border.Style as BS
import Brick.Widgets.Core
  ( fill
  , getName
  , hBox
  , hLimit
  , padLeftRight
  , raw
  , reportExtent
  , str
  , textWidth
  , translateBy
  , txt
  , vBox
  , vLimit
  , vLimitPercent
  , viewport
  , withBorderStyle
  , withHScrollBars
  , withVScrollBars
  )
import Brick.Widgets.Edit
  (Editor, editContentsL, handleEditorEvent, renderEditor)
import Brick.Widgets.List
  ( List
  , handleListEvent
  , listElements
  , listItemHeight
  , listSelectedElement
  , listSelectedL
  , renderList
  )
import qualified Brick.Widgets.List as BrickList
import Brick.Widgets.Table (renderTable, rowBorders, surroundingBorder, table)

-- case-insensitive
import Data.CaseInsensitive (original)

-- containers
import qualified Data.Map as Map

-- lens
import Control.Lens
  (ALens', _Just, cloneLens, set, view, (%=), (%~), (&), (.~), (^?))

-- microlens-mtl
import Lens.Micro.Mtl (zoom)

-- mime-types
import Network.Mime (defaultExtensionMap)

-- mtl
import Control.Monad.State.Class (get, gets, modify, put)

-- skylighting
import Skylighting
  ( Syntax
  , TokenizerConfig(TokenizerConfig)
  , defaultFormatOpts
  , defaultSyntaxMap
  , lookupSyntax
  , pygments
  , tokenize
  )

-- text
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Text.Encoding (decodeUtf8With, encodeUtf8)
import Data.Text.Encoding.Error (lenientDecode)
import qualified Data.Text.Lazy as LText

-- text-zipper
import Data.Text.Zipper (getText, stringZipper)

-- unliftio
import UnliftIO.Exception (tryAnyDeep)

-- vector
import qualified Data.Vector as Vector

-- wreq
import qualified Network.Wreq as W

-- vty
import Graphics.Vty.Attributes (Attr, currentAttr, reverseVideo, withStyle)
import qualified Graphics.Vty.Attributes as VA
import Graphics.Vty.Image
  ( Image
  , charFill
  , imageHeight
  , imageWidth
  , text'
  , utf8Bytestring'
  , vertCat
  , (<->)
  , (<|>)
  )
import qualified Graphics.Vty.Image as VI
import Graphics.Vty.Input.Events
  ( Button(BScrollDown, BScrollUp)
  , Event(EvKey, EvMouseDown)
  , Key(KBackTab, KChar, KDown, KEnter, KEsc, KLeft, KPageDown, KPageUp, KRight, KUp)
  , Modifier(MCtrl, MShift)
  )

-- local libs
import HTTP.Client
  ( Header
  , Method
  , customMethodWith
  , customPayloadMethodWith
  , defaults
  , headers
  , knownMethods
  , responseBody
  , responseHeader
  )

import Skylighting.Format.Vty (formatVty)
import Types
  (AppS(..), OverlayS(..), RangeInAlign(..), VertAlign, WideAlign, left, top)

-- | Second argument must be positive.
splitExtraSpace :: RangeInAlign -> Int -> (Int, Int)
splitExtraSpace Min n = (0, n)
splitExtraSpace MidL n = let (q, r) = n `divMod` 2 in (q, q + r)
splitExtraSpace MidG n = let (q, r) = n `divMod` 2 in (q + r, q)
splitExtraSpace Max n = (n, 0)

{-|
Grows an image to a minimum size by padding it, with original images being aligned as specified
within the larger image.
-}
growWith
  :: (Int -> Int -> Image) -- ^ How to generate wide by vert padding image
  -> Int -- ^ minimum width
  -> WideAlign -- ^ width-wise ("horizontal") alignment
  -> Int -- ^ minimum vert ("height")
  -> VertAlign -- ^ vertical alignment
  -> Image -- ^ original, small image
  -> Image -- ^ resulting, grown image
growWith fillImage w wa v va img = vertCat
  [ fillImage width topPad
  , fillImage leftPad vi <|> img <|> fillImage rightPad vi
  , fillImage width bottomPad
  ]
 where
  vi = imageHeight img
  vPad = max 0 (v - vi)
  (topPad, bottomPad) = splitExtraSpace va vPad
  wi = imageWidth img
  width = max w wi
  wPad = width - wi
  (leftPad, rightPad) = splitExtraSpace wa wPad

{- Export?
growTransparent :: Int -> WideAlign -> Int -> VertAlign -> Image -> Image
growTransparent = growWith backgroundFill
-}

-- | See 'growWith', this one uses ASCII SPC @' '@ to fill the padding.
growSpaces :: Int -> WideAlign -> Int -> VertAlign -> Image -> Image
growSpaces = growWith (charFill currentAttr ' ')

-- | Update a widget by changing the final render and no other properties (almost a lens)
postprocessImage :: (Image -> Image) -> Widget n -> Widget n
postprocessImage process widget = widget{render = (imageL %~ process) <$> render widget}

-- | Lens, focus tracking from app state.
focusL :: Functor f => (FocusRing Text -> f (FocusRing Text)) -> AppS -> f AppS
focusL embed s = (\newFocus -> s{focus = newFocus}) <$> embed (focus s)

-- | Lens, method text entry from app state.
methodEditorL :: Functor f => (Editor Method Text -> f (Editor Method Text)) -> AppS -> f AppS
methodEditorL embed s = (\newMethodEditor -> s{methodEditor = newMethodEditor}) <$> embed (methodEditor s)

-- | Lens, method in text entry.
methodL :: Functor f => (Method -> f Method) -> AppS -> f AppS
methodL = methodEditorL . editContentsL . methodInEditorContentsL
 where
  methodInEditorContentsL embed tz = (\newMethod -> stringZipper [newMethod] (Just 1)) <$> embed (concat $ getText tz)

-- | Lens, optional overlay in app state
overlayStateL :: Functor f => (Maybe OverlayS -> f (Maybe OverlayS)) -> AppS -> f AppS
overlayStateL embed s = (\newOverlay -> s{overlayState = newOverlay}) <$> embed (overlayState s)

-- | Lens, location of pop-up in overlay state
methodEditorExtentL :: Functor f => (Extent Text -> f (Extent Text)) -> OverlayS -> f OverlayS
methodEditorExtentL embed os = (\newExtent -> os{methodEditorExtent = newExtent}) <$> embed (methodEditorExtent os)

-- | Lens, method selector in overlay state
methodListL :: Functor f => (List Text Method -> f (List Text Method)) -> OverlayS -> f OverlayS
methodListL embed os = (\newList -> os{methodList = newList}) <$> embed (methodList os)

-- | Lens, URL text entry in app state
urlEditorL :: Functor f => (Editor String Text -> f (Editor String Text)) -> AppS -> f AppS
urlEditorL embed s = (\newUrlEditor -> s{urlEditor = newUrlEditor}) <$> embed (urlEditor s)

useDefaultHeadersL :: Functor f => (Bool -> f Bool) -> AppS -> f AppS
useDefaultHeadersL embed s =
  (\newUse -> s{useDefaultHeaders = newUse}) <$> embed (useDefaultHeaders s)

-- | Extent name.  Emitted by main UI, used to construct overlay state
methodEditorExtentName :: Text
methodEditorExtentName = "methodEditorExtent"

{-|
Like 'borderWithLabel' but grows the image of the inner widget so the whole label is always
visible.
-}
textLabeledBorder ::  Text -> Widget n -> Widget n
textLabeledBorder label inner =
  borderWithLabel (txt label) (postprocessImage (growSpaces (textWidth label) left 0 top) inner)

-- | Like 'textLabeledBorder' but allows attributes to be applied to the label.
textAttrLabeledBorder :: Text -> Attr -> Widget n -> Widget n
textAttrLabeledBorder label attr inner =
  borderWithLabel
    (raw $ text' attr label)
    (postprocessImage (growSpaces (textWidth label) left 0 top) inner)

-- | Area between main menu and main content area
mainMenuSeparator :: Widget n
mainMenuSeparator = vLimit 1 $ fill '='

-- | Non-functional top menu bar
mainMenu :: Widget n
mainMenu = hBox $ map (padLeftRight 2 . txt) [ "Headers", "Response Tools", "\x2026" ]


{- Widget names -}
defaultHeadersEditorName :: Text
defaultHeadersEditorName = "defaultHeadersEditor"

responseBodyViewportName :: Text
responseBodyViewportName = "responseBodyViewport"

{-|
Render.

Widget names are all 'Text'.

URL editor and label, then last response body at the top of the available space.  No other widgets
or layers.
-}
draw :: AppS -> [Widget Text]
draw AppS{..} =
  [ drawOverlay os | Just os <- [overlayState] ]
  ++
  [ vBox $
    [ mainMenu
    , mainMenuSeparator
    , hBox
      [ reportExtent methodEditorExtentName $ textLabeledBorder "Method" methodWidget
      , textLabeledBorder "URL to Query?" urlWidget
      ]
    , if useDefaultHeaders
       then
        textAttrLabeledBorder
          "[X] Use Default Headers"
          defaultHeadersAttr
          (headersWidget defaultHeaders)
       else raw $ text' defaultHeadersAttr " [ ] Use Default Headers"
    ]
    ++
    [ textLabeledBorder "Custom Headers" (headersWidget customHeaders) | not $ null customHeaders ]
    ++
    [ focusedBorder
      . textLabeledBorder "Response Body"
      . withVScrollBars OnRight
      . withHScrollBars OnBottom
      . viewport responseBodyViewportName Both
      $ raw vtySafeResponse
    ]
  ] -- layers top to bottom
 where
  focusDefaultHeaders = focusGetCurrent focus == Just defaultHeadersEditorName
  focusedResponseBody = focusGetCurrent focus == Just responseBodyViewportName
  focusedBorder = if focusedResponseBody then withBorderStyle BS.unicodeBold else id
  defaultHeadersAttr =
    if focusDefaultHeaders then currentAttr `withStyle` reverseVideo else currentAttr
  defaultHeaders = view headers defaults
  responseImage = lastResponse
  vtySafeResponse = responseImage
  editorWidget = withFocusRing focus (renderEditor (vBox . map str))
  urlWidget = editorWidget urlEditor
  methodWidget = hLimit 18 $ hBox [editorWidget methodEditor, str "\x25BC"]

headersWidget :: [Header] -> Widget n
headersWidget = renderTable . surroundingBorder False . rowBorders False . table . map headerRow
 where
  headerRow (n, v) =
    [raw . utf8Bytestring' currentAttr $ original n, raw $ utf8Bytestring' currentAttr v]

-- | When the overlay is present, what are the widget to draw on that layer.
drawOverlay :: OverlayS -> Widget Text
drawOverlay OverlayS{..} =
  translateBy transLoc . hLimit w . textLabeledBorder "Method (Select)" $ methodSelectWidget
 where
  methodSelectWidget = vLimitPercent 50 . vLimit mv $ renderList (const str) True methodList
  w = fst $ extentSize methodEditorExtent
  transLoc = extentUpperLeft methodEditorExtent
  mv = Vector.length (listElements methodList) * listItemHeight methodList

-- | Where to place the cursor?  If overlay present, no cursor.  Otherwise determined by 'focus'
chooseCursor :: AppS -> [CursorLocation Text] -> Maybe (CursorLocation Text)
chooseCursor s =
  case overlayState s of
   Nothing -> focusRingCursor focus s
   Just os -> showCursorNamed (getName $ methodList os)

-- | App state change on [Tab] to advace the focus.
moveFocusNext :: AppS -> AppS
moveFocusNext = focusL %~ focusNext

-- | App state change on [S+Tab] to recede the focus
moveFocusPrev :: AppS -> AppS
moveFocusPrev = focusL %~ focusPrev

{-|
State update in response to event.

Widget names are all 'Text'.  No application specific events, so event type is 'Void'.

Global events handled here:
 * [Esc] (with any or no modifiers) and Ctrl+q (with any or no other modifiers) halts.
 * No application events are expected.
 * Mouse events are ignored.

Other Vty events are passed to 'handleEventLocal'.
-}
handleEvent :: BrickEvent Text Void -> EventM Text AppS ()
handleEvent (VtyEvent (EvKey KEsc _)) = halt -- global: [ESC]: exit cleanly
handleEvent (VtyEvent e@(EvKey (KChar 'q') mods)) = -- global Ctrl+q: exit cleanly
  if MCtrl `elem` mods
   then halt
   else handleEventLocal e
handleEvent (VtyEvent e) = handleEventLocal e
handleEvent (AppEvent bottom) = absurd bottom -- can't happen
handleEvent MouseDown{} = pure () -- ignore
handleEvent MouseUp{} = pure () -- ignore

{-|
If the overlay is deing displayed, defer to 'handleEventOverlay'.  Otherwise, defer to
'handleEventMain'.  "Global" events should already have been handled in 'handleEvent'.
-}
handleEventLocal :: Event -> EventM Text AppS ()
handleEventLocal e = do
  mos <- gets overlayState
  -- switch to different behavior based on overlay
  case mos of
   Nothing -> handleEventMain e
   Just os -> handleEventOverlay os e

{-|
Events for the main UI:
 * [Enter] causes the application to 'doRequest'
 * [Tab] causes 'moveFocusNext', [S+Tab] causes 'moveFocusPrev'.
 * [BackTab] casues 'moveFocusPrev', [S+BackTab] causes 'moveFocusNext'.
 * [Down] on the method text entry causes pop-up display; if focus is elsewhere it is ignored.
 * [Space] on the default headers editor toggles the setting.
 * If an editor is focused, other events update it.
-}
handleEventMain :: Event -> EventM Text AppS ()
handleEventMain (EvKey KEnter _) = get >>= suspendAndResume . doRequest
handleEventMain (EvKey (KChar '\t') mods) = -- change focus
  modify $ if MShift `elem` mods
    then moveFocusPrev
    else moveFocusNext
handleEventMain (EvKey KBackTab mods) = -- change focus
  modify $ if MShift `elem` mods
    then moveFocusNext
    else moveFocusPrev
handleEventMain evt = do -- Depends on focus
  s <- get
  case focusGetCurrent (focus s) of
    Nothing -> pure ()
    Just nm | nm == getName (urlEditor s) -> handleEditorLEvent urlEditorL evt
    Just nm | nm == getName (methodEditor s) -> handleMethodEditorEvent evt
    Just nm | nm == defaultHeadersEditorName -> handleDefaultHeadersEditorEvent evt
    Just nm | nm == responseBodyViewportName -> handleResponseBodyViewportEvent evt
    Just _u -> pure () -- unknown focus (log?)

-- | Pass event into 'handleEditorEvent', when not handled more specifically.
handleEditorLEvent :: ALens' AppS (Editor String Text) -> Event -> EventM Text AppS ()
handleEditorLEvent editorL evt = zoom (cloneLens editorL) (handleEditorEvent $ VtyEvent evt)

-- | Handle event when focus is on the method editor and will not change.
-- [Down] opens the method selector overlay.
-- Other events are passed to 'handleEditorLEvent'.
handleMethodEditorEvent :: Event -> EventM Text AppS ()
handleMethodEditorEvent (EvKey KDown _mods) = do
  s <- get
  let
    enteredMethod = view methodL s
    listContents = Vector.fromList . nub $ enteredMethod : knownMethods
  mMethodEditorExtent <- lookupExtent methodEditorExtentName
  for_ mMethodEditorExtent $ \methodEditorExtent ->
    let
      initialListState = set listSelectedL (Just 0) $ BrickList.list "methodSelector" listContents 1
      overlay = OverlayS
        { methodList = initialListState
        , methodEditorExtent = methodEditorExtent
        }
    in put s{overlayState = Just overlay}
handleMethodEditorEvent evt = handleEditorLEvent methodEditorL evt

-- | Handle event when focus is on response body viewport and will not change.
-- * [Down] or 'j': line scroll down
-- * [Up] or 'k': line scroll up
-- * [Right] or 'l': column scroll right
-- * [Left] or 'h': column scroll left
-- * [PgDn]: page scroll down
-- * [PgUp]: page scroll up
-- * <ScrollUp>: 3 line scroll up
-- * <ScrollDown>: 3 line scroll down
handleResponseBodyViewportEvent :: Event -> EventM Text AppS ()
handleResponseBodyViewportEvent evt =
  case evt of
    EvKey k _mods ->
      case k of
        KDown -> vScrollBy vps 1
        KChar 'j' -> vScrollBy vps 1
        KUp -> vScrollBy vps (-1)
        KChar 'k' -> vScrollBy vps (-1)
        KRight -> hScrollBy vps 1
        KChar 'l' -> hScrollBy vps 1
        KLeft -> hScrollBy vps (-1)
        KChar 'h' -> hScrollBy vps (-1)
        KPageDown -> vScrollPage vps Down
        KPageUp -> vScrollPage vps Up
        _ -> pure () -- ignored
    EvMouseDown _x _y b _mods ->
      case b of
        BScrollUp -> vScrollBy vps (-3)
        BScrollDown -> vScrollBy vps 3
        _ -> pure () -- ignored
    _ -> pure () -- ignored
 where
  vps = viewportScroll responseBodyViewportName

-- | Handle event when focus in on default headers editor and will not change.
handleDefaultHeadersEditorEvent :: Event -> EventM Text AppS ()
handleDefaultHeadersEditorEvent (EvKey (KChar ' ') _) = useDefaultHeadersL %= not
handleDefaultHeadersEditorEvent _ = pure ()

-- | Retrieve extent emitted during last draw and update overlay state.
updateExtent :: EventM Text OverlayS ()
updateExtent = do
  mExtent <- lookupExtent methodEditorExtentName
  for_ mExtent $ \extent ->
   modify $ set methodEditorExtentL extent

{-|
Events for the overlay:
 * [Enter] closes the overlay taking the selected method and updating the application state.
 * Other events are sent to the method selection list.

All code paths should 'updateExtent', in case the pop-up needs to move.
-}
handleEventOverlay :: OverlayS -> Event -> EventM Text AppS ()
handleEventOverlay currentOverlay (EvKey KEnter _) = do -- pick selected method, remove popup
  mSelectedMethod <- fmap snd . nestEventM currentOverlay $ do
    updateExtent
    gets $ fmap snd . listSelectedElement . methodList
  for_ mSelectedMethod $ \method ->
    modify $ set methodL method . set overlayStateL Nothing
handleEventOverlay _currentOverlay e = zoom (overlayStateL . _Just) $ do -- defer to list
    updateExtent
    zoom methodListL (handleListEvent e)

{-|
Construct and issue a wreq request from the application state, handle request failures that are
raised as exceptions in IO, updating the application state ('lastResponse') either from the
response or the execption.
-}
doRequest :: AppS -> IO AppS
doRequest s = do
  result <- tryAnyDeep $ do
    let opts = W.defaults & (W.manager .~ Right (connManager s))
    response <- httpRequest opts . concat . getText . view editContentsL $ urlEditor s
    pure $ syntaxHighlightResponse (pure $ view responseBody response) (responseContentType response)
  pure s{ lastResponse = either exResponse id result }
 where
  updateHeaders AppS{..} = if useDefaultHeaders then (++ customHeaders) else const customHeaders
  httpMethod AppS{..} = concat . getText $ view editContentsL methodEditor
  httpOptions = headers %~ updateHeaders s
  httpRequest opts =
    case payload s of
     Nothing -> customMethodWith (httpMethod s) (httpOptions opts)
     Just lbs -> \url -> customPayloadMethodWith (httpMethod s) (httpOptions opts) url lbs
  exResponse ex = VI.text (VA.Attr VA.Default VA.Default VA.Default VA.Default) $ "[Exception: " <> LText.pack (show ex) <> "]"
  responseContentType resp = fmap LBS.fromStrict $ resp ^? responseHeader "Content-Type"

{- Incoming ByteString for payload has not been pruned of invalid chacaters nor been tab expanded.

   - These operations are required to be compatible with Vty's text rendering. The require removing
   paticular characters like escape, tab, vertical tab, and new lines. The newslines are dealt with as part of the
   -}
syntaxHighlightResponse :: Maybe LBS.ByteString -> Maybe LBS.ByteString -> Image
syntaxHighlightResponse Nothing _ = VI.text (VA.Attr VA.Default VA.Default VA.Default VA.Default) "-- No response body --\n"
syntaxHighlightResponse (Just payload) Nothing = noSyntaxFound $ cleanPayload payload
syntaxHighlightResponse (Just payload) (Just contentType) = case syntaxFromExtension of
  (syn:_) -> highlighted syn $ cleanPayload payload
  [] -> noSyntaxFound $ cleanPayload payload
 where
  syntaxFromExtension = mapMaybe (`lookupSyntax` defaultSyntaxMap) contentTypeToExtensionList
  contentTypeToExtensionList = fromMaybe [] $ Map.lookup mimeType defaultExtensionMap
  mimeType = encodeUtf8 $ Text.takeWhile (/= ';') $ lbsToText contentType


cleanPayload :: LBS.ByteString -> Text
cleanPayload = expandTabs . cleanText
  where
    cleanText = Text.filter (`notElem` ['\ESC', '\v']) . lbsToText
    expandTabs = Text.replace "\t" "    "

highlighted :: Syntax -> Text -> Image
highlighted s t = case tokenize (TokenizerConfig defaultSyntaxMap False) s t of
  Left err -> foldr ((<->) . VI.text (VA.Attr VA.Default VA.Default VA.Default VA.Default))
    VI.emptyImage
    ["-- Syntax highlighting error: ", LText.pack err, " --" , LText.fromStrict t]
  Right sourceLines -> formatVty defaultFormatOpts pygments sourceLines

noSyntaxFound :: Text -> Image
noSyntaxFound payload = foldr
    ((<->) . VI.text (VA.Attr VA.Default VA.Default VA.Default VA.Default))
    VI.emptyImage
    ("--Uknown Body Type --" : map LText.fromStrict (Text.lines payload))

-- Helper function to convert a lazy ByteString to Text in UTF-8 encoding
lbsToText :: LBS.ByteString -> Text
lbsToText = decodeUtf8With lenientDecode . toStrict