restman-0.7.2.2: 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
    , cleanPayload
    , draw
    , focusAttr
    , focusStyle
    , growWith
    , handleEvent
    , doRequest
    , lbsToText
    , moveFocusNext
    , moveFocusPrev
    , noSyntaxFound
    , splitExtraSpace
    , syntaxHighlightResponse
    ) where

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

-- brick
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)
  , Result(image)
  , Size(Fixed)
  , VScrollBarOrientation(OnRight)
  , ViewportType(Both)
  , Widget(Widget, render)
  , attrL
  , emptyResult
  , extentSize
  , extentUpperLeft
  , getContext
  , imageL
  , nestEventM
  )
import Brick.Widgets.Border (borderWithLabel)
import Brick.Widgets.Border.Style (unicodeBold)
import Brick.Widgets.Core
  ( fill
  , hBox
  , hLimit
  , modifyDefAttr
  , padLeftRight
  , raw
  , reportExtent
  , str
  , textWidth
  , translateBy
  , txt
  , vBox
  , vLimit
  , vLimitPercent
  , viewport
  , withBorderStyle
  , withHScrollBars
  , withVScrollBars
  )
import Brick.Widgets.Edit
  ( Editor
  , editContentsL
  , editorText
  , getEditContents
  , 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)

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

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

-- 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 (decodeUtf8Lenient, 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(attrStyle), MaybeDefault(..), Style, currentAttr, reverseVideo)
import qualified Graphics.Vty.Attributes as VA
import Graphics.Vty.Image
  ( Image
  , charFill
  , imageHeight
  , imageWidth
  , 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

-- | 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 => (AppR -> f AppR) -> 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 AppR -> f (Editor Method AppR)) -> 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 AppR -> f (Extent AppR)) -> OverlayS -> f OverlayS
methodEditorExtentL embed os = (\newExtent -> os{methodEditorExtent = newExtent}) <$> embed (methodEditorExtent os)

