restman (empty) → 0.7.1.1
raw patch · 13 files changed
+1743/−0 lines, 13 filesdep +ansi-terminal-typesdep +basedep +binarysetup-changed
Dependencies added: ansi-terminal-types, base, binary, brick, bytestring, case-insensitive, containers, http-client, http-client-tls, http-types, lens, microlens, microlens-mtl, mime-types, mtl, optparse-applicative, restman, skylighting, text, text-zipper, unliftio, utf8-string, vector, vty, wreq
Files
- ChangeLog.md +46/−0
- LICENSE +30/−0
- README.md +66/−0
- Setup.hs +2/−0
- app/Main.hs +185/−0
- app/TUI.hs +23/−0
- restman.cabal +92/−0
- src/HTTP/Client.hs +79/−0
- src/Lib.hs +602/−0
- src/Skylighting/Format/Vty.hs +417/−0
- src/Types.hs +93/−0
- src/UI.hs +106/−0
- test/Spec.hs +2/−0
+ ChangeLog.md view
@@ -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
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,66 @@+[](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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -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)
+ app/TUI.hs view
@@ -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)
+ restman.cabal view
@@ -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 <https://gitlab.com/krakrjak/restman#readme>+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
+ src/HTTP/Client.hs view
@@ -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"+ ]
+ src/Lib.hs view
@@ -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+-- * <ScrollUp>: 3 line scroll up+-- * <ScrollDown>: 3 line scroll down+handleResponseBodyViewportEvent :: Event -> EventM Text AppS ()+handleResponseBodyViewportEvent evt =+ case evt of+ EvKey k _mods ->+ case k of+ KDown -> vScrollBy vps 1+ KChar 'j' -> vScrollBy vps 1+ KUp -> vScrollBy vps (-1)+ KChar 'k' -> vScrollBy vps (-1)+ KRight -> hScrollBy vps 1+ KChar 'l' -> hScrollBy vps 1+ KLeft -> hScrollBy vps (-1)+ KChar 'h' -> hScrollBy vps (-1)+ KPageDown -> vScrollPage vps Down+ KPageUp -> vScrollPage vps Up+ _ -> pure () -- ignored+ EvMouseDown _x _y b _mods ->+ case b of+ BScrollUp -> vScrollBy vps (-3)+ BScrollDown -> vScrollBy vps 3+ _ -> pure () -- ignored+ _ -> pure () -- ignored+ where+ vps = viewportScroll responseBodyViewportName++-- | Handle event when focus in on default headers editor and will not change.+handleDefaultHeadersEditorEvent :: Event -> EventM Text AppS ()+handleDefaultHeadersEditorEvent (EvKey (KChar ' ') _) = useDefaultHeadersL %= not+handleDefaultHeadersEditorEvent _ = pure ()++-- | Retrieve extent emitted during last draw and update overlay state.+updateExtent :: EventM Text OverlayS ()+updateExtent = do+ mExtent <- lookupExtent methodEditorExtentName+ for_ mExtent $ \extent ->+ modify $ set methodEditorExtentL extent++{-|+Events for the overlay:+ * [Enter] closes the overlay taking the selected method and updating the application state.+ * Other events are sent to the method selection list.++All code paths should 'updateExtent', in case the pop-up needs to move.+-}+handleEventOverlay :: OverlayS -> Event -> EventM Text AppS ()+handleEventOverlay currentOverlay (EvKey KEnter _) = do -- pick selected method, remove popup+ mSelectedMethod <- fmap snd . nestEventM currentOverlay $ do+ updateExtent+ gets $ fmap snd . listSelectedElement . methodList+ for_ mSelectedMethod $ \method ->+ modify $ set methodL method . set overlayStateL Nothing+handleEventOverlay _currentOverlay e = zoom (overlayStateL . _Just) $ do -- defer to list+ updateExtent+ zoom methodListL (handleListEvent e)++{-|+Construct and issue a wreq request from the application state, handle request failures that are+raised as exceptions in IO, updating the application state ('lastResponse') either from the+response or the execption.+-}+doRequest :: AppS -> IO AppS+doRequest s = do+ result <- tryAnyDeep $ do+ let opts = W.defaults & (W.manager .~ Right (connManager s))+ response <- httpRequest opts . concat . getText . view editContentsL $ urlEditor s+ pure $ syntaxHighlightResponse (pure $ view responseBody response) (responseContentType response)+ pure s{ lastResponse = either exResponse id result }+ where+ updateHeaders AppS{..} = if useDefaultHeaders then (++ customHeaders) else const customHeaders+ httpMethod AppS{..} = concat . getText $ view editContentsL methodEditor+ httpOptions = headers %~ updateHeaders s+ httpRequest opts =+ case payload s of+ Nothing -> customMethodWith (httpMethod s) (httpOptions opts)+ Just lbs -> \url -> customPayloadMethodWith (httpMethod s) (httpOptions opts) url lbs+ exResponse ex = VI.text (VA.Attr VA.Default VA.Default VA.Default VA.Default) $ "[Exception: " <> LText.pack (show ex) <> "]"+ responseContentType resp = fmap LBS.fromStrict $ resp ^? responseHeader "Content-Type"++{- Incoming ByteString for payload has not been pruned of invalid chacaters nor been tab expanded.++ - These operations are required to be compatible with Vty's text rendering. The require removing+ paticular characters like escape, tab, vertical tab, and new lines. The newslines are dealt with as part of the+ -}+syntaxHighlightResponse :: Maybe LBS.ByteString -> Maybe LBS.ByteString -> Image+syntaxHighlightResponse Nothing _ = VI.text (VA.Attr VA.Default VA.Default VA.Default VA.Default) "-- No response body --\n"+syntaxHighlightResponse (Just payload) Nothing = noSyntaxFound $ cleanPayload payload+syntaxHighlightResponse (Just payload) (Just contentType) = case syntaxFromExtension of+ (syn:_) -> highlighted syn $ cleanPayload payload+ [] -> noSyntaxFound $ cleanPayload payload+ where+ syntaxFromExtension = mapMaybe (`lookupSyntax` defaultSyntaxMap) contentTypeToExtensionList+ contentTypeToExtensionList = fromMaybe [] $ Map.lookup mimeType defaultExtensionMap+ mimeType = encodeUtf8 $ Text.takeWhile (/= ';') $ lbsToText contentType+++cleanPayload :: LBS.ByteString -> Text+cleanPayload = expandTabs . cleanText+ where+ cleanText = Text.filter (`notElem` ['\ESC', '\v']) . lbsToText+ expandTabs = Text.replace "\t" " "++highlighted :: Syntax -> Text -> Image+highlighted s t = case tokenize (TokenizerConfig defaultSyntaxMap False) s t of+ Left err -> foldr ((<->) . VI.text (VA.Attr VA.Default VA.Default VA.Default VA.Default))+ VI.emptyImage+ ["-- Syntax highlighting error: ", LText.pack err, " --" , LText.fromStrict t]+ Right sourceLines -> formatVty defaultFormatOpts pygments sourceLines++noSyntaxFound :: Text -> Image+noSyntaxFound payload = foldr+ ((<->) . VI.text (VA.Attr VA.Default VA.Default VA.Default VA.Default))+ VI.emptyImage+ ("--Uknown Body Type --" : map LText.fromStrict (Text.lines payload))++-- Helper function to convert a lazy ByteString to Text in UTF-8 encoding+lbsToText :: LBS.ByteString -> Text+lbsToText = decodeUtf8With lenientDecode . toStrict
+ src/Skylighting/Format/Vty.hs view
@@ -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
+ src/Types.hs view
@@ -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+-}
+ src/UI.hs view
@@ -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"
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"