restman-0.7.4.0: src/UI.hs

{-# language OverloadedStrings #-}
{-|
Module: UI

Top-level Brick application wiring for RESTman.

'mkInitialState' builds the initial 'AppS' from the values parsed on the command line.
'startUI' creates the HTTP manager, optionally performs an initial request when a URI is
supplied, and hands control to the Brick main loop.

The Brick 'App' record is assembled here; the individual draw, event-handling, and cursor
functions live in "Lib".
-}
module UI
    ( -- * Application entry points
      mkInitialState
    , startUI
    ) where

-- base
import Data.Maybe (fromMaybe)

-- brick
import Brick.AttrMap (AttrMap)
import qualified Brick.AttrMap as Brick
import Brick.Main (App(..), defaultMain)
import Brick.Widgets.Border (borderAttr)
import Brick.Widgets.Edit (editor)
import Brick.Widgets.List (listSelectedFocusedAttr)

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

-- http-client
import qualified Network.HTTP.Client as HC

-- text
import Data.Text (Text)
import qualified Data.Text as T

-- vty
import Graphics.Vty.Attributes
  ( Attr(Attr, attrBackColor, attrForeColor, attrStyle, attrURL)
  , MaybeDefault(Default, SetTo)
  , currentAttr
  , reverseVideo
  )
import Graphics.Vty.Image (emptyImage)

-- local libs
import HTTP.Client (Header, UseDefaultHeaders, robustSettings)
import Lib
import Types


-- | Attribute map for the application.  Sets reverse-video for the focused list item and
-- resets the border attribute to terminal defaults so borders inherit the terminal colour scheme.
attrMap :: AppS -> AttrMap
attrMap _ =
  Brick.attrMap currentAttr
    [ (listSelectedFocusedAttr, currentAttr {attrStyle = SetTo reverseVideo})
    , (borderAttr, termDefaults)
    ]
 where
  termDefaults = Attr
    { attrStyle = Default
    , attrForeColor = Default
    , attrBackColor = Default
    , attrURL = Default
    }

-- | Build the initial 'AppS' from command-line arguments and an HTTP manager.
mkInitialState
  :: HC.Manager            -- ^ HTTP connection manager
  -> String                -- ^ Initial HTTP method
  -> UseDefaultHeaders     -- ^ How to handle default headers
  -> [Header]              -- ^ Additional or replacement headers
  -> Maybe Lazy.ByteString -- ^ Payload or Nothing
  -> Maybe Text            -- ^ URI or Nothing
  -> AppS
mkInitialState m method useDefault custHeaders payloadLbs uri = AppS
  { focus = UrlEditor
  , methodEditor = editor MethodEditor (Just 1) method
  , overlayState = Nothing
  , urlEditor = editor UrlEditor (Just 1) (T.unpack $ fromMaybe "" uri)
  , lastResponse = emptyImage
  , useDefaultHeaders = toEnum $ fromEnum useDefault
  , customHeaders = map (True,) custHeaders
  , headerEditor = Nothing
  , payload = payloadLbs
  , connManager = m
  }

{-|
Launch the RESTman TUI.

Creates a new HTTP 'HC.Manager' using 'robustSettings', builds the initial 'AppS' via
'mkInitialState', and — if a URI was supplied — fires an initial request before entering
the Brick event loop.
-}
startUI
  :: String -- ^ Initial HTTP method
  -> UseDefaultHeaders -- ^ how to handle default headers
  -> [Header] -- ^ additional or replacement headers
  -> Maybe Lazy.ByteString -- ^ payload or Nothing
  -> Maybe Text -- ^ uri or Nothing
  -> IO ()
startUI method useDefault custHeaders payloadLbs uri = do
  manager <- HC.newManager robustSettings
  uiState <- case uri of
    Nothing -> pure $ mkInitialState manager method useDefault custHeaders payloadLbs uri
    Just{} -> doRequest $ mkInitialState manager method useDefault custHeaders payloadLbs uri
  _ <- defaultMain app uiState
  pure ()
 where
  app = App
    { appDraw = draw
    , appChooseCursor = chooseCursor
    , appHandleEvent = handleEvent
    , appStartEvent = pure ()
    , appAttrMap = attrMap
    }