-- | Lens, method selector in overlay state
methodListL :: Functor f => (List AppR Method -> f (List AppR 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 AppR -> f (Editor String AppR)) -> AppS -> f AppS
urlEditorL embed s = (\newUrlEditor -> s{urlEditor = newUrlEditor}) <$> embed (urlEditor s)

-- | Lens, flag to use default headers
useDefaultHeadersL :: Functor f => (Bool -> f Bool) -> AppS -> f AppS
useDefaultHeadersL embed s =
  (\newUse -> s{useDefaultHeaders = newUse}) <$> embed (useDefaultHeaders s)

-- | Lens, custom headers
customHeadersL :: Functor f => ([(Bool, Header)] -> f [(Bool, Header)]) -> AppS -> f AppS
customHeadersL embed s =
  (\newHeaders -> s {customHeaders = newHeaders}) <$> embed (customHeaders s)

-- | Lens, header editor (maybe)
headerEditorL :: Functor f => (Maybe (Editor Text AppR) -> f (Maybe (Editor Text AppR))) -> AppS -> f AppS
headerEditorL embed s =
  (\newHEdit -> s { headerEditor = newHEdit }) <$> embed (headerEditor s)

{-|
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)

-- | 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" ]

data FocusSensitive = MkFocusSensitive
  { methodWidget :: Widget AppR
  , urlWidget :: Widget AppR
  , defaultHeadersToggleWidget :: Widget AppR
  , customHeadersWidgets :: [[Widget AppR]]
  , addCustomHeaderWidget :: Widget AppR
  , responseBodyWidget :: Widget AppR
  }

{-|
Render.

Widget names are all 'AppR'.

URL editor and label, then last response body at the top of the available space.  No other widgets
or layers.
-}
draw :: AppS -> [Widget AppR]
draw AppS{..} =
  [ drawOverlay os | Just os <- [overlayState] ]
  ++
  [ vBox $
    [ mainMenu
    , mainMenuSeparator
    , hBox
      [ reportExtent MethodEditor $ textLabeledBorder "Method" methodWidget
      , textLabeledBorder "URL to Query?" urlWidget
      ]
    , defaultHeadersSection
    ]
    ++
    [ textLabeledBorder "Custom Headers"
      . renderTable
      . surroundingBorder False
      . rowBorders False
      . table
      $ customHeadersWidgets ++ [[addCustomHeaderWidget, txt "", txt ""]]
    ]
    ++
    [ responseBodyWidget ]
  ] -- layers top to bottom
 where
  unfocusedWidgets = MkFocusSensitive
    { methodWidget = methodEditorWidget False
    , urlWidget = editorWidget False urlEditor
    , defaultHeadersToggleWidget = defaultHeadersToggle
    , customHeadersWidgets = map unfocusedHeader customHeaders
    , addCustomHeaderWidget = addCustomHeader
    , responseBodyWidget = responseBodyView
    }
  methodEditorWidget isFocused = hLimit 18 $ hBox [editorWidget isFocused methodEditor, str "\x25BC"]
  editorWidget = renderEditor (vBox . map str)
  usingDefaultHeadersText = "[X] Use Default Headers"
  (defaultHeadersToggle, defaultHeadersSection) =
    if useDefaultHeaders
     then
      ( txt usingDefaultHeadersText
      , borderWithLabel
          defaultHeadersToggleWidget
          (postprocessImage (growSpaces (textWidth usingDefaultHeadersText) left 0 top) (headersWidget defaultHeaders))
      )
     else (txt "[ ] Use Default Headers", defaultHeadersToggleWidget)
   where
    defaultHeaders = view headers defaults
  unfocusedHeader (active, (n, v)) = [unfocusedActive active, unfocusedName n, utf8 v ]
  unfocusedActive active = txt . Text.singleton $ if active then 'X' else ' '
  unfocusedName = utf8 . original
  addCustomHeader = txt "+"
  responseBodyView =
    textLabeledBorder "Response Body"
    . withVScrollBars OnRight
    . withHScrollBars OnBottom
    . viewport ResponseBodyView Both
    $ raw lastResponse
  MkFocusSensitive{..} = case focus of
    MethodEditor -> unfocusedWidgets { methodWidget = methodEditorWidget True }
    UrlEditor -> unfocusedWidgets { urlWidget = editorWidget True urlEditor }
    DefaultHeadersToggle -> unfocusedWidgets { defaultHeadersToggleWidget = focusWidget defaultHeadersToggle }
    ExistingCustomHeader chResource -> unfocusedWidgets { customHeadersWidgets = customHeadersWithFocus chResource }
    AddCustomHeader -> unfocusedWidgets { addCustomHeaderWidget = focusWidget addCustomHeader }
    ResponseBodyView -> unfocusedWidgets { responseBodyWidget = withBorderStyle unicodeBold responseBodyView }
    MethodSelector -> unfocusedWidgets
  customHeadersWithFocus MkCustomHeaderR{..} = zipWith headerRow [0..] customHeaders
   where
    headerRow i = if listIndex == i then focusedRow else unfocusedHeader
    focusedRow (active, (n, v)) = case column of
      ActiveToggle -> [focusWidget activeWidget, nameWidget, valueWidget]
      NameEditor -> [activeWidget, maybe (focusWidget nameWidget) renderHeaderEditor headerEditor, valueWidget]
      ValueEditor -> [activeWidget, nameWidget, maybe (focusWidget valueWidget) renderHeaderEditor headerEditor]
     where
      activeWidget = unfocusedActive active
      nameWidget = unfocusedName n
      valueWidget = utf8 v
      renderHeaderEditor hedit =
        hLimit (foldr (max . succ . textWidth) 1 $ getEditContents hedit)
        . vLimit 1
        $ renderEditor (vBox . map txt) True hedit

focusStyle :: Style -> Style
focusStyle x = x `xor` reverseVideo

focusAttr :: Attr -> Attr
focusAttr attr = attr { attrStyle = SetTo newStyle }
 where
  newStyle = case attrStyle attr of
    Default -> reverseVideo
    KeepCurrent -> reverseVideo
    SetTo style -> focusStyle style

focusWidget :: Widget n -> Widget n
focusWidget = modifyDefAttr focusAttr

utf8 :: ByteString -> Widget n
utf8 bytes = Widget Fixed Fixed $ do
  c <- getContext
  return emptyResult { image = utf8Bytestring' (c ^. attrL) bytes }

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

-- | When the overlay is present, what are the widget to draw on that layer.
drawOverlay :: OverlayS -> Widget AppR
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 AppR] -> Maybe (CursorLocation AppR)
chooseCursor s = showCursorNamed $ case overlayState s of
  Nothing -> focus s
  Just _ -> MethodSelector

-- | App state change on [Tab] to advace the focus.
moveFocusNext :: AppS -> AppS
moveFocusNext s = focusNext (customHeaders s) (focus s) s
 where
  focusNext cheaders = \case
    MethodEditor -> focusL .~ UrlEditor
    UrlEditor -> focusL .~ DefaultHeadersToggle
    DefaultHeadersToggle -> focusL .~ nextFocus
     where
      nextFocus =
        if null cheaders
         then AddCustomHeader
         else ExistingCustomHeader MkCustomHeaderR { listIndex = 0, column = ActiveToggle }
    ExistingCustomHeader MkCustomHeaderR{..} -> \os -> case splitAt listIndex cheaders of
      (initHdrs, (flag, (name, value)) : tailHdrs) -> case column of
        ActiveToggle -> os
          { focus = nextFocus
          , headerEditor = Just $ editorText nextFocus (Just 1) (decodeUtf8Lenient $ original name)
          }
         where
          nextFocus = ExistingCustomHeader MkCustomHeaderR { listIndex, column = NameEditor }
        NameEditor -> os
          { focus = nextFocus
          , headerEditor = Just $ editorText nextFocus (Just 1) (decodeUtf8Lenient value)
          , customHeaders =
              initHdrs
              ++ (flag, (maybe name (CaseInsensitive.mk . getEditorUtf8) (headerEditor os), value))
              : tailHdrs
          }
         where
          nextFocus = ExistingCustomHeader MkCustomHeaderR { listIndex, column = ValueEditor }
        ValueEditor ->
          if null tailHdrs
           then os
            { focus = AddCustomHeader
            , headerEditor = Nothing
            , customHeaders =
                initHdrs ++ [(flag, (name, valueViaEditor))]
            }
           else os
            { focus = ExistingCustomHeader MkCustomHeaderR { listIndex = succ listIndex, column = ActiveToggle }
            , headerEditor = Nothing
            , customHeaders =
                initHdrs ++ (flag, (name, valueViaEditor)) : tailHdrs
            }
         where
          valueViaEditor = maybe value getEditorUtf8 (headerEditor os)
      _ -> os { focus = AddCustomHeader, headerEditor = Nothing } -- NB: invalid focus
    AddCustomHeader -> focusL .~ ResponseBodyView
    ResponseBodyView -> focusL .~ MethodEditor
    MethodSelector -> focusL .~ MethodEditor -- NB: invalid focus

-- | App state change on [S+Tab] to recede the focus
moveFocusPrev :: AppS -> AppS
moveFocusPrev s = case focus s of
  MethodEditor -> s { focus = ResponseBodyView }
  UrlEditor -> s { focus = MethodEditor }
  DefaultHeadersToggle -> s { focus = UrlEditor }
  ExistingCustomHeader MkCustomHeaderR { .. } -> case splitAt listIndex $ customHeaders s of
    (initHdrs, (flag, (name, value)) : tailHdrs) -> case column of
      ActiveToggle -> case unsnoc initHdrs of
        Nothing -> s { focus = DefaultHeadersToggle }
        Just (_, (_, (_, lastValue))) -> s
          { focus = newFocus
          , headerEditor = Just . editorText newFocus (Just 1) $ decodeUtf8Lenient lastValue
          }
         where newFocus = ExistingCustomHeader MkCustomHeaderR { listIndex = pred listIndex, column = ValueEditor }
      NameEditor -> s
        { focus = ExistingCustomHeader MkCustomHeaderR { listIndex, column = ActiveToggle }
        , headerEditor = Nothing
        , customHeaders =
            initHdrs ++ (flag, (maybe name (CaseInsensitive.mk . getEditorUtf8) (headerEditor s), value)) : tailHdrs
        }
      ValueEditor -> s
        { focus = newFocus
        , headerEditor = Just . editorText newFocus (Just 1) . decodeUtf8Lenient $ original name
        , customHeaders =
            initHdrs ++ (flag, (name, maybe value getEditorUtf8 $ headerEditor s)) : tailHdrs
        }
       where
        newFocus = ExistingCustomHeader MkCustomHeaderR { listIndex, column = NameEditor }
    _ -> s { focus = DefaultHeadersToggle, headerEditor = Nothing } -- NB: invalid focus
  AddCustomHeader -> case unsnoc $ customHeaders s of
    Nothing -> s { focus = DefaultHeadersToggle }
    Just (initHdrs, (_, (_, value))) -> s
      { focus = newFocus
      , headerEditor = Just $ editorText newFocus (Just 1) (decodeUtf8Lenient value)
      }
     where
      newFocus = ExistingCustomHeader MkCustomHeaderR { listIndex = length initHdrs, column = ValueEditor }
  ResponseBodyView -> s { focus = AddCustomHeader }
  MethodSelector -> s { focus = ResponseBodyView } -- NB: invalid focus


{-|
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 AppR Void -> EventM AppR 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 AppR 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 AppR 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 focus s of
     UrlEditor -> handleEditorLEvent urlEditorL evt
     MethodEditor -> handleMethodEditorEvent evt
     DefaultHeadersToggle -> handleDefaultHeadersEditorEvent evt
     ExistingCustomHeader chResource -> handleCustomHeaderEvent chResource evt
     AddCustomHeader -> handleAddCustomHeaderEvent evt
     ResponseBodyView -> handleResponseBodyViewportEvent evt
     MethodSelector -> pure () -- NB: invalid focus / should be in handleEventOverlay

-- | Pass event into 'handleEditorEvent', when not handled more specifically.
handleEditorLEvent :: ALens' AppS (Editor String AppR) -> Event -> EventM AppR 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 AppR AppS ()
handleMethodEditorEvent (EvKey KDown _mods) = do
  s <- get
  let
    enteredMethod = view methodL s
    listContents = Vector.fromList . nub $ enteredMethod : knownMethods
  mMethodEditorExtent <- lookupExtent MethodEditor
  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 AppR 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 ResponseBodyView

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

-- | If in the active column, SP toggles.  Otherwise, pass to the active headerEditor (which _should_ not be Nothing).
--
-- FUTURE: Allow KUp and KDown to move the focus.
--
-- TBD: How to delete (not just deactivate) a custom header?
handleCustomHeaderEvent :: CustomHeaderR -> Event -> EventM AppR AppS ()
handleCustomHeaderEvent MkCustomHeaderR { listIndex, column = ActiveToggle } (EvKey (KChar ' ') _) =
  customHeadersL %= toggleHeader
 where
  toggleHeader oldHeaders = case splitAt listIndex oldHeaders of
    (initHdrs, (flag, hdr) : tailHdrs) -> initHdrs ++ (not flag, hdr) : tailHdrs
    _ -> oldHeaders -- Invalid Index
handleCustomHeaderEvent _ evt = zoom (headerEditorL . _Just) . handleEditorEvent $ VtyEvent evt

-- | SP creates a new header.
handleAddCustomHeaderEvent :: Event -> EventM AppR AppS ()
handleAddCustomHeaderEvent (EvKey (KChar ' ') _) = modify addNewCustomHeader
 where
  addNewCustomHeader oldState = oldState
    { customHeaders = oldCustomHeaders ++ [(True, (CaseInsensitive.mk newName, ByteString.empty))]
    , focus = newFocus
    , headerEditor = Just . editorText newFocus (Just 1) $ decodeUtf8Lenient newName
    }
   where
    oldCustomHeaders = customHeaders oldState
    newName = ByteString.empty
    newFocus = ExistingCustomHeader MkCustomHeaderR { listIndex = length oldCustomHeaders, column = NameEditor }
handleAddCustomHeaderEvent _ = pure ()

-- | Retrieve extent emitted during last draw and update overlay state.
updateExtent :: EventM AppR OverlayS ()
updateExtent = do
  mExtent <- lookupExtent MethodEditor
  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 AppR 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)

getEditorUtf8 :: Editor Text n -> ByteString
getEditorUtf8 = encodeUtf8 . mconcat . getEditContents

{-|
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
  justSndIfFst (active, value) = if active then Just value else Nothing
  updateHeaders AppS{..} = if useDefaultHeaders then (++ activeCustomHeaders) else const activeCustomHeaders
   where
    activeCustomHeaders = case focus of
      ExistingCustomHeader MkCustomHeaderR{..} -> catMaybes $ zipWith focusedOrSaved [0..] customHeaders
       where
        focusedOrSaved _i (False, _) = Nothing
        focusedOrSaved i (True, hdr) = if listIndex == i then Just $ focusByColumn hdr else Just hdr
        focusByColumn hdr = case column of
          ActiveToggle -> hdr
          NameEditor -> (maybe (fst hdr) (CaseInsensitive.mk . getEditorUtf8) headerEditor, snd hdr)
          ValueEditor -> (fst hdr, maybe (snd hdr) getEditorUtf8 headerEditor)
      _ -> mapMaybe justSndIfFst 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