diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,46 @@ +# Changelog for restman + +## 0.7.1.0 + +⬆️ Update to LTS 24.24 (ghc-9.10.3) +✨ Show Default Headers in TUI When Enabled +✨ Automatically Syntax Hightlight Payload when Possible +✨ Horizontal & Vertical Scrolling in Payload Widget (Vi Keys & Mouse Support) + +## 0.7.0.1 + +🚑️ Only the space key should toggle using default headers when focused + +## 0.7.0.0 + +⬆️ Update to LTS 24.14 (ghc-9.10.3) +✨ Allow toggling "Use Default Headers" setting in TUI + +## 0.6.0.0 + +⬆️ Stackage LTS 23.0 ghc-9.8.4 + +## 0.5.0.0 + +⬆️ Stackage LTS 22.36 ghc-9.6.4 +⚡️ Rapid Load Support + +## 0.4.0 + +⬆️ Stackage LTS version 18.28 +👷 CI Build Image Pinned to Stackage Version + +## 0.3.0 + +⬆️ Stackage LTS version 17.4 + +## 0.2.0 + +⬆️ Stackage LTS version 15. +✨ TUI and basic CLI (TUI launcher only). +✨ Most basic features landed here including HTTPS support. +✨ GET, POST, DELETE, etc. to a given URL. +✨ You can also specify custom headers and payloads. + +## Unreleased changes +All of them diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Zac Slade (c) 2025 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Zac Slade nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,66 @@ +[![pipeline status](https://gitlab.com/krakrjak/restman/badges/master/pipeline.svg)](https://gitlab.com/krakrjak/restman/-/commits/master) + +RESTMan is a program for sending web requests using a terminal user interface or TUI. + +[[_TOC_]] + +Right now, Windows is not supported directly due to limitations of the [Brick](https://hackage.haskell.org/package/brick) library used to generate the TUI. You can however, use Windows to build and execute RESTMan through WSL2 and a Debian distribution. See details below. + +--- + +# Usage + + % stack exec restman -- --help + RESTman, an HTTP(S) application + + Usage: restman [--help] [-m|--method METHOD] + [--no-default-headers | --default-headers] + [-h|--custom-header NAME_VALUE] + [--payload PAYLOAD | --payload-file PATHNAME] + A TUI application for interactively using the full range of HTTP(S) directly + + Available options: + --help Show command-line help and abort normal operation. + -m,--method METHOD HTTP(S) Method (or "Verb") (default: "GET") + --no-default-headers Send ONLY the custom headers specified. + --default-headers Send custom headers after default headers. This is + the default behavior. + -h,--custom-header NAME_VALUE + Add a custom header, argument is name:value (colon + separates name from value). + --payload PAYLOAD Specify (in UTF-8) payload directly on command-line + --payload-file PATHNAME Load payload from file on startup + + https://gitlab.com/krakrjak/restman + +--- +# Building + +For those already familiar with Haskell and the Stack, you can get up and running quickly with the usual recipie of `stack setup` followed by `stack build`. As usual, `stack setup` only needs to be run once. + +## Building on Debian (WSL2 Tested) + +Install and configure your favorite shell, you are going to spend a lot of time in it. :) + +Once you are comfortable install the package _haskell-stack_, _libtinfo-dev_, and _libz1g-dev_ using apt: `apt install haskell-stack libtinfo-dev libz1g-dev` + +You will need to upgrade the Debian provided stack using `stack upgrade`. If needed it will prompt you for sudo access. Once your stack is up-to-date you need a Haskell compiler. Use `stack setup` to determine, fetch, and configure a compiler for your environment. You can check your installation using `stack ghci` to enter the GHC REPL. + +Now you are ready to build RESTMan and all of its dependencies. `stack build` + +## Building on M1 Mac + +Install [ghcup](https://www.haskell.org/ghcup/), then `brew install llvm`. Then you will need the following setup in your environment: + +```sh +export PATH="/opt/homebrew/opt/llvm@13/bin:$PATH" +export LDFLAGS="-L/opt/homebrew/opt/llvm@13/lib" +export CPPFLAGS="-I/opt/homebrew/opt/llvm@13/include" +``` + +Then you can successfully use `stack` to build the program. You will need some extra flags to make it all work. Here's what is reported to work currently: `stack --arch aarch64 --system-ghc build`. + +--- +# Running and Testing + +Once you have _restman-exe_ built you can use stack to execute it with `stack exec restman-exe`. If you want to pass options to the program you can use the form `stack exec restman-exe -- OPTIONS FOR RESTMAN BINARY`. You can also install the binary to _~/.local_ with `stack install`. If you add _~/.local/bin_ to your __PATH__ you can run the program without the aid of the _stack_ executable. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,185 @@ +module Main (main) where + +-- base +import Control.Applicative (many, optional, (<|>)) +import Data.Bits (Bits, unsafeShiftL) +import System.IO (IOMode(ReadMode), withFile) + +-- bytestring +import Data.ByteString (ByteString, hGetSome) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as CS +import Data.ByteString.Lazy (fromChunks, fromStrict) +import qualified Data.ByteString.Lazy as Lazy (ByteString) + +-- case-insensitive +import qualified Data.CaseInsensitive as CI + +-- microlens +import Lens.Micro.Extras (view) + +-- optparse-applicatve +import Options.Applicative + ( ParseError(ShowHelpText) + , Parser + , ParserInfo + , abortOption + , completeWith + , execParser + , flag' + , footer + , fullDesc + , header + , help + , info + , long + , metavar + , progDesc + , short + , showDefault + , strArgument + , strOption + ) +import qualified Options.Applicative as OptParse + +-- text +import Data.Text (Text) + +-- utf8-string +import qualified Data.ByteString.UTF8 as UTF8 + +-- local imports +import HTTP.Client +import UI + + +-- | Handles @-m@ / @--method@ +methodParser :: Parser Method +methodParser = strOption + ( short 'm' + <> long "method" + <> help "HTTP(S) Method (or \"Verb\")" + <> OptParse.value "GET" + <> showDefault + <> metavar "METHOD" + <> completeWith knownMethods + ) + +-- | handles @--[no-]default-headers@ +useDefaultParser :: Parser UseDefaultHeaders +useDefaultParser = noDefaultHeaders <|> defaultHeaders <|> pure AppendCustomToDefaultHeaders + where + noDefaultHeaders = flag' ReplaceDefaultHeaders + ( long "no-default-headers" + <> help "Send ONLY the custom headers specified." + ) + defaultHeaders = flag' AppendCustomToDefaultHeaders + ( long "default-headers" + <> help "Send custom headers after default headers. This is the default behavior." + ) + +{-| +Handles the option-argument for @-h@ / @--custom-header@. + +Unicode value is split on the first colon. Anything before the colon must truncate to ISO-8859-1, +and is treated as the header name. Anything after the colon is treated as the header value, and +full Unicode is accepted and encoded as UTF-8. + +No validation is done on the header name. No allowance is made for specifying an (invalid) header +name that contains a colon. +-} +optArgToHeader :: String -> Header +optArgToHeader arg = (CI.mk $ CS.pack name, UTF8.fromString value) + where + (name, colonValue) = break (':' ==) arg + value = drop 1 colonValue + +-- | handles @-h@ / @--custom-header@ +customHeadersParser :: Parser [Header] +customHeadersParser = many . fmap optArgToHeader $ strOption + ( short 'h' + <> long "custom-header" + <> help "Add a custom header, argument is name:value (colon separates name from value)." + <> metavar "NAME_VALUE" + ) + +-- | Specification of the payload from the user +data Payload + = Literal ByteString -- ^ argument converted to bytes + | File FilePath -- ^ argument converts to file path + +-- | Handles @--payload@ and @--payload-file@ +payloadParser :: Parser (Maybe Payload) +payloadParser = optional ((Literal <$> literalParser) <|> (File <$> fileParser)) + where + literalParser = UTF8.fromString <$> strOption + ( long "payload" + <> help "Specify (in UTF-8) payload directly on command-line" + <> metavar "PAYLOAD" + ) + fileParser = strOption + ( long "payload-file" + <> help "Load payload from file on startup" + <> metavar "PATHNAME" + ) + +-- | Handle optional positional parameter for URI +uriPositionalParser :: Parser (Maybe Text) +uriPositionalParser = optional $ strArgument (metavar "URI") + +-- | Options from the command-line +data Options = MkOptions + { method :: Method + , useDefaultHeaders :: UseDefaultHeaders + , customHeaders :: [Header] + , payload :: Maybe Payload + , uri :: Maybe Text + } + +helpParser :: Parser (a -> a) +helpParser = abortOption (ShowHelpText mempty) + ( long "help" + <> help "Show command-line help and abort normal operation." + ) + +-- | Handles full command-line, generating help, and completions +appParser :: ParserInfo Options +appParser = info (helpParser <*> optionsParser) + ( fullDesc + <> header "RESTman, an HTTP(S) application" + <> footer "https://gitlab.com/krakrjak/restman" + <> progDesc "A TUI application for interactively using the full range of HTTP(S) directly" + ) + where + optionsParser = + MkOptions <$> methodParser <*> useDefaultParser <*> customHeadersParser <*> payloadParser <*> uriPositionalParser + +-- | Lens for the method in the options. +optMethod :: Functor f => (Method -> f Method) -> Options -> f Options +optMethod embed opts = fmap (\m -> opts{ method = m}) . embed $ method opts + +-- | 'unsafeShilfL' +(.<<.) :: Bits b => b -> Int -> b +(.<<.) = unsafeShiftL + +-- | Go from payload specification to a payload ready for library. +loadPayload :: Payload -> IO Lazy.ByteString +loadPayload (Literal bs) = pure $ fromStrict bs +loadPayload (File fp) = fromChunks <$> withFile fp ReadMode readChunks + where + readChunks hdl = go + where + go = do + chunk <- hGetSome hdl (1 .<<. 15 {- 32k -}) + if BS.null chunk + then return [] + else do + chunks <- go + return $ chunk:chunks + +-- | Application entry point. +main :: IO () +main = do + options <- execParser appParser + payloadLbs <- traverse loadPayload $ payload options + startUI (view optMethod options) (useDefaultHeaders options) (customHeaders options) payloadLbs (uri options) diff --git a/app/TUI.hs b/app/TUI.hs new file mode 100644 --- /dev/null +++ b/app/TUI.hs @@ -0,0 +1,23 @@ +{-# language DeriveGeneric #-} +module TUI where + +-- ghc +import GHC.Generics (Generic) + +-- text +import Data.Text as T + +-- wreq +import Network.Wreq (Options) + +-- Types of HTTP requests, extensible with Custom +data Verb = GET | HEAD | POST | PUT | DELETE | OPTIONS | PATCH | Custom T.Text + deriving (Show, Eq, Generic) + +-- Resource Type for making requets +data ReqConfig = + ReqConfig + { _httpUri :: T.Text + , _options :: Options + , _verb :: Verb + } deriving (Show, Generic) diff --git a/restman.cabal b/restman.cabal new file mode 100644 --- /dev/null +++ b/restman.cabal @@ -0,0 +1,92 @@ +cabal-version: 1.12 +name: restman +-- version Controlled by semantic-release +version: 0.7.1.1 +synopsis: Web request TUI program. +description: Please see the README on GitLab at +category: Web +homepage: https://gitlab.com/krakrjak/restman#readme +bug-reports: https://gitlab.com/krakrjak/restman/issues +author: Zac Slade +maintainer: krakrjak@gmail.com, boyd.stephen.smith.jr@gmail.com +copyright: Zac Slade or Boyd Stephen Smith Jr, 2024 +license: BSD2 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://gitlab.com/krakrjak/restman + +library + exposed-modules: + HTTP.Client + Skylighting.Format.Vty + Lib + Types + UI + other-modules: + Paths_restman + hs-source-dirs: + src + build-depends: + ansi-terminal-types + , base >=4.7 && <5 + , binary + , brick + , bytestring + , case-insensitive + , containers + , http-client + , http-client-tls + , http-types + , lens + , microlens-mtl + , mime-types + , mtl + , skylighting + , text + , text-zipper + , unliftio + , vector + , vty + , wreq + default-language: GHC2024 + +executable restman + main-is: Main.hs + other-modules: + TUI + Paths_restman + hs-source-dirs: + app + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + build-depends: + base >=4.7 && <5 + , brick + , bytestring + , case-insensitive + , http-types + , microlens + , optparse-applicative + , restman + , text + , utf8-string + , wreq + default-language: GHC2024 + +test-suite restman-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_restman + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + build-depends: + base >=4.7 && <5 + , restman + default-language: GHC2024 diff --git a/src/HTTP/Client.hs b/src/HTTP/Client.hs new file mode 100644 --- /dev/null +++ b/src/HTTP/Client.hs @@ -0,0 +1,79 @@ +{-| +Create wreq options with a custom HTTP manager that has increased limits to handle captive portals and proxies. + +This sets: +- managerResponseTimeout to 30 seconds (prevents hanging on slow proxies) + +Note: The underlying http-client library has a hardcoded 8KB limit per header line that cannot +be configured in this version. Some sites (e.g., slashdot.org with its extensive Content-Security-Policy +header listing hundreds of domains) may exceed this limit. These sites will fail with an OverlongHeaders +exception. This is a known limitation of the http-client library version in use. +-} +{-# language OverloadedStrings #-} +module HTTP.Client + ( -- * HTTP.Client helpers + UseDefaultHeaders(..) + , knownMethods + , Method + , robustSettings + -- * wreq re-exports + , customMethodWith + , customPayloadMethodWith + , defaults + , headers + , responseBody + , responseHeader + -- * http-types re-exports + , Header + ) where + +-- http-client +import qualified Network.HTTP.Client as HC +-- http-client-tls +import qualified Network.HTTP.Client.TLS as HCT +-- http-types +import Network.HTTP.Types.Header (Header) +-- wreq +import Network.Wreq + ( customMethodWith + , customPayloadMethodWith + , defaults + , headers + , responseBody + , responseHeader + ) + +-- | Helper type for clarity of intention. +type Method = String + +-- | Bool-ish (for now) with more descriptive names. +data UseDefaultHeaders + = ReplaceDefaultHeaders + | AppendCustomToDefaultHeaders + deriving (Eq, Ord, Enum, Bounded, Show, Read) + +robustSettings :: HC.ManagerSettings +robustSettings = HCT.tlsManagerSettings + { HC.managerResponseTimeout = HC.responseTimeoutMicro 30000000 -- 30 seconds + -- Note: managerRawConnection can be used to customize the connection, + -- but header size limits are hardcoded in the http-client parser. + -- The default limit is 8KB per header line. Sites like slashdot.org + -- may exceed this with long cookie headers. + } + +{-| +Lifted from +https://en.wikipedia.org/w/index.php?title=Hypertext_Transfer_Protocol&oldid=954964381#Request_methods +-} +knownMethods :: [Method] +knownMethods = + [ "GET" + , "HEAD" + , "POST" + , "PUT" + , "DELETE" + , "TRACE" + , "OPTIONS" + , "CONNECT" + , "PATCH" + ] diff --git a/src/Lib.hs b/src/Lib.hs new file mode 100644 --- /dev/null +++ b/src/Lib.hs @@ -0,0 +1,602 @@ +{-# 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 +-- * : 3 line scroll up +-- * : 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 diff --git a/src/Skylighting/Format/Vty.hs b/src/Skylighting/Format/Vty.hs new file mode 100644 --- /dev/null +++ b/src/Skylighting/Format/Vty.hs @@ -0,0 +1,417 @@ + +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# language CPP #-} +{-# language DeriveDataTypeable #-} +{-# language DeriveGeneric #-} +{-# language FlexibleInstances #-} +{-# language GeneralizedNewtypeDeriving #-} +{-# language OverloadedStrings #-} +module Skylighting.Format.Vty ( + formatVty + ) where +import Control.Monad (mplus) +import Data.Binary (Binary) +import Data.Bits ((.|.)) +import Data.Data +import Data.Int +import Data.List +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import Data.Ord +import qualified Data.Text.Lazy as LText +import Data.Word +import GHC.Generics + +-- skylighting +import Skylighting.Types + ( ANSIColorLevel(..) + , Color(..) + , FormatOptions(..) + , FromColor(..) + , LineNo(..) + , SourceLine + , Style(..) + , ToColor(..) + , Token + , TokenStyle(..) + , backgroundColor + , defStyle + , defaultColor + , fromColor + , lineNumberBackgroundColor + , lineNumberColor + , toColor + , tokenStyles + ) + +-- ansi-terminal-types +import qualified System.Console.ANSI.Codes as ANSI + +#if !MIN_VERSION_base(4,11,0) +import Data.Semigroup ((<>)) +#endif + +import qualified Graphics.Vty.Attributes as VA +import Graphics.Vty.Image (Image, emptyImage, horizJoin, (<->)) +import qualified Graphics.Vty.Image as VI + + +formatVty :: FormatOptions -> Style -> [SourceLine] -> Image +formatVty opts sty sls = foldr (<->) emptyImage $ zipWith (sourceLineToImage opts sty) [startNum..] sls + where startNum = LineNo $ startNumber opts + +sourceLineToImage :: FormatOptions -> Style -> LineNo -> SourceLine -> Image +sourceLineToImage opts sty lno = foldr (horizJoin . tokenToImage clv sty) prependLineNoImage + where prependLineNoImage = if numberLines opts + then lineNoImage + else emptyImage + lineNoImage = VI.text (vtyStyleAttr clv lineNoFgc lineNoBgc False False False) $ LText.pack (show $ lineNo lno) <> "\t" + lineNoFgc = lineNumberColor sty `mplus` defaultColor sty + lineNoBgc = lineNumberBackgroundColor sty `mplus` backgroundColor sty + clv = ansiColorLevel opts + +tokenToImage :: ANSIColorLevel -> Style -> Token -> Image +tokenToImage clv sty (tokTy, tokText) = VI.text (vtyStyleAttr clv tokFgc tokBgc tokB tokI tokU) (LText.fromStrict tokText) + where TokenStyle tokFgcRaw tokBgcRaw tokB tokI tokU = fromMaybe defStyle . Map.lookup tokTy $ tokenStyles sty + tokFgc = tokFgcRaw `mplus` defaultColor sty + tokBgc = tokBgcRaw `mplus` backgroundColor sty + +vtyStyleAttr :: ANSIColorLevel -- ^ color support level + -> Maybe Color -- ^ foreground + -> Maybe Color -- ^ background + -> Bool -- ^ bold + -> Bool -- ^ italic + -> Bool -- ^ underlined + -> VA.Attr +vtyStyleAttr clv fgc bgc b i u = VA.Attr + (VA.SetTo $ attrStyle b i u) + (maybe VA.Default VA.SetTo (attrColor clv fgc)) + (maybe VA.Default VA.SetTo (attrColor clv bgc)) + VA.Default + +attrStyle :: Bool -> Bool -> Bool -> VA.Style +attrStyle b i u = style + where + bold = if b then VA.bold else VA.defaultStyleMask + underline = if u then VA.underline else VA.defaultStyleMask + italic = if i then VA.italic else VA.defaultStyleMask + style = bold .|. underline .|. italic + +attrColor :: ANSIColorLevel -> Maybe Color -> Maybe VA.Color +attrColor _clv Nothing = Nothing +attrColor clv (Just (RGB r g b)) = case clv of + ANSITrueColor -> Just $ VA.rgbColor r g b + ANSI256Color -> Just $ VA.rgbColor r g b + ANSI16Color -> Just $ VA.rgbColor r g b + + +-- | Standard values taken from https://jonasjacek.github.io/colors/ +ansi16ColorList :: [((ANSI.ColorIntensity, ANSI.Color), Color)] +ansi16ColorList = [ ((ANSI.Dull , ANSI.Black ), RGB 0 0 0 ) + , ((ANSI.Dull , ANSI.Red ), RGB 128 0 0 ) + , ((ANSI.Dull , ANSI.Green ), RGB 0 128 0 ) + , ((ANSI.Dull , ANSI.Yellow ), RGB 128 128 0 ) + , ((ANSI.Dull , ANSI.Blue ), RGB 0 0 128) + , ((ANSI.Dull , ANSI.Magenta), RGB 128 0 128) + , ((ANSI.Dull , ANSI.Cyan ), RGB 0 128 128) + , ((ANSI.Dull , ANSI.White ), RGB 192 192 192) + , ((ANSI.Vivid, ANSI.Black ), RGB 128 128 128) + , ((ANSI.Vivid, ANSI.Red ), RGB 255 0 0 ) + , ((ANSI.Vivid, ANSI.Green ), RGB 0 255 0 ) + , ((ANSI.Vivid, ANSI.Yellow ), RGB 255 255 0 ) + , ((ANSI.Vivid, ANSI.Blue ), RGB 0 0 255) + , ((ANSI.Vivid, ANSI.Magenta), RGB 255 0 255) + , ((ANSI.Vivid, ANSI.Cyan ), RGB 0 255 255) + , ((ANSI.Vivid, ANSI.White ), RGB 255 255 255) + ] + +newtype Xterm256ColorCode = Xterm256ColorCode { getXterm256ColorCode :: Word8 } + deriving (Show, Read, Eq, Ord, Enum, Bounded, Data, Typeable, Generic) + +instance Binary Xterm256ColorCode + +-- | Converted from https://jonasjacek.github.io/colors/data.json, then slightly rearranged +ansi256ColorList :: [(Xterm256ColorCode, Color)] +ansi256ColorList = [ (Xterm256ColorCode 232, RGB 8 8 8) -- grayscale colors + , (Xterm256ColorCode 233, RGB 18 18 18) + , (Xterm256ColorCode 234, RGB 28 28 28) + , (Xterm256ColorCode 235, RGB 38 38 38) + , (Xterm256ColorCode 236, RGB 48 48 48) + , (Xterm256ColorCode 237, RGB 58 58 58) + , (Xterm256ColorCode 238, RGB 68 68 68) + , (Xterm256ColorCode 239, RGB 78 78 78) + , (Xterm256ColorCode 240, RGB 88 88 88) + , (Xterm256ColorCode 241, RGB 98 98 98) + , (Xterm256ColorCode 242, RGB 108 108 108) + , (Xterm256ColorCode 243, RGB 118 118 118) + , (Xterm256ColorCode 244, RGB 128 128 128) + , (Xterm256ColorCode 245, RGB 138 138 138) + , (Xterm256ColorCode 246, RGB 148 148 148) + , (Xterm256ColorCode 247, RGB 158 158 158) + , (Xterm256ColorCode 248, RGB 168 168 168) + , (Xterm256ColorCode 249, RGB 178 178 178) + , (Xterm256ColorCode 250, RGB 188 188 188) + , (Xterm256ColorCode 251, RGB 198 198 198) + , (Xterm256ColorCode 252, RGB 208 208 208) + , (Xterm256ColorCode 253, RGB 218 218 218) + , (Xterm256ColorCode 254, RGB 228 228 228) + , (Xterm256ColorCode 255, RGB 238 238 238) + , (Xterm256ColorCode 16, RGB 0 0 0) -- RGB cube colors + , (Xterm256ColorCode 17, RGB 0 0 95) + , (Xterm256ColorCode 18, RGB 0 0 135) + , (Xterm256ColorCode 19, RGB 0 0 175) + , (Xterm256ColorCode 20, RGB 0 0 215) + , (Xterm256ColorCode 21, RGB 0 0 255) + , (Xterm256ColorCode 22, RGB 0 95 0) + , (Xterm256ColorCode 23, RGB 0 95 95) + , (Xterm256ColorCode 24, RGB 0 95 135) + , (Xterm256ColorCode 25, RGB 0 95 175) + , (Xterm256ColorCode 26, RGB 0 95 215) + , (Xterm256ColorCode 27, RGB 0 95 255) + , (Xterm256ColorCode 28, RGB 0 135 0) + , (Xterm256ColorCode 29, RGB 0 135 95) + , (Xterm256ColorCode 30, RGB 0 135 135) + , (Xterm256ColorCode 31, RGB 0 135 175) + , (Xterm256ColorCode 32, RGB 0 135 215) + , (Xterm256ColorCode 33, RGB 0 135 255) + , (Xterm256ColorCode 34, RGB 0 175 0) + , (Xterm256ColorCode 35, RGB 0 175 95) + , (Xterm256ColorCode 36, RGB 0 175 135) + , (Xterm256ColorCode 37, RGB 0 175 175) + , (Xterm256ColorCode 38, RGB 0 175 215) + , (Xterm256ColorCode 39, RGB 0 175 255) + , (Xterm256ColorCode 40, RGB 0 215 0) + , (Xterm256ColorCode 41, RGB 0 215 95) + , (Xterm256ColorCode 42, RGB 0 215 135) + , (Xterm256ColorCode 43, RGB 0 215 175) + , (Xterm256ColorCode 44, RGB 0 215 215) + , (Xterm256ColorCode 45, RGB 0 215 255) + , (Xterm256ColorCode 46, RGB 0 255 0) + , (Xterm256ColorCode 47, RGB 0 255 95) + , (Xterm256ColorCode 48, RGB 0 255 135) + , (Xterm256ColorCode 49, RGB 0 255 175) + , (Xterm256ColorCode 50, RGB 0 255 215) + , (Xterm256ColorCode 51, RGB 0 255 255) + , (Xterm256ColorCode 52, RGB 95 0 0) + , (Xterm256ColorCode 53, RGB 95 0 95) + , (Xterm256ColorCode 54, RGB 95 0 135) + , (Xterm256ColorCode 55, RGB 95 0 175) + , (Xterm256ColorCode 56, RGB 95 0 215) + , (Xterm256ColorCode 57, RGB 95 0 255) + , (Xterm256ColorCode 58, RGB 95 95 0) + , (Xterm256ColorCode 59, RGB 95 95 95) + , (Xterm256ColorCode 60, RGB 95 95 135) + , (Xterm256ColorCode 61, RGB 95 95 175) + , (Xterm256ColorCode 62, RGB 95 95 215) + , (Xterm256ColorCode 63, RGB 95 95 255) + , (Xterm256ColorCode 64, RGB 95 135 0) + , (Xterm256ColorCode 65, RGB 95 135 95) + , (Xterm256ColorCode 66, RGB 95 135 135) + , (Xterm256ColorCode 67, RGB 95 135 175) + , (Xterm256ColorCode 68, RGB 95 135 215) + , (Xterm256ColorCode 69, RGB 95 135 255) + , (Xterm256ColorCode 70, RGB 95 175 0) + , (Xterm256ColorCode 71, RGB 95 175 95) + , (Xterm256ColorCode 72, RGB 95 175 135) + , (Xterm256ColorCode 73, RGB 95 175 175) + , (Xterm256ColorCode 74, RGB 95 175 215) + , (Xterm256ColorCode 75, RGB 95 175 255) + , (Xterm256ColorCode 76, RGB 95 215 0) + , (Xterm256ColorCode 77, RGB 95 215 95) + , (Xterm256ColorCode 78, RGB 95 215 135) + , (Xterm256ColorCode 79, RGB 95 215 175) + , (Xterm256ColorCode 80, RGB 95 215 215) + , (Xterm256ColorCode 81, RGB 95 215 255) + , (Xterm256ColorCode 82, RGB 95 255 0) + , (Xterm256ColorCode 83, RGB 95 255 95) + , (Xterm256ColorCode 84, RGB 95 255 135) + , (Xterm256ColorCode 85, RGB 95 255 175) + , (Xterm256ColorCode 86, RGB 95 255 215) + , (Xterm256ColorCode 87, RGB 95 255 255) + , (Xterm256ColorCode 88, RGB 135 0 0) + , (Xterm256ColorCode 89, RGB 135 0 95) + , (Xterm256ColorCode 90, RGB 135 0 135) + , (Xterm256ColorCode 91, RGB 135 0 175) + , (Xterm256ColorCode 92, RGB 135 0 215) + , (Xterm256ColorCode 93, RGB 135 0 255) + , (Xterm256ColorCode 94, RGB 135 95 0) + , (Xterm256ColorCode 95, RGB 135 95 95) + , (Xterm256ColorCode 96, RGB 135 95 135) + , (Xterm256ColorCode 97, RGB 135 95 175) + , (Xterm256ColorCode 98, RGB 135 95 215) + , (Xterm256ColorCode 99, RGB 135 95 255) + , (Xterm256ColorCode 100, RGB 135 135 0) + , (Xterm256ColorCode 101, RGB 135 135 95) + , (Xterm256ColorCode 102, RGB 135 135 135) + , (Xterm256ColorCode 103, RGB 135 135 175) + , (Xterm256ColorCode 104, RGB 135 135 215) + , (Xterm256ColorCode 105, RGB 135 135 255) + , (Xterm256ColorCode 106, RGB 135 175 0) + , (Xterm256ColorCode 107, RGB 135 175 95) + , (Xterm256ColorCode 108, RGB 135 175 135) + , (Xterm256ColorCode 109, RGB 135 175 175) + , (Xterm256ColorCode 110, RGB 135 175 215) + , (Xterm256ColorCode 111, RGB 135 175 255) + , (Xterm256ColorCode 112, RGB 135 215 0) + , (Xterm256ColorCode 113, RGB 135 215 95) + , (Xterm256ColorCode 114, RGB 135 215 135) + , (Xterm256ColorCode 115, RGB 135 215 175) + , (Xterm256ColorCode 116, RGB 135 215 215) + , (Xterm256ColorCode 117, RGB 135 215 255) + , (Xterm256ColorCode 118, RGB 135 255 0) + , (Xterm256ColorCode 119, RGB 135 255 95) + , (Xterm256ColorCode 120, RGB 135 255 135) + , (Xterm256ColorCode 121, RGB 135 255 175) + , (Xterm256ColorCode 122, RGB 135 255 215) + , (Xterm256ColorCode 123, RGB 135 255 255) + , (Xterm256ColorCode 124, RGB 175 0 0) + , (Xterm256ColorCode 125, RGB 175 0 95) + , (Xterm256ColorCode 126, RGB 175 0 135) + , (Xterm256ColorCode 127, RGB 175 0 175) + , (Xterm256ColorCode 128, RGB 175 0 215) + , (Xterm256ColorCode 129, RGB 175 0 255) + , (Xterm256ColorCode 130, RGB 175 95 0) + , (Xterm256ColorCode 131, RGB 175 95 95) + , (Xterm256ColorCode 132, RGB 175 95 135) + , (Xterm256ColorCode 133, RGB 175 95 175) + , (Xterm256ColorCode 134, RGB 175 95 215) + , (Xterm256ColorCode 135, RGB 175 95 255) + , (Xterm256ColorCode 136, RGB 175 135 0) + , (Xterm256ColorCode 137, RGB 175 135 95) + , (Xterm256ColorCode 138, RGB 175 135 135) + , (Xterm256ColorCode 139, RGB 175 135 175) + , (Xterm256ColorCode 140, RGB 175 135 215) + , (Xterm256ColorCode 141, RGB 175 135 255) + , (Xterm256ColorCode 142, RGB 175 175 0) + , (Xterm256ColorCode 143, RGB 175 175 95) + , (Xterm256ColorCode 144, RGB 175 175 135) + , (Xterm256ColorCode 145, RGB 175 175 175) + , (Xterm256ColorCode 146, RGB 175 175 215) + , (Xterm256ColorCode 147, RGB 175 175 255) + , (Xterm256ColorCode 148, RGB 175 215 0) + , (Xterm256ColorCode 149, RGB 175 215 95) + , (Xterm256ColorCode 150, RGB 175 215 135) + , (Xterm256ColorCode 151, RGB 175 215 175) + , (Xterm256ColorCode 152, RGB 175 215 215) + , (Xterm256ColorCode 153, RGB 175 215 255) + , (Xterm256ColorCode 154, RGB 175 255 0) + , (Xterm256ColorCode 155, RGB 175 255 95) + , (Xterm256ColorCode 156, RGB 175 255 135) + , (Xterm256ColorCode 157, RGB 175 255 175) + , (Xterm256ColorCode 158, RGB 175 255 215) + , (Xterm256ColorCode 159, RGB 175 255 255) + , (Xterm256ColorCode 160, RGB 215 0 0) + , (Xterm256ColorCode 161, RGB 215 0 95) + , (Xterm256ColorCode 162, RGB 215 0 135) + , (Xterm256ColorCode 163, RGB 215 0 175) + , (Xterm256ColorCode 164, RGB 215 0 215) + , (Xterm256ColorCode 165, RGB 215 0 255) + , (Xterm256ColorCode 166, RGB 215 95 0) + , (Xterm256ColorCode 167, RGB 215 95 95) + , (Xterm256ColorCode 168, RGB 215 95 135) + , (Xterm256ColorCode 169, RGB 215 95 175) + , (Xterm256ColorCode 170, RGB 215 95 215) + , (Xterm256ColorCode 171, RGB 215 95 255) + , (Xterm256ColorCode 172, RGB 215 135 0) + , (Xterm256ColorCode 173, RGB 215 135 95) + , (Xterm256ColorCode 174, RGB 215 135 135) + , (Xterm256ColorCode 175, RGB 215 135 175) + , (Xterm256ColorCode 176, RGB 215 135 215) + , (Xterm256ColorCode 177, RGB 215 135 255) + , (Xterm256ColorCode 178, RGB 215 175 0) + , (Xterm256ColorCode 179, RGB 215 175 95) + , (Xterm256ColorCode 180, RGB 215 175 135) + , (Xterm256ColorCode 181, RGB 215 175 175) + , (Xterm256ColorCode 182, RGB 215 175 215) + , (Xterm256ColorCode 183, RGB 215 175 255) + , (Xterm256ColorCode 184, RGB 215 215 0) + , (Xterm256ColorCode 185, RGB 215 215 95) + , (Xterm256ColorCode 186, RGB 215 215 135) + , (Xterm256ColorCode 187, RGB 215 215 175) + , (Xterm256ColorCode 188, RGB 215 215 215) + , (Xterm256ColorCode 189, RGB 215 215 255) + , (Xterm256ColorCode 190, RGB 215 255 0) + , (Xterm256ColorCode 191, RGB 215 255 95) + , (Xterm256ColorCode 192, RGB 215 255 135) + , (Xterm256ColorCode 193, RGB 215 255 175) + , (Xterm256ColorCode 194, RGB 215 255 215) + , (Xterm256ColorCode 195, RGB 215 255 255) + , (Xterm256ColorCode 196, RGB 255 0 0) + , (Xterm256ColorCode 197, RGB 255 0 95) + , (Xterm256ColorCode 198, RGB 255 0 135) + , (Xterm256ColorCode 199, RGB 255 0 175) + , (Xterm256ColorCode 200, RGB 255 0 215) + , (Xterm256ColorCode 201, RGB 255 0 255) + , (Xterm256ColorCode 202, RGB 255 95 0) + , (Xterm256ColorCode 203, RGB 255 95 95) + , (Xterm256ColorCode 204, RGB 255 95 135) + , (Xterm256ColorCode 205, RGB 255 95 175) + , (Xterm256ColorCode 206, RGB 255 95 215) + , (Xterm256ColorCode 207, RGB 255 95 255) + , (Xterm256ColorCode 208, RGB 255 135 0) + , (Xterm256ColorCode 209, RGB 255 135 95) + , (Xterm256ColorCode 210, RGB 255 135 135) + , (Xterm256ColorCode 211, RGB 255 135 175) + , (Xterm256ColorCode 212, RGB 255 135 215) + , (Xterm256ColorCode 213, RGB 255 135 255) + , (Xterm256ColorCode 214, RGB 255 175 0) + , (Xterm256ColorCode 215, RGB 255 175 95) + , (Xterm256ColorCode 216, RGB 255 175 135) + , (Xterm256ColorCode 217, RGB 255 175 175) + , (Xterm256ColorCode 218, RGB 255 175 215) + , (Xterm256ColorCode 219, RGB 255 175 255) + , (Xterm256ColorCode 220, RGB 255 215 0) + , (Xterm256ColorCode 221, RGB 255 215 95) + , (Xterm256ColorCode 222, RGB 255 215 135) + , (Xterm256ColorCode 223, RGB 255 215 175) + , (Xterm256ColorCode 224, RGB 255 215 215) + , (Xterm256ColorCode 225, RGB 255 215 255) + , (Xterm256ColorCode 226, RGB 255 255 0) + , (Xterm256ColorCode 227, RGB 255 255 95) + , (Xterm256ColorCode 228, RGB 255 255 135) + , (Xterm256ColorCode 229, RGB 255 255 175) + , (Xterm256ColorCode 230, RGB 255 255 215) + , (Xterm256ColorCode 231, RGB 255 255 255) + , (Xterm256ColorCode 0, RGB 0 0 0) -- “system” colors + , (Xterm256ColorCode 1, RGB 128 0 0) + , (Xterm256ColorCode 2, RGB 0 128 0) + , (Xterm256ColorCode 3, RGB 128 128 0) + , (Xterm256ColorCode 4, RGB 0 0 128) + , (Xterm256ColorCode 5, RGB 128 0 128) + , (Xterm256ColorCode 6, RGB 0 128 128) + , (Xterm256ColorCode 7, RGB 192 192 192) + , (Xterm256ColorCode 8, RGB 128 128 128) + , (Xterm256ColorCode 9, RGB 255 0 0) + , (Xterm256ColorCode 10, RGB 0 255 0) + , (Xterm256ColorCode 11, RGB 255 255 0) + , (Xterm256ColorCode 12, RGB 0 0 255) + , (Xterm256ColorCode 13, RGB 255 0 255) + , (Xterm256ColorCode 14, RGB 0 255 255) + , (Xterm256ColorCode 15, RGB 255 255 255) + ] + +instance ToColor Xterm256ColorCode where + toColor = flip lookup ansi256ColorList -- cannot actually fail + +instance ToColor (ANSI.ColorIntensity, ANSI.Color) where + toColor = flip lookup ansi16ColorList -- cannot actually fail + +-- | Warning: this conversion is extremely approximate! +instance FromColor (ANSI.ColorIntensity, ANSI.Color) where + fromColor = findApproximateColor ansi16ColorList + +-- | Warning: this conversion is noticeably approximate! +instance FromColor Xterm256ColorCode where + -- Same algorithm as above + fromColor = findApproximateColor ansi256ColorList + +colorDistance :: Color -> Color -> Int16 +colorDistance (RGB r1 g1 b1) (RGB r2 g2 b2) = abs (fromIntegral r1 - fromIntegral r2) + + abs (fromIntegral g1 - fromIntegral g2) + + abs (fromIntegral b1 - fromIntegral b2) + +-- This is the most naïve possible nearest-neighbor search; +-- it could almost certainly be optimized, if its speed matters at all. +findApproximateColor :: [(a, Color)] -> Color -> a +findApproximateColor acs c = let ranked = map (\ac -> (ac, colorDistance c $ snd ac)) acs + in fst . fst $ minimumBy (comparing snd) ranked diff --git a/src/Types.hs b/src/Types.hs new file mode 100644 --- /dev/null +++ b/src/Types.hs @@ -0,0 +1,93 @@ +module Types + ( -- * Global Types for TUI manipulation + AppS(..) + , OverlayS(..) + -- * Range Ord-like types and helpers + , RangeInAlign(..) + , VertAlign + , WideAlign + , left + , top + ) where + + +-- brick +import Brick.Focus (FocusRing) +import Brick.Types (Extent) +import Brick.Widgets.Edit (Editor) +import Brick.Widgets.List (List) + +-- bytestring +import qualified Data.ByteString.Lazy as Lazy (ByteString) + +-- text +import Data.Text (Text) + +-- http-client +import qualified Network.HTTP.Client as HC + +-- vty +import Graphics.Vty.Image (Image) + +-- internal imports +import HTTP.Client (Header, Method) + +{-| +Application State + +Single URL editor widget. + +Widget names are all 'Text' values. +-} +data AppS = AppS + { focus :: FocusRing Text -- ^ Focus tracking within the main interface. + , methodEditor :: Editor Method Text -- ^ text entry for the HTTP method to use for request + , overlayState :: Maybe OverlayS -- ^ If not Nothing, the overlay is displayed with this state + , urlEditor :: !(Editor String Text) -- ^ text entry for URL to request + , lastResponse :: !Image -- ^ Either the response body, or an error message + , useDefaultHeaders :: Bool -- ^ If False, replace with; otherwise append custom headers + , customHeaders :: [Header] -- ^ additional/replacement request headers + , payload :: Maybe Lazy.ByteString -- ^ just the request body, no content type / filename + , connManager :: HC.Manager -- ^ HTTP connection manager + } + +{-| +State of the UI overlay, which is currently just the "pop-up" for the method selector. +-} +data OverlayS = OverlayS + { methodEditorExtent :: Extent Text -- ^ Where the pop-up should start + , methodList :: List Text Method -- ^ Method selection + } + + +-- | Alignment of one range strictly within another range both over a discete, totally ordered set. +data RangeInAlign + = Min -- ^ min of both ranges match + | MidL -- ^ inner midpoint as close as possible to, but less than or equal to outer midpoint + | MidG -- ^ inner midpoint as close as possible to, but greater than or equal to outer midpoint + | Max -- ^ max of both ranges match + +-- | Vertical alignment +type VertAlign = RangeInAlign + +top{-, centerHigh, centerLow, bottom-} :: VertAlign + +-- | Align at the top, matching min vert corodinates. +top = Min +{- +centerHigh = MidL +centerLow = MidG +bottom = Max +-} + +-- | Wide-ways ("horizonal") alignment +type WideAlign = RangeInAlign +left{-, centerLeft, centerRight, right-} :: VertAlign + +-- | Align on the left, matching min wide coordinates. +left = Min +{- +centerLeft = MidL +centerRight = MidG +right = Max +-} diff --git a/src/UI.hs b/src/UI.hs new file mode 100644 --- /dev/null +++ b/src/UI.hs @@ -0,0 +1,106 @@ +{-# language OverloadedStrings #-} + +module UI + ( startUI + ) where + +-- base +import Data.Maybe (fromMaybe) + +-- brick +import Brick.AttrMap (AttrMap) +import qualified Brick.AttrMap as Brick +import Brick.Focus (focusRing, focusSetCurrent) +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 + ( chooseCursor + , defaultHeadersEditorName + , doRequest + , draw + , handleEvent + , responseBodyViewportName + ) +import Types (AppS(..)) + + +-- | Empty attribute map +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 + } + +{-| +As the poor name implies, not sure what to call the library entry point, or really even what it +should look like at this point. +-} +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 $ initialState manager + Just{} -> doRequest $ initialState manager + _ <- defaultMain app uiState + pure () + where + app = App + { appDraw = draw + , appChooseCursor = chooseCursor + , appHandleEvent = handleEvent + , appStartEvent = pure () + , appAttrMap = attrMap + } + initialState m = AppS + { focus = + focusSetCurrent urlEditorName + $ focusRing [methodEditorName, urlEditorName, defaultHeadersEditorName, responseBodyViewportName] + , methodEditor = editor methodEditorName (Just 1) method + , overlayState = Nothing + , urlEditor = editor urlEditorName (Just 1) (T.unpack $ fromMaybe "" uri) + , lastResponse = emptyImage + , useDefaultHeaders = toEnum $ fromEnum useDefault + , customHeaders = custHeaders + , payload = payloadLbs + , connManager = m + } + methodEditorName = "methodEditor" + urlEditorName = "urlEditor" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"