├── .github └── workflows │ └── haskell.yml ├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── app └── Main.hs ├── cabal.project.local ├── data ├── bookmarks.ini ├── general.ini ├── help.txt ├── homepage.ini ├── open.ini └── theme.ini ├── flake.lock ├── flake.nix ├── package.yaml ├── src ├── Bookmarks.hs ├── BrickApp.hs ├── BrickApp │ ├── Draw.hs │ ├── Draw │ │ ├── Help.hs │ │ ├── Menu.hs │ │ ├── Open.hs │ │ ├── Progress.hs │ │ ├── Save.hs │ │ ├── Search.hs │ │ └── TextFile.hs │ ├── Handle.hs │ ├── Handle │ │ ├── Bookmarks.hs │ │ ├── Goto.hs │ │ ├── Help.hs │ │ ├── Homepage.hs │ │ ├── Menu.hs │ │ ├── Menu │ │ │ ├── Find.hs │ │ │ └── Jump.hs │ │ ├── Open.hs │ │ ├── Progress.hs │ │ ├── Save.hs │ │ ├── Search.hs │ │ └── TextFile.hs │ ├── ModeAction │ │ ├── Bookmarks.hs │ │ ├── Goto.hs │ │ ├── Help.hs │ │ ├── Homepage.hs │ │ ├── Menu.hs │ │ ├── Menu │ │ │ ├── Find.hs │ │ │ ├── Jump.hs │ │ │ └── State.hs │ │ ├── Open.hs │ │ ├── Progress.hs │ │ └── Search.hs │ ├── Types.hs │ ├── Types │ │ ├── Helpers.hs │ │ └── Names.hs │ ├── Utils.hs │ └── Utils │ │ ├── Popup.hs │ │ ├── Style.hs │ │ └── WaffleAddresses.hs ├── Config.hs ├── Config │ ├── Bookmarks.hs │ ├── ConfigOpen.hs │ ├── Homepage.hs │ └── Theme.hs ├── Gopher.hs ├── GopherNet.hs └── Open.hs ├── stack.yaml ├── stack.yaml.lock ├── test └── MyLibTest.hs └── waffle.cabal /.github/workflows/haskell.yml: -------------------------------------------------------------------------------- 1 | name: Haskell CI 2 | 3 | on: 4 | push: 5 | branches: [ master ] 6 | pull_request: 7 | branches: [ master ] 8 | 9 | jobs: 10 | build: 11 | 12 | runs-on: ubuntu-latest 13 | 14 | steps: 15 | - uses: actions/checkout@v2 16 | - uses: actions/setup-haskell@v1 17 | with: 18 | ghc-version: '8.8.3' 19 | cabal-version: '3.2' 20 | 21 | - name: Cache 22 | uses: actions/cache@v1 23 | env: 24 | cache-name: cache-cabal 25 | with: 26 | path: ~/.cabal 27 | key: ${{ runner.os }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }} 28 | restore-keys: | 29 | ${{ runner.os }}-build-${{ env.cache-name }}- 30 | ${{ runner.os }}-build- 31 | ${{ runner.os }}- 32 | 33 | - name: Install dependencies 34 | run: | 35 | cabal update 36 | cabal build --only-dependencies --enable-tests --enable-benchmarks 37 | - name: Build 38 | run: cabal build --enable-tests --enable-benchmarks all 39 | - name: Run tests 40 | run: cabal test all 41 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *~ 3 | dist-newstyle/ 4 | result 5 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog 2 | All notable changes to this project will be documented in this file. This is 3 | mostly for the enduser. 4 | 5 | The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), 6 | and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). 7 | 8 | ## [Unreleased] 9 | 10 | ## [0.24.0] - 2020-12-09 11 | 12 | ### Fix 13 | 14 | * Prevent homepage from being launched during modes where it shouldn't, like 15 | GotoMode and SearchMode 16 | * Allow GotoMode to be launched while viewing bookmarks 17 | 18 | ## [0.23.0] - 2020-11-25 19 | 20 | ### Add 21 | 22 | * Homepage support 23 | * "Ok" and "cancel" buttons for popups 24 | * Bookmark title in bookmark mode 25 | * Support for "waffle addresses" like waffle://bookmarks, waffle://help, and waffle://assocs 26 | 27 | ### Change 28 | 29 | * Replace popup system with Brick's Dialog system 30 | 31 | ### Fix 32 | 33 | * OpenConfigMode (setting associations) menu now less buggy when scrolling 34 | around/tabbing through the fields 35 | * You can no longer keep opening bookmark mode, which might not be noticeable, 36 | except it would keep consuming memory 37 | 38 | ## [0.22.0] - 2020-09-12 39 | 40 | ### Add 41 | 42 | * Saving of menus and text files in gopherspace! 43 | 44 | ## [0.21.0] - 2020-09-12 45 | 46 | ### Add 47 | 48 | * More default bookmarks 49 | 50 | ### Change 51 | 52 | * Under-the-hood: further modularize the bookmark system just a little bit 53 | 54 | ## [0.20.0] - 2020-09-03 55 | 56 | ### Change 57 | 58 | * Rename theme attributes to give a much more readable and intuitive theme/INI 59 | interface 60 | 61 | ## [0.19.0] - 2020-08-24 62 | 63 | ### Add 64 | 65 | * Ability to theme/stylize Waffle through a `~/.config/waffle/theme.ini` 66 | file! 67 | 68 | ## [0.18.0] - 2020-08-14 69 | 70 | ### Fix 71 | 72 | * Issue with menu find and pressing enter to follow a link found 73 | when it's a link to a text file, the find search bar would stay 74 | open in the bottom/status bar 75 | 76 | ## [0.17.0] - 2020-08-14 77 | 78 | ### Add 79 | 80 | * Docs/help for using jump to menu item # 81 | * Titlebar uses display string from links which led the user to the resource 82 | * Refresh feature! Press F5 to reload a text file or a menu! 83 | 84 | ### Change 85 | 86 | * Make it so menu item find is case-insensitive 87 | 88 | ## [0.16.0] - 2020-08-09 89 | 90 | ### Fix 91 | 92 | * Any bookmark which would alphabetically come before `DEFAULT` 93 | would cause reading the bookmarks to crash Waffle. This has 94 | been fixed! 95 | 96 | ## [0.15.0] - 2020-08-05 97 | 98 | ### Add 99 | 100 | * Emojis for `GifFile` and `ImageFile` entries in menus 101 | 102 | ## [0.14.0] - 2020-08-05 103 | 104 | ### Fix 105 | 106 | * Made it so add bookmark could only be activated 107 | if current mode is MenuMode or TextFileMode, 108 | avoiding weird bugs like trying to bookmark 109 | save file screen 110 | 111 | ## [0.13.0] - 2020-08-05 112 | 113 | Menu item finder! 114 | 115 | ### Add 116 | 117 | * Help documentation for menu find 118 | * Menu finder: find a menu item that contains input text 119 | * Utilities for the status bar editor 120 | 121 | ### Fix 122 | 123 | * Use a new `doEventIfModes` to replace `eventDependingMode`, 124 | resolving some issues relating to the fact that some modes 125 | should only be initiated if the current mode matches a 126 | whitelist of modes. Tangibly, this means you will no longer 127 | get stuck, for instance, if you enter goto mode while saving 128 | a file, or in progress mode, etc. 129 | 130 | ### Change 131 | 132 | * Refactor a little bit of `Handle.hs` 133 | 134 | ## [0.12.0] - 2020-08-03 135 | 136 | Bookmarks! 137 | 138 | ### Add 139 | 140 | * Bookmarks are stored in `bookmarks.ini`, but 141 | can also be edited with the TUI using `ctrl` + `b` 142 | * A default set of bookmarks, which will be copied if 143 | ~/.config/waffle/bookmarks.ini doesn't exist 144 | * Bookmark current page with `ctrl` + `p` 145 | * Help instructions for the new bookmark feature 146 | 147 | ### Change 148 | 149 | * Refactor utility code to be more reusable, specifically 150 | making `Menu`s into `MenuBuffer`s 151 | 152 | ## [0.11.0] - 2020-07-22 153 | 154 | Reorganize and clean up the structure of the UI package (the brick app portion)... 155 | This is all under-the-hood stuff. Refactoring. 156 | 157 | ### Change 158 | 159 | * Rename the UI modules to BrickApp since that more accurately describes 160 | their role 161 | * Re-organize UI/BrickApp into these parts: handle (for handling events), 162 | mode action (for manipulating models/types), and types (for models). 163 | Basically the MVC structure. There's also a utils section. 164 | 165 | ### Change 166 | 167 | ## [0.10.1] - 2020-07-17 168 | 169 | ### Fix 170 | 171 | * Network errors resulting in Waffle crashing. Now, instead, 172 | there are error popups for network errors 173 | 174 | ## [0.10.0] - 2020-07-15 175 | 176 | ### Add 177 | 178 | * You can now jump to a link in a menu by typing out the link #! 179 | 180 | ## [0.9.0] - 2020-07-14 181 | 182 | Fix gopher URIs (gophertype) 183 | 184 | In RFC 4266 the path/resource in a Gopher URI has a 185 | "gopheritem" prefix in the format /1/foo/bar (`1` 186 | being the gopheritem). This gopheritem prefix allows 187 | clients to decipher the content the URI points to, 188 | a job usually fulfilled by a menu's item type 189 | (RFC 1436). 190 | 191 | ### Fix 192 | 193 | * Waffle didn't go to the right resource if the resource 194 | in the URI supplied had a gopheritem prefix (RFC 4266). 195 | Now it will both use that gopheritem prefix to decipher 196 | the content and go to the correct resource which excludes 197 | said prefix 198 | 199 | ### Add 200 | 201 | A bit under-the-hood: 202 | 203 | * Implement a function which gets the "gopheritem" 204 | (a single character) from a selector/resource 205 | 206 | ### Change 207 | 208 | Again, a bit under-the-hood: 209 | 210 | * Use these new tools for `GotoMode` and for 211 | the starting location provided when executing 212 | Waffle 213 | * Remove `itemTypeToRenderMode` and `guessMode` 214 | in favor for the new tools used with the new 215 | `selectorToRenderMode` function which will 216 | give a `RenderMode` for the supplied URI. 217 | 218 | ## [0.8.0] - 2020-07-10 219 | 220 | Fixes, error handling, code cleanup/refactoring, and a performance enhancement. 221 | Some under-the-hood refactoring for cleanups. 222 | 223 | ### Add 224 | 225 | * Popups for errors related to `GotoMode` (bad URIs, cannot connect error) 226 | 227 | ### Fix 228 | 229 | * No longer doing static releases due to the standalone crashing a lot for some 230 | reason I'm too lazy ot figure out yet. 231 | * Errors related to `GotoMode` which would crash Waffle, like malformed URIs, 232 | nonresponsive servers, etc. 233 | * Inability to goto URIs that include a port specification due to `read` error 234 | * Extreme performance issues when viewing large text files; now viewing very large 235 | 236 | ## [0.7.0] - 2020-07-04 237 | 238 | Bug fixes regarding re-entering modes, popup notification for saving config. 239 | 240 | ### Add 241 | 242 | * Popup notifying of saved configuration changes for open config mode 243 | 244 | ### Fix 245 | 246 | * Prevent open config mode being relaunched while already in open config 247 | mode 248 | * Prevent goto mode being relaunched while already in goto mode 249 | * Prevent help mode from being relaunched while already in help mode 250 | 251 | ### Change 252 | 253 | * A bit under-the-hood, but now `esc` is the universal popup 254 | closer key 255 | 256 | ## [0.6.0] - 2020-07-03 257 | 258 | Changes for static builds. 259 | 260 | ### Change 261 | 262 | * Replace uses of `Paths_` library to use `file-embed`, so static builds can be 263 | packaged/archived with just the binary and no other files 264 | * Cabal project config for static building 265 | 266 | ## [0.5.0] - 2020-06-28 267 | 268 | Introduce the ability to open Gopher menu items with an external application 269 | by associating commands with specific item types. 270 | 271 | ### Add 272 | 273 | * General configuration infrastructure for managing Waffle's current 274 | `open.ini` configuration, as well as future configurations, all residing 275 | in `~/.config/waffle/` 276 | * Default `open.ini` in `data/` 277 | * UI for editing which command opens an item type (ctrl+c to bring up UI, 278 | ctrl+s to save changes), which manipulates the corresponding config stored 279 | at `~/.config/waffle/open.ini` 280 | * Instructions in the help screen for the new open feature 281 | * Introduce `AnyName` which is a Brick name that encompasses *all* names as 282 | a "sum type" 283 | * A progress handler (`initOpenMode`, `progressOpen`) for downloading and 284 | then opening the download with the associated command 285 | * Open certain menu items with a command using ctrl+o 286 | * Representations for open config stuff, including helper functions 287 | 288 | ### Change 289 | 290 | * Pretty much all instances of `MyName` to use the new `AnyName` (which `MyName` 291 | is now a constructor of) 292 | 293 | ## [0.4.0] - 2020-05-31 294 | 295 | This release is just a little bit of cleanup and fixes. 296 | 297 | ### Add 298 | 299 | * `newMenuBuffer` and `getMenu` to assist in handling `Menu` directly 300 | instead of passing around `GopherBrowserState`. 301 | * Pedantic-style warnings (`-Wall` and `-Werror`) to ghc build options 302 | in cabal config 303 | * Make it so moving a line down/up will wrap to the be beggining or end 304 | of the list 305 | 306 | ### Change 307 | 308 | * Reduce redundancy by making `updateMenuList` a top level function 309 | * Loosely couple `jumpNextLink`, `jumpPrevLink`, `listDrawElement`, 310 | and `selectedMenuLine` so they both only need `Menu` instead of 311 | `GopherBrowserState`. 312 | 313 | ### Fix 314 | 315 | * Refactor `jumpNextLink` and `jumpPrevLink` to be safe. Otherwise, moving 316 | to next or previous link would crash Waffle on menus (waffle: Prelude.head: empty list) 317 | where there were no links, such as gopher://sdf.org:70/users/raoeupb/. This also covers a 318 | situation where a line, for whatever reason, might not be selected, and 319 | thus would cause an error. 320 | 321 | ## [0.3.0] - 2020-05-17 322 | 323 | This release is preparing for uploading to Hackage. On the non-code 324 | side we switch from Stack to Cabal and start using GitHub actions. 325 | 326 | ### Add 327 | 328 | * Tests, namely doctests 329 | 330 | ### Fix 331 | 332 | * Fix going up a directory, which in some cases could result 333 | in new history with the same page. 334 | 335 | * Fix get parent directory which in some edge cases would 336 | return the same path as it was given. Also fix the leading/root 337 | slash being omitted in all cases. Simply start using System.FilePath 338 | to get the parent directory in a path. 339 | 340 | ## [0.2.0] - 2020-05-09 341 | 342 | This release is dedicated to Adrian Cochrane's 343 | [Rhapsode](https://rhapsode.adrian.geek.nz/), as these features were requested, 344 | which also happened to benefit this project as well. 345 | 346 | Interpret Gopher URI item types based on their selector/path. 347 | 348 | Bonus: make everything align nicely by simply putting item type descriptors in 349 | gophermaps/menus at the end of the line. 350 | 351 | ### Add 352 | 353 | The high level: 354 | 355 | * Item type guessing based on selector, allowing you to goto and startup URIs that require 356 | any RenderMode (namely: text files, menus, downloads). 357 | 358 | The nitty-gritty: 359 | 360 | * `GopherNet.hs`: modularize things further by starting a networking module, 361 | which `writeAllBytes` was moved to. 362 | * ItemType type, which unifies both canonical and noncanonical item types 363 | * `selectorExtToItemType` for determining an item type based off of a selector's 364 | file extension 365 | * `selectorPrefixItemType` for determining an item type based off a selector's prefix 366 | according to RFC 4266. 367 | * `selectorItemType` for determining a selector's item type by first preferring 368 | to use RFC 4266, but if that fails determine based off of file extension (using the two 369 | functions named above). 370 | * `counterMutator` for the new higher order version of the `writeAllBytes` function. 371 | 372 | ### Fix 373 | 374 | The high level: 375 | 376 | * Goto breaking if not going to a menu/gophermap as URI destination 377 | * Startup args breaking if not specifying a gophermap as URI destination 378 | 379 | ### Change 380 | 381 | The nitty-gritty: 382 | 383 | * All `Either GopherCanonicalItemType GopherNonCanonicalItemType` instances to 384 | simply use the new `ItemType` type. 385 | * `writeAllBytes` to be agnostic of UI stuff; made into a higher order function. 386 | 387 | ## [0.1.0] - 2020-05-03 388 | 389 | This is the first release. It is in alpha. All the basic features required to browse Gopherspace! 390 | 391 | See [the GitHub milestone for this release](https://github.com/hyperreal-gopher/waffle/milestone/1?closed=1)! 392 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # 🧇 Waffle: Haskell Gopher Protocol Client 2 | 3 | Both _gopher_ and _waffle_ in French is "gaufre:" 4 | 5 | > The origin of the word 'gopher' is uncertain; French gaufre, meaning 6 | > 'waffle', has been suggested, on account of the gopher tunnels resembling the 7 | > honeycomb-like pattern of holes in a waffle… 8 | 9 | —"Gopher," Wikipedia. 10 | 11 | Waffle is a [Gopher 12 | protocol](https://en.wikipedia.org/wiki/Gopher_%28protocol%29) client with a 13 | text interface written in Haskell, implemented according to [RFC 14 | 1436](https://tools.ietf.org/html/rfc1436) technical specification. 15 | 16 | You can build and run with `nix`, like `nix build` and `nix run`. 17 | 18 | ## Alpha 19 | 20 | This is a project in alpha. It is not fully functional. It is currently a demo. 21 | This is a project that is helping me learn a few things, namely Haskell, but I 22 | intend to make this a really good Gopher client. I got the idea to make a 23 | Gopher client because the default `gopher` client in Ubuntu was lacking and I 24 | wanted to provide fixes and improvements. 25 | 26 | Special thanks to @Garmelon for mentoring me through all of this. 27 | 28 | ## Try it out! 29 | 30 | Compile it with `cabal build` and then try it out with `cabal run waffle 31 | sdf.org 70 phlogs`. I compiled with GHC 8.10.7. 32 | 33 | Press `?` while using the browser for full details on using it! 34 | 35 | ## Built with 36 | 37 | * Cabal 3 38 | * Brick 39 | 40 | ## Tests 41 | 42 | Tests are currently just 43 | [doctest](https://hackage.haskell.org/package/doctest), but you can run with 44 | `cabal test`. 45 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified Data.Text as T 4 | import System.Environment 5 | 6 | import BrickApp 7 | import Config 8 | import Config.ConfigOpen 9 | import Config.Bookmarks 10 | import Config.Homepage 11 | import Config.Theme 12 | 13 | handleArgs :: [String] -> IO () 14 | handleArgs [] = uiMain Nothing 15 | handleArgs (host:port:resource:[]) = uiMain (Just (T.pack host, read port :: Int, T.pack resource)) 16 | handleArgs (_) = error "Error! Need to supply host, port, and selector (or no args!). For empty selector you can use \"\"." 17 | 18 | main :: IO () 19 | main = do 20 | -- First do config file check 21 | -- FIXME: hacky doing setup here... 22 | -- maybe could have a cli option to reset even 23 | setupConfigDirectory 24 | setupDefaultOpenConfig 25 | setupDefaultBookmarks 26 | setupDefaultHomepageConfig 27 | setupDefaultTheme 28 | -- Now run! 29 | args <- getArgs 30 | handleArgs args 31 | -------------------------------------------------------------------------------- /cabal.project.local: -------------------------------------------------------------------------------- 1 | tests: True 2 | -------------------------------------------------------------------------------- /data/bookmarks.ini: -------------------------------------------------------------------------------- 1 | [SDF Phlogs] 2 | host=sdf.org 3 | resource=phlogs/ 4 | type=1 5 | port=70 6 | 7 | [Floodgap] 8 | host=floodgap.com 9 | resource=/ 10 | type=1 11 | port=70 12 | 13 | [Mozz.us - Hand Crafted Experiences] 14 | host=mozz.us 15 | port=70 16 | resource=/ 17 | type=1 18 | 19 | [World of Solitaire] 20 | host=worldofsolitaire.com 21 | resource=/ 22 | port=70 23 | type=1 24 | -------------------------------------------------------------------------------- /data/general.ini: -------------------------------------------------------------------------------- 1 | # General setings 2 | 3 | [homepage] 4 | uri=gopher://sdf.org:70/1/phlogs 5 | -------------------------------------------------------------------------------- /data/help.txt: -------------------------------------------------------------------------------- 1 | _.-------._ 2 | .' _|_|_|_|_ '. 3 | / _|_|_|_|_|_|_ \ 4 | | |_|_|_|_|_|_|_| | 5 | |_|_|_|_|_|_|_|_|_| 6 | | |_|_|_|_| | |_| | _ ___ ___ _ 7 | | |_|_|_|_|( ) _ ( ) /'___)/'___)(_ ) 8 | \ -|_|_|_|| | ( ) | | _ _ | (__ | (__ | | __ 9 | '. -|_|_|| | | | | | /'_` )| ,__)| ,__) | | /'__`\ 10 | `------| (_/ \_) |( (_| || | | | | | ( ___/ 11 | `\___x___/'`\__,_)(_) (_) (___)`\____) 12 | 13 | 🧇 Waffle Gopher Protocol Browser 14 | Thanks to jgs for the Waffle ASCII on ascii.co.uk 15 | 16 | Press ESC to close. 17 | 18 | MOVING THE CURSOR & SCROLLING: `j` (down), `k` (up), `h` (left), `l` (right). 19 | `page down` and `page up` moves page up and page down. `g` and `home` goes to 20 | beginning. `G` and `end` goes to end. To jump between menu links in menu mode 21 | use `p` (previous link) and `n` (next link). 22 | 23 | OPEN MENU ITEM: press 'o' to open the currently selected menu item with 24 | an associated external program. You can edit the assocations with 25 | ctrl + c for a UI or edit the config/INI directly at 26 | `~/.config/waffle/open.ini`. 27 | 28 | REFRESH A MENU OR TEXT FILE: press F5 to delete the current text file/menu's 29 | cache and reload the resource. 30 | 31 | GET INFO ON CURRENTLY SELECTED LINE: in menu/map mode, with `i`. 32 | 33 | SEARCH FOR MENU ITEM: Press `/` to start searching for a bit 34 | of text to be found somewhere after the currently selected 35 | menu line. Press `ctrl` + `n` to jump to next item. Press 36 | `enter` to follow the currently selected menu item. Press 37 | `esc` to exit search mode. The search does not wrap. 38 | 39 | JUMP TO A MENU ITEM: Simply start typing a number and the menu 40 | item selected will correspond to the number you have typed. 41 | You can press `Enter` to follow the menu item, or hit `esc`, 42 | or anything not a number, to leave this mode. 43 | 44 | QUIT WAFFLE: ctrl+q. 45 | 46 | GOTO URI: open a Gopherspace by specifying a Gopher URI with `ctrl` + `g`. 47 | 48 | WHEN SAVING A FILE: enter to choose a directory, `n` to start typing a file 49 | name to save as--use the `enter` key to accept the filename. 50 | 51 | DURING SEARCH MODE: type your query then hit `enter`. Be patient. 52 | 53 | BOOKMARKS: On any page use `+` to add the current page as a bookmark, you'll 54 | be asked to (optionally) provide a bookmark display string. To view bookmarks 55 | use `ctrl` + `b`. When viewing bookmarks you can delete the selected bookmark 56 | with `d`. Bookmark view works the same as any Gopher menu. 57 | 58 | TOR: You can browse Gopherspace using Tor, even visit hidden services like 59 | gopher://bztf2mno3tpwrqop.onion:70/1/ if you just start Waffle with `torsocks`, 60 | for example: `torsocks waffle`. 61 | 62 | HOMEPAGE: set the homepage with `ctrl` + `z`. Go home with `h`. You can 63 | also edit `~/.config/waffle/homepage.ini`. 64 | -------------------------------------------------------------------------------- /data/homepage.ini: -------------------------------------------------------------------------------- 1 | [homepage] 2 | uri=waffle://bookmarks 3 | display=Bookmarks 4 | -------------------------------------------------------------------------------- /data/open.ini: -------------------------------------------------------------------------------- 1 | # Associations between Gopher menu item types and their associated 2 | # commands to open downloaded content with. 3 | 4 | # If you have any issues you can delete this file and it will be 5 | # recreated. 6 | 7 | # FIXME: could even separate by canon and noncanon 8 | 9 | [DEFAULT] 10 | File=xdg-open 11 | Directory=xdg-open 12 | CsoPhoneBookServer=xdg-open 13 | Error=xdg-open 14 | BinHexedMacintoshFile=xdg-open 15 | DosBinaryArchive=xdg-open 16 | UnixUuencodedFile=xdg-open 17 | IndexSearchServer=xdg-open 18 | TextBasedTelnetSession=xdg-open 19 | BinaryFile=xdg-open 20 | RedundantServer=xdg-open 21 | GifFile=xdg-open 22 | ImageFile=xdg-open 23 | Tn3270Session=xdg-open 24 | Doc=xdg-open 25 | HtmlFile=xdg-open 26 | InformationalMessage=xdg-open 27 | SoundFile=xdg-open 28 | -------------------------------------------------------------------------------- /data/theme.ini: -------------------------------------------------------------------------------- 1 | # FIXME: better names! 2 | # TODO: add button style 3 | 4 | # Waffle theme 5 | # 6 | # Please see: 7 | # https://hackage.haskell.org/package/brick-0.55/docs/Brick-Themes.html 8 | # 9 | # COLOR SPECIFICATION 10 | # 11 | # A color specification can be any of the strings black, red, green, yellow, 12 | # blue, magenta, cyan, white, brightBlack, brightRed, brightGreen, 13 | # brightYellow, brightBlue, brightMagenta, brightCyan, brightWhite, or default. 14 | # 15 | # We also support color specifications in the common hex format #RRGGBB, but 16 | # note that this specification is lossy: terminals can only display 256 colors, 17 | # but hex codes can specify 256^3 = 16777216 colors. 18 | # 19 | # STYLE SPECIFICATION 20 | # 21 | # A style specification can be either one of the following values (without 22 | # quotes) or a comma-delimited list of one or more of the following values 23 | # (e.g. "[bold,underline]") indicating that all of the specified styles be 24 | # used. Valid styles are standout, underline, reverseVideo, blink, dim, italic, 25 | # and bold. 26 | 27 | # The default background, foreground, and style. 28 | [default] 29 | default.fg = #cccccc 30 | default.bg = #000000 31 | ;default.style="" 32 | 33 | # The other section specifies for each attribute name in the theme the same fg, 34 | # bg, and style settings as for the default attribute. Furthermore, if an 35 | # attribute name has multiple components, the fields in the INI file should use 36 | # periods as delimiters. For example, if a theme has an attribute name ("foo" 37 | # <> "bar"), then the file may specify three fields: 38 | # 39 | # foo.bar.fg - a color specification 40 | # foo.bar.bg - a color specification 41 | # foo.bar.style - a style specification 42 | # 43 | # Any color or style specifications omitted from the file mean that those 44 | # attribute or style settings will use the theme's default value instead. 45 | # 46 | # Attribute names with multiple components (e.g. attr1 <> attr2) can be 47 | # referenced in customization files by separating the names with a dot. For 48 | # example, the attribute name "list" <> "selected" can be referenced by using 49 | # the string "list.selected". 50 | [other] 51 | # GENERAL THEME 52 | 53 | ; Menu lists and save lists, all lists in general 54 | list.fg=white 55 | list.bg=#000000 56 | 57 | ; The currently selected menu item! Style and background can be set, but 58 | ; fg/foreground seems to be overriden by something else/not do anything. 59 | ; 60 | ; I need to read about how <> works in Brick to understand "extending" attributes! 61 | list.selected.style=bold 62 | 63 | ; Title bar; the current view's label/title 64 | titleAttr.style=[reverseVideo,bold] 65 | titleAttr.fg=white 66 | 67 | # EDITOR FIELDS 68 | # Input fields you can type into. 69 | 70 | ; A regular input field that isn't focused. 71 | edit.fg=white 72 | edit.bg=brightBlack 73 | 74 | ; An input field which has focus. 75 | edit.focused.fg=white 76 | edit.focused.bg=brightBlack 77 | edit.focused.style=bold 78 | 79 | # MENU ITEM TYPE DESCRIPTORS 80 | # Describes the menu item type 81 | 82 | ; For the directory line descriptor in menu mode. 83 | ; Links to other menus. 84 | menu.line.itemDesc.directory.fg=#ff0000 85 | 86 | ; Index search server item line descriptors in menu mode. 87 | ; Links to index search servers. 88 | menu.line.itemDesc.indexSearchServer.fg=magenta 89 | 90 | ; Plaintext file line item descriptor in menu mode. 91 | ; Links to a plaintext file. 92 | menu.line.itemDesc.file.fg=cyan 93 | 94 | ; Catchall style for all other line descriptors. 95 | menu.line.itemDesc.generic.fg=green 96 | 97 | # MENU STUFF 98 | # General menu theming. 99 | 100 | ; Info lines in menu mode which are currently selected 101 | menu.line.info.selected.fg=white 102 | 103 | ; The currently selected item's display string (if it's a proper menu line 104 | ; and not an info line) 105 | menu.line.selected.style=bold 106 | menu.line.selected.fg=white 107 | 108 | ; This is for the current line cursor/indicator in menu mode 109 | menu.asterisk.fg=white 110 | 111 | ; Informational text line 112 | menu.line.info.fg=#ffff00 113 | 114 | ; Numbers which prefix each menu link which can be followed/opened 115 | menu.numberPrefix.fg=#FC28FE 116 | 117 | ; The color of the display string part of a menu item that is a 118 | ; followable link 119 | menu.line.linkString.fg=#1C98FF 120 | 121 | # INPUT POPUP 122 | # I think this is only used for index search. The popup dialog 123 | # which asks for input in order to complete a search. 124 | 125 | ; The title of an input title. 126 | popup.label.style=[reverseVideo,bold] 127 | popup.label.fg=yellow 128 | 129 | # FILE BROWSER 130 | # This is seen/used for saving files. 131 | 132 | ; The file browser's current directory 133 | fileBrowser.CurrentDirectory.fg=white 134 | fileBrowser.CurrentDirectory.bg=blue 135 | 136 | ; for the uh... selection... info...? FIXME 137 | fileBrowser.SelectionInfo.fg=white 138 | fileBrowser.SelectionInfo.bg=blue 139 | 140 | ; File browser directory lines/entries 141 | fileBrowser.Directory.fg=blue 142 | 143 | ; File browser block device listing 144 | fileBrowser.BlockDevice.fg=magenta 145 | 146 | ; file browser character device 147 | fileBrowser.CharacterDevice.fg=green 148 | 149 | ; file browser named pipe 150 | fileBrowser.NamedPipe.fg=yellow 151 | 152 | ; symbolic link listing in file browser 153 | fileBrowser.SymbolicLink.fg=cyan 154 | 155 | ; unix socket file browser listing 156 | fileBrowser.UnixSocket.fg=red 157 | 158 | ; selected item in file browser 159 | fileBrowser.Selected.fg=white 160 | fileBrowser.Selected.bg=magenta 161 | 162 | ; File browser errors 163 | ; This API is subject to change. 164 | error.fg=red 165 | 166 | # STUFF THAT ISN'T WORKING RIGHT 167 | # Stuff that I have to go over and fix... 168 | 169 | ; should be the theme of the input popup's contents, but doesn't 170 | ; seem to *actually* do anything at all! 171 | ;inputDialogAttr.fg=#FFFF00 172 | ;inputDialogAttr.bg=#000000 173 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "flake-parts": { 4 | "inputs": { 5 | "nixpkgs-lib": "nixpkgs-lib" 6 | }, 7 | "locked": { 8 | "lastModified": 1709336216, 9 | "narHash": "sha256-Dt/wOWeW6Sqm11Yh+2+t0dfEWxoMxGBvv3JpIocFl9E=", 10 | "owner": "hercules-ci", 11 | "repo": "flake-parts", 12 | "rev": "f7b3c975cf067e56e7cda6cb098ebe3fb4d74ca2", 13 | "type": "github" 14 | }, 15 | "original": { 16 | "owner": "hercules-ci", 17 | "repo": "flake-parts", 18 | "type": "github" 19 | } 20 | }, 21 | "haskell-flake": { 22 | "locked": { 23 | "lastModified": 1710420065, 24 | "narHash": "sha256-0ohPtOIlCuWPr1CHDVdlcCXGxsJ841g/Z6RJkuICII8=", 25 | "owner": "srid", 26 | "repo": "haskell-flake", 27 | "rev": "10c49135759d45f1e2619b0321d7ad8a90ccf7c1", 28 | "type": "github" 29 | }, 30 | "original": { 31 | "owner": "srid", 32 | "repo": "haskell-flake", 33 | "type": "github" 34 | } 35 | }, 36 | "nixpkgs": { 37 | "locked": { 38 | "lastModified": 1688392541, 39 | "narHash": "sha256-lHrKvEkCPTUO+7tPfjIcb7Trk6k31rz18vkyqmkeJfY=", 40 | "owner": "nixos", 41 | "repo": "nixpkgs", 42 | "rev": "ea4c80b39be4c09702b0cb3b42eab59e2ba4f24b", 43 | "type": "github" 44 | }, 45 | "original": { 46 | "owner": "nixos", 47 | "ref": "nixos-22.11", 48 | "repo": "nixpkgs", 49 | "type": "github" 50 | } 51 | }, 52 | "nixpkgs-lib": { 53 | "locked": { 54 | "dir": "lib", 55 | "lastModified": 1709237383, 56 | "narHash": "sha256-cy6ArO4k5qTx+l5o+0mL9f5fa86tYUX3ozE1S+Txlds=", 57 | "owner": "NixOS", 58 | "repo": "nixpkgs", 59 | "rev": "1536926ef5621b09bba54035ae2bb6d806d72ac8", 60 | "type": "github" 61 | }, 62 | "original": { 63 | "dir": "lib", 64 | "owner": "NixOS", 65 | "ref": "nixos-unstable", 66 | "repo": "nixpkgs", 67 | "type": "github" 68 | } 69 | }, 70 | "root": { 71 | "inputs": { 72 | "flake-parts": "flake-parts", 73 | "haskell-flake": "haskell-flake", 74 | "nixpkgs": "nixpkgs" 75 | } 76 | } 77 | }, 78 | "root": "root", 79 | "version": 7 80 | } 81 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | inputs = { 3 | nixpkgs.url = "github:nixos/nixpkgs/nixos-22.11"; 4 | flake-parts.url = "github:hercules-ci/flake-parts"; 5 | haskell-flake.url = "github:srid/haskell-flake"; 6 | }; 7 | outputs = inputs@{ self, nixpkgs, flake-parts, ... }: 8 | flake-parts.lib.mkFlake { inherit inputs; } { 9 | systems = nixpkgs.lib.systems.flakeExposed; 10 | imports = [ inputs.haskell-flake.flakeModule ]; 11 | 12 | perSystem = { self', pkgs, ... }: { 13 | 14 | # Typically, you just want a single project named "default". But 15 | # multiple projects are also possible, each using different GHC version. 16 | haskellProjects.default = { 17 | # The base package set representing a specific GHC version. 18 | # By default, this is pkgs.haskellPackages. 19 | # You may also create your own. See https://community.flake.parts/haskell-flake/package-set 20 | basePackages = pkgs.haskell.packages.ghc88; 21 | 22 | # Extra package information. See https://community.flake.parts/haskell-flake/dependency 23 | # 24 | # Note that local packages are automatically included in `packages` 25 | # (defined by `defaults.packages` option). 26 | # 27 | packages = { 28 | # aeson.source = "1.5.0.0"; # Hackage version override 29 | # shower.source = inputs.shower; 30 | }; 31 | settings = { 32 | # aeson = { 33 | # check = false; 34 | # }; 35 | # relude = { 36 | # haddock = false; 37 | # broken = false; 38 | # }; 39 | }; 40 | 41 | devShell = { 42 | # Enabled by default 43 | # enable = true; 44 | 45 | # Programs you want to make available in the shell. 46 | # Default programs can be disabled by setting to 'null' 47 | # tools = hp: { fourmolu = hp.fourmolu; ghcid = null; }; 48 | 49 | hlsCheck.enable = pkgs.stdenv.isDarwin; # On darwin, sandbox is disabled, so HLS can use the network. 50 | }; 51 | }; 52 | 53 | # haskell-flake doesn't set the default package, but you can do it here. 54 | packages.default = self'.packages.waffle; 55 | }; 56 | }; 57 | } 58 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: waffle 2 | version: 0.1.0.0 3 | 4 | license: GPL 5 | description: Please see the README on GitHub at 6 | github: "hyperreal-gopher/waffle" 7 | 8 | ## These fields might be useful to fill out in the future 9 | # author: 10 | # copyright: 11 | # synopsis: 12 | 13 | dependencies: 14 | - base >= 4.7 && < 5 15 | - brick 16 | - text 17 | - bytestring 18 | - microlens 19 | - open-browser 20 | - utf8-string 21 | - directory 22 | - filepath 23 | - temporary 24 | - containers 25 | - vector 26 | - network-simple 27 | - split 28 | - vty 29 | - network-uri 30 | 31 | data-files: data/help.txt 32 | 33 | library: 34 | source-dirs: src 35 | 36 | executables: 37 | waffle: 38 | source-dirs: app 39 | main: Main.hs 40 | ghc-options: 41 | - -threaded 42 | - -rtsopts 43 | - -with-rtsopts=-N 44 | dependencies: 45 | - waffle 46 | -------------------------------------------------------------------------------- /src/Bookmarks.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Bookmarks ( bookmarksMenuText ) where 4 | 5 | import qualified Data.Text as T 6 | import qualified Data.Map as Map 7 | import Data.List ( intercalate ) 8 | 9 | import qualified Data.ConfigFile as CF 10 | import qualified Data.ConfigFile.Types as CFT 11 | 12 | import Config.Bookmarks 13 | 14 | -- | Converts the user's bookmarks.ini into a Gophermenu `Text` which can be parsed 15 | -- into an actual `Menu`. This is to make it so the user's bookmarks can be represented 16 | -- as a Gopher menu. 17 | bookmarksMenuText :: IO T.Text 18 | bookmarksMenuText = do 19 | cp <- getUserBookmarks 20 | -- It is noted in Data.ConfigFile to not do this 21 | let sectionOptionsList = filter (\x -> fst x /= "DEFAULT") $ Map.toList $ CF.content cp -- this skips DEFAULT 22 | menuLines = map entryToMenuItemText sectionOptionsList 23 | pure $ T.intercalate "\n" menuLines 24 | where 25 | -- FIXME: do left/right error thing 26 | entryToMenuItemText :: (CF.SectionSpec, CFT.CPOptions) -> T.Text 27 | entryToMenuItemText (sectionString, options) = 28 | let label = sectionString 29 | host = 30 | case Map.lookup "host" options of 31 | Just h -> h 32 | Nothing -> error "Parse bookmark error: no host" 33 | resource = 34 | case Map.lookup "resource" options of 35 | Just r -> r 36 | Nothing -> error "Parse bookmark error: no resource" 37 | gophertype = 38 | case Map.lookup "type" options of 39 | Just gt -> gt 40 | Nothing -> error "Parse bookmark error: no gophertype" 41 | port = 42 | case Map.lookup "port" options of 43 | Just p -> p 44 | Nothing -> error "Parse bookmark error: no port!" 45 | in T.pack $ intercalate "\t" [gophertype ++ label, resource, host, port] 46 | -------------------------------------------------------------------------------- /src/BrickApp.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- | Stitch together the Brick app from the disparate parts of the UI. 4 | -- 5 | -- The UI module and its child modules are all about `Brick` stuff. 6 | module BrickApp 7 | ( uiMain 8 | ) 9 | where 10 | 11 | 12 | import qualified Data.Text as T 13 | import Data.Maybe 14 | import Control.Monad ( void ) 15 | 16 | import qualified Brick.BChan as B 17 | import qualified Brick.Main as B 18 | import qualified Graphics.Vty as V 19 | import Brick.Widgets.Core ( txt ) 20 | 21 | import BrickApp.ModeAction.Homepage ( goHome ) 22 | import BrickApp.Types 23 | import BrickApp.Types.Names 24 | import BrickApp.Utils 25 | import BrickApp.Draw 26 | import BrickApp.Handle 27 | import BrickApp.ModeAction.Progress 28 | import BrickApp.Utils.Style 29 | 30 | theApp :: B.App GopherBrowserState CustomEvent AnyName 31 | theApp = B.App { B.appDraw = drawUI 32 | , B.appChooseCursor = B.showFirstCursor 33 | , B.appHandleEvent = appEvent 34 | , B.appStartEvent = return 35 | , B.appAttrMap = const theMap 36 | } 37 | 38 | -- | Start the Brick app at a specific Gopher menu in Gopherspace. 39 | uiMain :: Maybe (T.Text, Int, T.Text) -> IO () 40 | uiMain possibleLocation = do 41 | eventChan <- B.newBChan 10 42 | let buildVty = V.mkVty V.defaultConfig 43 | initialVty <- buildVty 44 | 45 | let dummyStateToOverride = GopherBrowserState { 46 | gbsBuffer = TextFileBuffer $ TextFile 47 | { tfContents = txt "" 48 | , tfTitle = "" 49 | } 50 | , gbsLocation = ("", 0, "", TextFileMode, Nothing) 51 | , gbsRenderMode = TextFileMode 52 | , gbsHistory = ([], -1) 53 | , gbsChan = eventChan 54 | , gbsPopup = Nothing 55 | , gbsCache = emptyCache 56 | , gbsStatus = Nothing 57 | } 58 | 59 | initialState <- if null possibleLocation then do 60 | -- if we didn't get a location passed to us, then we want to 61 | -- start with the home page from the config! 62 | goHome dummyStateToOverride 63 | else 64 | -- ...otherwise let's open the page supplied! 65 | let (host, port, magicString) = fromJust possibleLocation 66 | trueLocationType = (host, port, magicString, selectorToRenderMode magicString, Nothing) 67 | -- FIXME: what a horrible hack to produce a beginning state in order 68 | -- to use initProgressMode! Especially the buffer part... 69 | history = ([trueLocationType], 0) 70 | initialGbs = dummyStateToOverride 71 | { gbsBuffer = TextFileBuffer $ TextFile 72 | { tfContents = txt "" 73 | , tfTitle = "" 74 | } 75 | , gbsLocation = trueLocationType 76 | , gbsRenderMode = selectorToRenderMode magicString 77 | , gbsHistory = history 78 | } 79 | in initProgressMode initialGbs (Just history) trueLocationType 80 | 81 | theme <- getTheme 82 | void $ B.customMain initialVty buildVty (Just eventChan) (theApp {B.appAttrMap=const theme}) initialState 83 | -------------------------------------------------------------------------------- /src/BrickApp/Draw.hs: -------------------------------------------------------------------------------- 1 | -- | Functions for actually drawing the application state according to the current 2 | -- `RenderMode`, which is used by this Brick application's `Brick.Main.appDraw`. 3 | module BrickApp.Draw where 4 | 5 | import Data.Maybe 6 | 7 | import Brick.Types as B 8 | 9 | import BrickApp.Draw.Open ( openConfigModeUI ) 10 | import BrickApp.Types 11 | import BrickApp.Types.Names 12 | import BrickApp.Draw.Menu 13 | import BrickApp.Draw.Help 14 | import BrickApp.Draw.Save 15 | import BrickApp.Draw.Search 16 | import BrickApp.Draw.TextFile 17 | import BrickApp.Draw.Progress 18 | 19 | -- | The draw handler which will choose a UI based on the browser's mode. 20 | -- | Picks a UI/draw function based on the current gbsRenderMode. 21 | -- 22 | -- Used as Brick.Main.appDraw when constructing the Brick app. 23 | drawUI :: GopherBrowserState -> [B.Widget AnyName] 24 | drawUI gbs = modeUI $ gbsRenderMode gbs 25 | where 26 | modeUI mode = case mode of 27 | MenuMode -> menuModeUI gbs 28 | TextFileMode -> textFileModeUI gbs 29 | HelpMode -> helpModeUI gbs 30 | FileBrowserMode -> fileBrowserUi gbs 31 | SearchMode -> searchInputUI gbs 32 | ProgressMode -> drawProgressUI gbs 33 | GotoMode -> modeUI (seFormerMode $ fromJust $ gbsStatus gbs) 34 | MenuJumpMode -> modeUI (seFormerMode $ fromJust $ gbsStatus gbs) 35 | OpenConfigMode -> openConfigModeUI gbs 36 | BookmarksMode -> menuModeUI gbs 37 | AddBookmarkMode -> modeUI (seFormerMode $ fromJust $ gbsStatus gbs) 38 | MenuFindMode -> modeUI (seFormerMode $ fromJust $ gbsStatus gbs) 39 | -------------------------------------------------------------------------------- /src/BrickApp/Draw/Help.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- | Draw `HelpMode`. 4 | module BrickApp.Draw.Help where 5 | 6 | import qualified Brick.Types as T 7 | import Brick.Widgets.Core ( viewport 8 | , txt 9 | ) 10 | 11 | import BrickApp.Types.Names 12 | import BrickApp.Types.Helpers 13 | import BrickApp.Types 14 | import BrickApp.Utils 15 | 16 | helpModeUI :: GopherBrowserState -> [T.Widget AnyName] 17 | helpModeUI gbs = defaultBrowserUI gbs (viewport (MyName TextViewport) T.Both) titleWidget mainWidget statusWidget 18 | where 19 | mainWidget = getHelpTextFileContents gbs 20 | titleWidget = txt "Waffle Help" 21 | statusWidget = txt "Help mode. Use arrows or hjkl to scroll." 22 | -------------------------------------------------------------------------------- /src/BrickApp/Draw/Menu.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- | Drawing `MenuMode` 4 | module BrickApp.Draw.Menu where 5 | 6 | import qualified Data.Text as T 7 | import Data.List as List 8 | import qualified Data.Vector as Vector 9 | import Data.Maybe 10 | 11 | import Lens.Micro ( (^.) ) 12 | import qualified Brick.Widgets.List as BrickList 13 | import qualified Brick.Types as T 14 | import Brick.Widgets.Core ( viewport 15 | , txt 16 | , withAttr 17 | , (<+>) 18 | ) 19 | 20 | import Gopher 21 | import BrickApp.Types 22 | import BrickApp.Types.Names 23 | import BrickApp.Types.Helpers 24 | import BrickApp.Utils.Style 25 | import BrickApp.Utils 26 | import BrickApp.ModeAction.Menu.State 27 | 28 | menuModeUI :: GopherBrowserState -> [T.Widget AnyName] 29 | menuModeUI gbs = defaultBrowserUI gbs 30 | (viewport (MyName MenuViewport) T.Horizontal) 31 | titleWidget 32 | mainWidget 33 | statusWidget 34 | where 35 | (Menu (_, l, _)) = getMenu gbs 36 | titleWidget = maybe defaultTitle txt (let (_, _, _, _, displayString) = gbsLocation gbs in displayString) 37 | defaultTitle = 38 | let (host, port, resource, _, _) = gbsLocation gbs 39 | in txt 40 | $ " " 41 | <> host 42 | <> ":" 43 | <> T.pack (show port) 44 | <> if not $ T.null resource then " (" <> resource <> ") " else " " 45 | statusWidget = 46 | let cur = case l ^. BrickList.listSelectedL of 47 | Nothing -> txt "-" 48 | Just i -> txt (T.pack $ show (i + 1)) 49 | total = 50 | txt $ T.pack . show $ Vector.length $ l ^. BrickList.listElementsL 51 | in txt "? for help. Menu mode. " 52 | <+> txt "Item " 53 | <+> cur 54 | <+> txt " of " 55 | <+> total 56 | 57 | mainWidget :: T.Widget AnyName 58 | mainWidget = BrickList.renderListWithIndex (listDrawElement $ getMenu gbs) True l 59 | 60 | -- FIXME: this is messy! unoptimized! 61 | listDrawElement 62 | :: Menu -> Int -> Bool -> T.Text -> T.Widget AnyName 63 | listDrawElement menu indx sel a = cursorRegion <+> possibleNumber <+> withAttr 64 | lineColor 65 | (selStr a <+> lineDescriptorWidget (menuLine gmenu indx)) 66 | where 67 | (Menu (gmenu, mlist, focusLines)) = menu 68 | maybeSelectedLine = selectedMenuLine menu 69 | 70 | -- FIXME: I should document what this does... 71 | selStr s 72 | | sel && isJust maybeSelectedLine && isInfoMsg 73 | (fromJust $ selectedMenuLine menu) 74 | = withAttr custom2Attr (txt s) 75 | | sel 76 | = withAttr customAttr $ txt s 77 | | otherwise 78 | = txt s 79 | 80 | cursorRegion = if sel then withAttr asteriskAttr $ txt " ➤ " else txt " " 81 | isLink = indx `elem` focusLines 82 | lineColor = if isLink then linkAttr else textAttr 83 | biggestIndexDigits = 84 | length $ show (Vector.length $ mlist ^. BrickList.listElementsL) 85 | curIndexDigits = length $ show $ fromJust $ indx `elemIndex` focusLines 86 | 87 | possibleNumber = if isLink 88 | then 89 | withAttr numberPrefixAttr 90 | $ txt 91 | $ numberPad 92 | $ T.pack (show (fromJust $ indx `elemIndex` focusLines)) 93 | <> ". " 94 | else txt $ T.replicate (biggestIndexDigits + 2) " " 95 | where 96 | numberPad :: T.Text -> T.Text 97 | numberPad = (T.replicate (biggestIndexDigits - curIndexDigits) " " <>) 98 | 99 | lineDescriptorWidget :: MenuLine -> T.Widget n 100 | lineDescriptorWidget line = case line of 101 | -- it's a parsed line 102 | (Parsed gl) -> case glType gl of 103 | -- Cannonical type 104 | (Canonical ct) -> case ct of 105 | Directory -> withAttr directoryAttr $ txt " 📂 [Directory]" 106 | File -> withAttr fileAttr $ txt " 📄 [File]" 107 | GifFile -> withAttr fileAttr $ txt " 🎥 [GIF]" 108 | ImageFile -> withAttr fileAttr $ txt " 🖼 [Image]" 109 | IndexSearchServer -> 110 | withAttr indexSearchServerAttr $ txt " 🔎 [IndexSearchServer]" 111 | _ -> withAttr genericTypeAttr $ txt $ " [" <> T.pack (show ct) <> "]" 112 | -- Noncannonical type 113 | (NonCanonical nct) -> case nct of 114 | InformationalMessage -> txt $ T.replicate (biggestIndexDigits + 2) " " 115 | HtmlFile -> withAttr directoryAttr $ txt " 🌐 [HTMLFile] " 116 | _ -> withAttr genericTypeAttr $ txt $ " [" <> T.pack (show nct) <> "]" 117 | -- it's a malformed/unrecognized line 118 | (Unparseable _) -> txt "" 119 | -------------------------------------------------------------------------------- /src/BrickApp/Draw/Open.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module BrickApp.Draw.Open where 4 | 5 | import Brick.Widgets.Core 6 | ( vBox 7 | , str 8 | , txt 9 | , viewport 10 | ) 11 | import qualified Brick.Types as T 12 | 13 | import BrickApp.Types 14 | import BrickApp.Utils 15 | import BrickApp.Types.Names 16 | import BrickApp.ModeAction.Open 17 | 18 | openConfigModeUI :: GopherBrowserState -> [T.Widget AnyName] 19 | openConfigModeUI gbs = 20 | defaultBrowserUI gbs (viewport (MyName MyViewport) T.Vertical) titleWidget mainWidget statusWidget 21 | where 22 | {- 23 | fields = 24 | let renderEditor = E.renderEditor (str . unlines) 25 | fieldMaker = \x -> F.withFocusRing (focusRing openConfigState) renderEditor (x openConfigState) 26 | in map fieldMaker ... 27 | -} 28 | openConfigState = 29 | let (OpenConfigBuffer ocs) = gbsBuffer gbs 30 | in ocs 31 | titleWidget = txt "Config: Open Associations" 32 | statusWidget = txt "Set commands for item types. Use tab to cycle fields." 33 | 34 | vBoxHeader = 35 | [ str "Set the commands associated with opening specific menu item types." 36 | , str "Leave blank to use xdg-open." 37 | , str " " 38 | ] 39 | vBoxFooter = 40 | [ str " " 41 | , str "Press TAB to switch between editors, ESC to quit." 42 | ] 43 | 44 | mainWidget :: T.Widget AnyName 45 | mainWidget = vBox (vBoxHeader ++ editWidgets openConfigState ++ vBoxFooter) 46 | 47 | 48 | -------------------------------------------------------------------------------- /src/BrickApp/Draw/Progress.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- | Draw `ProgressMode` 4 | module BrickApp.Draw.Progress where 5 | 6 | import qualified Data.Text as T 7 | 8 | import Brick.Widgets.Core ( txt ) 9 | import qualified Brick.Types as T 10 | 11 | import BrickApp.Types.Names 12 | import BrickApp.Types.Helpers 13 | import BrickApp.Types 14 | 15 | -- TODO: progressUI... 16 | drawProgressUI :: GopherBrowserState -> [T.Widget AnyName] 17 | drawProgressUI gbs = [a] 18 | where 19 | -- FIXME: "downloaded" isn't necessarily correct. You can request more bytes than is left... 20 | bytesDownloaded = T.pack $ show (pbBytesDownloaded (getProgress gbs)) 21 | bytesMessage = "Downloaded bytes: " <> bytesDownloaded 22 | downloadingWhat = pbMessage (getProgress gbs) 23 | 24 | connectMessage :: T.Text 25 | connectMessage 26 | | pbIsFromCache (getProgress gbs) = "⏳ Loading from cache..." 27 | | pbConnected (getProgress gbs) = bytesMessage 28 | | otherwise = "⏳ Connecting..." 29 | 30 | a = txt $ downloadingWhat <> "\n" <> connectMessage 31 | 32 | 33 | -------------------------------------------------------------------------------- /src/BrickApp/Draw/Save.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- | Draw/render `SaveMode` 4 | module BrickApp.Draw.Save where 5 | 6 | import qualified Data.Text as T 7 | import Control.Exception ( displayException ) 8 | 9 | import qualified Brick.Widgets.FileBrowser as FB 10 | import qualified Brick.Types as T 11 | import Brick.Widgets.Center ( center 12 | , hCenter 13 | ) 14 | import Brick.Widgets.Border ( borderWithLabel ) 15 | import Brick.Widgets.Core ( vLimitPercent 16 | , hLimitPercent 17 | , (<=>) 18 | , txt 19 | , padTop 20 | , vBox 21 | , emptyWidget 22 | , str 23 | , withDefAttr 24 | ) 25 | 26 | import BrickApp.Types.Names 27 | import BrickApp.Types.Helpers 28 | import BrickApp.Types 29 | import BrickApp.Utils.Style 30 | 31 | -- FIXME 32 | fileBrowserUi :: GopherBrowserState -> [T.Widget AnyName] 33 | fileBrowserUi gbs = 34 | [center $ vLimitPercent 100 $ hLimitPercent 100 $ ui <=> help] 35 | where 36 | b = fromBuffer $ getSaveBrowser gbs 37 | fromBuffer = fbFileBrowser 38 | ui = hCenter $ borderWithLabel (txt "Choose a file") $ FB.renderFileBrowser 39 | True 40 | b 41 | help = padTop (T.Pad 1) $ vBox 42 | [ case FB.fileBrowserException b of 43 | Nothing -> emptyWidget 44 | Just e -> 45 | hCenter $ withDefAttr errorAttr $ txt $ T.pack $ displayException e 46 | , hCenter $ txt "/: search, Ctrl-C or Esc: cancel search" 47 | , hCenter $ txt "Esc: quit/cancel save" 48 | , hCenter $ txt "n: name the output file and then hit enter" 49 | , hCenter $ str $ fbFileOutPath (getSaveBrowser gbs) 50 | ] 51 | -------------------------------------------------------------------------------- /src/BrickApp/Draw/Search.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module BrickApp.Draw.Search where 4 | 5 | import qualified Brick.Types as T 6 | 7 | import BrickApp.Types 8 | import BrickApp.Types.Names 9 | import BrickApp.Types.Helpers 10 | import BrickApp.Utils.Popup 11 | 12 | -- | Draw the search prompt. Used by UI.drawUI if the gbsRenderMode 13 | -- is SearchMode. 14 | searchInputUI :: GopherBrowserState -> [T.Widget AnyName] 15 | searchInputUI gbs = inputPopupUI editorBuffer labelText helpText 16 | where 17 | searchBuffer = getSearch gbs 18 | editorBuffer = sbEditorState (getSearch gbs) 19 | labelText = "Search: " <> sbHost searchBuffer 20 | helpText = "Press ENTER to search" 21 | -------------------------------------------------------------------------------- /src/BrickApp/Draw/TextFile.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module BrickApp.Draw.TextFile where 4 | 5 | import qualified Brick.Types as T 6 | import Brick.Widgets.Core ( txt ) 7 | 8 | import BrickApp.Types.Names 9 | import BrickApp.Types.Helpers 10 | import BrickApp.Types 11 | import BrickApp.Utils 12 | 13 | textFileModeUI :: GopherBrowserState -> [T.Widget AnyName] 14 | textFileModeUI gbs = defaultOptimizedUI gbs titleWidget mainWidget statusWidget 15 | where 16 | mainWidget = tfContents $ getTextFile gbs 17 | titleWidget = txt $ tfTitle $ getTextFile gbs 18 | statusWidget = txt "? for help. Text file mode." 19 | -------------------------------------------------------------------------------- /src/BrickApp/Handle.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | -- | Brick application event handlers, depending on the current `RenderMode`, as used 3 | -- by this Brick application's `Brick.Main.appHandleEvent`. 4 | module BrickApp.Handle where 5 | 6 | import Control.Monad.IO.Class 7 | 8 | import qualified Brick.Main as B 9 | import qualified Brick.Types as B 10 | import qualified Graphics.Vty as V 11 | 12 | import BrickApp.Utils ( cacheRemove ) 13 | import BrickApp.Utils.Popup ( popupDialogEventHandler) 14 | import BrickApp.Types.Names 15 | import BrickApp.Types.Helpers 16 | import BrickApp.Types 17 | import BrickApp.ModeAction.Homepage ( goHome, createHomeDialog ) 18 | import BrickApp.ModeAction.Help 19 | import BrickApp.ModeAction.Goto 20 | import BrickApp.ModeAction.Progress 21 | import BrickApp.ModeAction.Open 22 | import BrickApp.ModeAction.Bookmarks 23 | import BrickApp.Handle.Open 24 | import BrickApp.Handle.Bookmarks 25 | import BrickApp.Handle.Progress 26 | import BrickApp.Handle.Menu 27 | import BrickApp.Handle.Menu.Jump 28 | import BrickApp.Handle.Menu.Find 29 | import BrickApp.Handle.Goto 30 | import BrickApp.Handle.TextFile 31 | import BrickApp.Handle.Search 32 | import BrickApp.Handle.Help 33 | import BrickApp.Handle.Save 34 | 35 | appropriateHandler :: GopherBrowserState -> V.Event -> B.EventM AnyName (B.Next GopherBrowserState) 36 | appropriateHandler gbs e = case gbsRenderMode gbs of 37 | MenuMode -> menuEventHandler gbs e 38 | TextFileMode -> textFileEventHandler gbs e 39 | HelpMode -> helpEventHandler gbs e 40 | FileBrowserMode -> saveEventHandler gbs e 41 | SearchMode -> searchEventHandler gbs e 42 | GotoMode -> gotoEventHandler gbs e 43 | MenuJumpMode -> jumpEventHandler gbs e 44 | OpenConfigMode -> openConfigEventHandler gbs e 45 | BookmarksMode -> bookmarksEventHandler gbs e 46 | AddBookmarkMode -> addBookmarkEventHandler gbs e 47 | MenuFindMode -> menuFindEventHandler gbs e 48 | -- FIXME: two separate ones because of the way we pass events and pattern match 49 | -- i.e., one for vtyhandler and one for the custom app events, which we should 50 | -- soon conflate by not matching specifically for VtyEvent (thus passing all events 51 | -- to the appropriate mode's handler) 52 | ProgressMode -> progressEventHandler gbs (Right e) 53 | 54 | -- | Preform the successEvent if the function produces 55 | -- True when applied to the current RenderMode. 56 | -- 57 | -- >>> doEventIfModeTrue gbs (`elem` [GotoMode, OpenConfigMode]) ... 58 | doEventIfModeTrue 59 | :: GopherBrowserState 60 | -> (RenderMode -> Bool) 61 | -> B.EventM AnyName (B.Next GopherBrowserState) 62 | -> B.EventM AnyName (B.Next GopherBrowserState) 63 | -> B.EventM AnyName (B.Next GopherBrowserState) 64 | doEventIfModeTrue gbs func successEvent failEvent 65 | | func $ gbsRenderMode gbs = successEvent 66 | | otherwise = failEvent 67 | 68 | 69 | -- FIXME: the way I'm handling input here is bad. It relies on whitelisting which modes are allowed 70 | -- to initiate a new mode/use a command. So for example, if I ever add a new thing that handles input, 71 | -- the homepage event handler might active, unless homepage event handler is whitelisted, which then 72 | -- a problem occurs where homepagemode might not be tripped if and when it actually should be during 73 | -- a new mode that gets added! 74 | -- FIXME: shouldn't history be handled top level and not in individual handlers? or are there 75 | -- some cases where we don't want history available 76 | -- 77 | -- | The Brick application event handler which chooses which event handler to use based 78 | -- on the current gbsRenderMode. 79 | -- 80 | -- Used for Brick.Main.appHandleEvent. 81 | appEvent 82 | :: GopherBrowserState 83 | -> B.BrickEvent AnyName CustomEvent 84 | -> B.EventM AnyName (B.Next GopherBrowserState) 85 | appEvent gbs (B.VtyEvent (V.EvKey (V.KChar 'q') [V.MCtrl])) = B.halt gbs 86 | appEvent gbs (B.VtyEvent e@(V.EvKey (V.KFun 5) [])) = 87 | let newCache = cacheRemove (gbsLocation gbs) (gbsCache gbs) 88 | newGbs = gbs { gbsCache = newCache } 89 | in doEventIfModeTrue gbs (`elem` [TextFileMode, MenuMode]) (liftIO (initProgressMode newGbs (Just $ gbsHistory gbs) (gbsLocation gbs)) >>= B.continue) (appropriateHandler gbs e) 90 | -- popup logic catching 91 | appEvent gbs@(GopherBrowserState{gbsPopup=(Just n)}) e = popupDialogEventHandler gbs n e 92 | -- Close a popup if there is one, otherwise forward to appropriate handler! 93 | appEvent gbs (B.VtyEvent e@(V.EvKey V.KEsc [])) 94 | | hasPopup gbs = B.continue $ closePopup gbs 95 | | otherwise = appropriateHandler gbs e 96 | -- add new bookmark 97 | appEvent gbs (B.VtyEvent e@(V.EvKey (V.KChar '+') [])) = 98 | doEventIfModeTrue gbs (`elem` [TextFileMode, MenuMode]) (B.continue $ initAddBookmarkMode gbs) (appropriateHandler gbs e) 99 | -- FIXME 100 | -- This is the config mode, which currently just goes right into the menu item 101 | -- command association editor. 102 | appEvent gbs (B.VtyEvent e@(V.EvKey (V.KChar 'c') [V.MCtrl])) = 103 | -- Why not just have this function defer to the appropriateHandler on failure? 104 | doEventIfModeTrue gbs (== OpenConfigMode) (openConfigEventHandler gbs e) (liftIO (initConfigOpenMode gbs) >>= B.continue) 105 | -- Bookmark mode! 106 | appEvent gbs (B.VtyEvent (V.EvKey (V.KChar 'b') [V.MCtrl])) = 107 | let successEvent = liftIO (initBookmarksMode gbs) >>= B.continue 108 | failureEvent = B.continue gbs 109 | in doEventIfModeTrue gbs (/= BookmarksMode) successEvent failureEvent 110 | -- GotoMode 111 | appEvent gbs (B.VtyEvent e@(V.EvKey (V.KChar 'g') [V.MCtrl])) = 112 | doEventIfModeTrue gbs (`elem` [BookmarksMode, MenuMode, TextFileMode, HelpMode]) (B.continue $ initGotoMode gbs) (appropriateHandler gbs e) 113 | -- TODO: needs to reset viewport 114 | appEvent gbs (B.VtyEvent e@(V.EvKey (V.KChar '?') [])) = 115 | doEventIfModeTrue gbs (== HelpMode) (appropriateHandler gbs e) (liftIO (modifyGbsForHelp gbs) >>= B.continue) 116 | -- Go to the homepage 117 | appEvent gbs (B.VtyEvent e@(V.EvKey (V.KChar 'h') [])) = 118 | doEventIfModeTrue gbs (`elem` [BookmarksMode, MenuMode, TextFileMode, HelpMode]) ((liftIO $ goHome gbs) >>= B.continue) (appropriateHandler gbs e) 119 | -- Set the homepage 120 | -- FIXME: why does ctrl h not work? 121 | appEvent gbs (B.VtyEvent (V.EvKey (V.KChar 'z') [V.MCtrl])) = 122 | -- TODO/FIXME: bring up prompt about setting homepage 123 | B.continue (createHomeDialog gbs) 124 | -- 125 | -- FIXME: this could be easily fixed just by doing appEvent gbs e instead of vtyevent 126 | -- and leaving it up to eventhandlers 127 | -- What about above FIXME... event types should be deicphered by event handler? 128 | -- FIXME: just do vague event type discerning and don't say B.VtyEvent so it leaves it 129 | -- to the event handlers in case they want custom events 130 | appEvent gbs (B.VtyEvent e) = appropriateHandler gbs e 131 | -- Seems hacky FIXME (for customevent) 132 | appEvent gbs (B.AppEvent (ClearCacheEvent cce)) = cce >> B.continue gbs 133 | appEvent gbs e 134 | | gbsRenderMode gbs == ProgressMode = progressEventHandler gbs (Left e) 135 | | otherwise = B.continue gbs 136 | -------------------------------------------------------------------------------- /src/BrickApp/Handle/Bookmarks.hs: -------------------------------------------------------------------------------- 1 | module BrickApp.Handle.Bookmarks where 2 | 3 | import Data.Maybe ( fromJust ) 4 | import Control.Monad.IO.Class 5 | 6 | import qualified Brick.Main as B 7 | import qualified Brick.Types as T 8 | import qualified Graphics.Vty as V 9 | import Brick.Widgets.Edit as E 10 | 11 | import BrickApp.ModeAction.Progress ( initProgressMode ) 12 | import BrickApp.Handle.Menu ( menuEventHandler ) 13 | import BrickApp.Types 14 | import BrickApp.Types.Names 15 | import BrickApp.ModeAction.Bookmarks 16 | 17 | -- REDUNDANT FIXME (move to Utils/Status mayb? 18 | formerMode :: GopherBrowserState -> GopherBrowserState 19 | formerMode g = g { gbsRenderMode = seFormerMode $ fromJust $ gbsStatus g, gbsStatus = Nothing } 20 | 21 | -- | The handler for the bookmark viewer, which just extends the menu's handler, since the bookmark viewer 22 | -- is a menu! 23 | bookmarksEventHandler 24 | :: GopherBrowserState 25 | -> V.Event 26 | -> T.EventM AnyName (T.Next GopherBrowserState) 27 | bookmarksEventHandler gbs e = 28 | case e of 29 | V.EvKey V.KEsc [] -> do 30 | -- LOL all this is all done so we can have the display string in title since we're 31 | -- using the menu's draw code (lazy, but DRY) 32 | if let (_, historyIndex) = gbsHistory gbs in historyIndex == (-1) 33 | then B.continue gbs 34 | else let (historyStack, historyIndex) = gbsHistory gbs 35 | currentLocation = historyStack !! historyIndex 36 | in liftIO (initProgressMode gbs (Just $ gbsHistory gbs) currentLocation) >>= B.continue 37 | V.EvKey (V.KChar 'd') [] -> liftIO (removeSelectedBookmark gbs) >>= B.continue 38 | _ -> menuEventHandler gbs e 39 | 40 | -- | The handler for the add a bookmark dialog. 41 | addBookmarkEventHandler 42 | :: GopherBrowserState -> V.Event -> T.EventM AnyName (T.Next GopherBrowserState) 43 | addBookmarkEventHandler gbs e = case e of 44 | V.EvKey V.KEsc [] -> B.continue $ formerMode gbs 45 | -- On enter save bookmark with the name inputted 46 | V.EvKey V.KEnter [] -> liftIO (bookmarkCurrentLocation gbs) >>= B.continue 47 | _ -> B.continue =<< editorEventHandler gbs e 48 | where 49 | -- | A modification of the default Brick.Widgets.Edit event handler; changed to 50 | -- return a GopherBrowserState instead of just an editor state. 51 | editorEventHandler 52 | :: GopherBrowserState -> V.Event -> T.EventM AnyName GopherBrowserState 53 | -- TODO: e' is unused! 54 | editorEventHandler _ e' = 55 | -- Maybe this should be a general function in Representation. 56 | let updateEditorInStatus x = gbs { gbsStatus = Just $ (fromJust $ gbsStatus gbs) { seEditorState = x } } 57 | in updateEditorInStatus 58 | <$> E.handleEditorEvent e' (seEditorState $ fromJust $ gbsStatus gbs) 59 | -------------------------------------------------------------------------------- /src/BrickApp/Handle/Goto.hs: -------------------------------------------------------------------------------- 1 | -- | Event handler stuff for `GotoMode`. 2 | module BrickApp.Handle.Goto where 3 | 4 | import Data.Maybe 5 | 6 | import qualified Brick.Main as M 7 | import qualified Brick.Types as T 8 | import Brick.Widgets.Edit as E 9 | import qualified Graphics.Vty as V 10 | import Graphics.Vty.Input.Events ( Event ) 11 | 12 | import BrickApp.Types 13 | import BrickApp.Types.Names 14 | import BrickApp.ModeAction.Goto 15 | 16 | gotoEventHandler 17 | :: GopherBrowserState -> Event -> T.EventM AnyName (T.Next GopherBrowserState) 18 | gotoEventHandler gbs e = case e of 19 | -- FIXME: esc quits! Change key... 20 | V.EvKey V.KEsc [] -> M.continue $ formerMode gbs 21 | V.EvKey V.KEnter [] -> mkGotoResponseState gbs 22 | _ -> M.continue =<< editorEventHandler gbs e 23 | where 24 | -- | A modification of the default Brick.Widgets.Edit event handler; changed to 25 | -- return a GopherBrowserState instead of just an editor state. 26 | editorEventHandler 27 | :: GopherBrowserState -> Event -> T.EventM AnyName GopherBrowserState 28 | -- TODO: e' is unused! 29 | editorEventHandler _ e' = 30 | -- Maybe this should be a general function in Representation. 31 | let updateEditorInStatus x = gbs { gbsStatus = Just $ (fromJust $ gbsStatus gbs) { seEditorState = x } } 32 | in updateEditorInStatus 33 | <$> E.handleEditorEvent e' (seEditorState $ fromJust $ gbsStatus gbs) 34 | -------------------------------------------------------------------------------- /src/BrickApp/Handle/Help.hs: -------------------------------------------------------------------------------- 1 | -- | Event handler for the help screen/`HelpMode`. 2 | module BrickApp.Handle.Help where 3 | 4 | import qualified Brick.Types as T 5 | import qualified Graphics.Vty as V 6 | import qualified Brick.Main as M 7 | 8 | import BrickApp.Types 9 | import BrickApp.Types.Names 10 | import BrickApp.Types.Helpers 11 | import BrickApp.Handle.TextFile 12 | 13 | -- | Basic text file controls, modularized so that the Help screen can use 14 | -- too, without including the history stuff. See the Help module. 15 | helpEventHandler 16 | :: GopherBrowserState 17 | -> V.Event 18 | -> T.EventM AnyName (T.Next GopherBrowserState) 19 | helpEventHandler gbs e = case e of 20 | -- What about left and right?! 21 | V.EvKey V.KEsc [] -> M.continue $ hFormerGbs $ getHelp gbs 22 | _ -> basicTextFileEventHandler gbs e 23 | -------------------------------------------------------------------------------- /src/BrickApp/Handle/Homepage.hs: -------------------------------------------------------------------------------- 1 | -- | The handler for setting the homepage. 2 | -- asks if you want this page to be homepage 3 | -------------------------------------------------------------------------------- /src/BrickApp/Handle/Menu.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- | Event handling for `MenuMode`. 4 | module BrickApp.Handle.Menu where 5 | 6 | import Data.Char ( isDigit, digitToInt ) 7 | import Control.Monad.IO.Class 8 | 9 | import qualified Graphics.Vty as V 10 | import qualified Brick.Main as M 11 | import qualified Brick.Widgets.Edit as B 12 | import qualified Brick.Widgets.List as L 13 | import qualified Brick.Types as T 14 | 15 | import BrickApp.Types 16 | import BrickApp.Types.Names 17 | import BrickApp.Types.Helpers 18 | import BrickApp.Handle.Menu.Jump 19 | import BrickApp.ModeAction.Progress 20 | import BrickApp.ModeAction.Menu 21 | import BrickApp.ModeAction.Menu.State 22 | import BrickApp.Utils 23 | 24 | -- This belongs in ModeAction FIXME 25 | initMenuFindMode :: GopherBrowserState -> GopherBrowserState 26 | initMenuFindMode gbs = gbs 27 | { gbsRenderMode = MenuFindMode 28 | , gbsStatus = Just $ StatusEditor { seLabel = "Find item: " 29 | , seEditorState = B.editor (MyName EditorViewport) Nothing "" 30 | , seFormerMode = gbsRenderMode gbs 31 | } 32 | } 33 | 34 | menuEventHandler 35 | :: GopherBrowserState 36 | -> V.Event 37 | -> T.EventM AnyName (T.Next GopherBrowserState) 38 | menuEventHandler gbs e 39 | | 40 | -- Handle a popup (esc key to dismiss) while there is a popup present... 41 | hasPopup gbs = case e of 42 | V.EvKey V.KEsc [] -> M.continue $ closePopup gbs 43 | _ -> M.continue gbs 44 | | 45 | --- Handle controlling the menu. 46 | otherwise = case e of 47 | -- Save a menu 48 | V.EvKey (V.KChar 's') [V.MCtrl] -> do 49 | let (host, port, resource, _, displayString) = gbsLocation gbs 50 | liftIO (initProgressMode gbs Nothing (host, port, resource, FileBrowserMode, displayString)) >>= M.continue 51 | V.EvKey (V.KChar 'i') [] -> M.continue $ lineInfoPopup gbs 52 | V.EvKey V.KEnter [] -> 53 | liftIO (newStateFromSelectedMenuItem gbs) >>= M.continue 54 | V.EvKey (V.KChar 'o') [] -> 55 | liftIO (newStateFromOpenItem gbs) >>= M.continue 56 | V.EvKey (V.KChar 'l') [] -> 57 | M.hScrollBy menuViewportScroll 1 >> M.continue gbs 58 | V.EvKey (V.KChar 'h') [] -> 59 | M.hScrollBy menuViewportScroll (-1) >> M.continue gbs 60 | V.EvKey (V.KChar 'j') [] -> 61 | M.continue $ newMenuBuffer gbs $ nextLine (getMenu gbs) 62 | V.EvKey (V.KChar 'k') [] -> 63 | M.continue $ newMenuBuffer gbs $ previousLine (getMenu gbs) 64 | V.EvKey V.KDown [] -> 65 | M.continue $ newMenuBuffer gbs $ nextLine (getMenu gbs) 66 | V.EvKey V.KUp [] -> 67 | M.continue $ newMenuBuffer gbs $ previousLine (getMenu gbs) 68 | V.EvKey (V.KChar 'n') [] -> 69 | M.continue $ newMenuBuffer gbs $ jumpNextLink (getMenu gbs) 70 | V.EvKey (V.KChar 'p') [] -> 71 | M.continue $ newMenuBuffer gbs $ jumpPrevLink (getMenu gbs) 72 | V.EvKey (V.KChar 'u') [] -> liftIO (goParentDirectory gbs) >>= M.continue 73 | V.EvKey (V.KChar 'f') [] -> liftIO (goHistory gbs 1) >>= M.continue 74 | V.EvKey (V.KChar 'b') [] -> liftIO (goHistory gbs (-1)) >>= M.continue 75 | V.EvKey (V.KChar '/') [] -> M.continue $ initMenuFindMode gbs 76 | -- FIXME: Implement jump to link # here... 77 | V.EvKey (V.KChar c) [] -> 78 | if isDigit c 79 | then initJumpMode gbs (digitToInt c) 80 | else M.continue gbs 81 | -- The following catch-all is to hand off the event to Brick's list handler (the special one with vi controls). 82 | ev -> M.continue =<< updateMenuList <$> L.handleListEventVi 83 | L.handleListEvent 84 | ev 85 | (getMenuList gbs) 86 | where 87 | getMenuList x = let (Menu (_, gl, _)) = getMenu x in gl 88 | updateMenuList x = 89 | let (Menu (gm, _, fl)) = getMenu gbs 90 | in gbs { gbsBuffer = MenuBuffer $ Menu (gm, x, fl) } 91 | -------------------------------------------------------------------------------- /src/BrickApp/Handle/Menu/Find.hs: -------------------------------------------------------------------------------- 1 | module BrickApp.Handle.Menu.Find where 2 | 3 | import Control.Monad.IO.Class 4 | import Data.Maybe ( fromJust ) 5 | 6 | import qualified Brick.Main as B 7 | import qualified Brick.Types as T 8 | import qualified Graphics.Vty as V 9 | import Brick.Widgets.Edit as E 10 | 11 | -- import BrickApp.ModeAction.Progress ( initProgressMode ) 12 | import BrickApp.ModeAction.Menu.Find 13 | import BrickApp.Types 14 | import BrickApp.Utils 15 | import BrickApp.Types.Names 16 | import BrickApp.ModeAction.Menu.State 17 | 18 | -- REDUNDANT FIXME (move to Utils/Status mayb? 19 | 20 | menuFindEventHandler 21 | :: GopherBrowserState -> V.Event -> T.EventM AnyName (T.Next GopherBrowserState) 22 | menuFindEventHandler gbs e = case e of 23 | -- FIXME: esc quits! Change key... 24 | V.EvKey V.KEsc [] -> B.continue $ statusEditorFormerMode gbs 25 | -- On enter save bookmark with the name inputted 26 | V.EvKey V.KEnter [] -> liftIO (newStateFromSelectedMenuItem $ gbs { gbsStatus = Nothing }) >>= B.continue 27 | V.EvKey (V.KChar 'n') [V.MCtrl] -> B.continue =<< editorEventHandler gbs e 28 | _ -> B.continue =<< editorEventHandler gbs e 29 | where 30 | -- FIXME: this should just be in utils! 31 | -- | A modification of the default Brick.Widgets.Edit event handler; changed to 32 | -- return a GopherBrowserState instead of just an editor state. 33 | editorEventHandler 34 | :: GopherBrowserState -> V.Event -> T.EventM AnyName GopherBrowserState 35 | -- TODO: e' is unused! 36 | editorEventHandler _ e' = 37 | -- Maybe this should be a general function in Representation. 38 | let updateEditorInStatus x = selectFirstFound $ gbs { gbsStatus = Just $ (fromJust $ gbsStatus gbs) { seEditorState = x } } 39 | in updateEditorInStatus 40 | <$> E.handleEditorEvent e' (seEditorState $ fromJust $ gbsStatus gbs) 41 | -------------------------------------------------------------------------------- /src/BrickApp/Handle/Menu/Jump.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- | Handle events for `MenuMode`'s jump feature 4 | module BrickApp.Handle.Menu.Jump where 5 | 6 | import Data.Char ( isDigit) 7 | import Control.Monad.IO.Class 8 | import Data.Maybe 9 | import qualified Data.Text as T 10 | 11 | import qualified Brick.Main as M 12 | import qualified Brick.Types as T 13 | import Graphics.Vty.Input.Events ( Event ) 14 | import qualified Graphics.Vty as V 15 | import Brick.Widgets.Edit as E 16 | 17 | import BrickApp.Types 18 | import BrickApp.Types.Names 19 | import BrickApp.Types.Helpers 20 | import BrickApp.ModeAction.Menu.Jump 21 | import BrickApp.ModeAction.Menu.State 22 | 23 | -- WHAT WHY 24 | statusEditorUpdateHandler :: GopherBrowserState -> Event -> T.EventM AnyName GopherBrowserState 25 | statusEditorUpdateHandler gbs ev = 26 | -- Maybe functor is so handy! defaults to Nothing if Nothing! 27 | let updateEditorInStatus x 28 | | T.length (getEditText x) > 0 && T.all isDigit (getEditText x) = newMenuBuffer (gbs { gbsStatus = (\f -> f { seEditorState = x }) <$> gbsStatus gbs }) $ jumpToLink (getMenu gbs) (read (T.unpack $ getEditText x) :: Int) 29 | | otherwise = formerMode gbs 30 | in updateEditorInStatus 31 | <$> E.handleEditorEvent ev (seEditorState $ fromJust $ gbsStatus gbs) 32 | 33 | jumpEventHandler 34 | :: GopherBrowserState -> Event -> T.EventM AnyName (T.Next GopherBrowserState) 35 | jumpEventHandler gbs e = case e of 36 | -- FIXME: esc quits! Change key... 37 | V.EvKey V.KEsc [] -> M.continue $ formerMode gbs 38 | -- If enter key then follow... 39 | V.EvKey V.KEnter [] -> liftIO (newStateFromSelectedMenuItem $ formerMode gbs) >>= M.continue 40 | -- V.EvKey V.KEnter [] -> liftIO (mkGotoResponseState gbs) >>= M.continue 41 | _ -> M.continue =<< statusEditorUpdateHandler gbs e 42 | 43 | 44 | -- This should be more generic for status... could even have UI/Representations/Status.hs 45 | formerMode :: GopherBrowserState -> GopherBrowserState 46 | formerMode g = g { gbsRenderMode = seFormerMode $ fromJust $ gbsStatus g, gbsStatus = Nothing } 47 | 48 | -- TODO: should this go to UI.Handle? 49 | -- Think really hard about why this is TODO 50 | initJumpMode :: GopherBrowserState -> Int -> T.EventM AnyName (T.Next GopherBrowserState) 51 | initJumpMode gbs i = 52 | let newGbs = gbs { 53 | gbsRenderMode = MenuJumpMode 54 | , gbsStatus = Just $ StatusEditor { seLabel = "Jump to link #: " 55 | , seEditorState = E.editor (MyName EditorViewport) Nothing (T.pack $ show i) 56 | , seFormerMode = gbsRenderMode gbs 57 | } 58 | } 59 | -- WHY? 60 | in M.continue =<< statusEditorUpdateHandler newGbs (V.EvKey V.KRight []) 61 | -------------------------------------------------------------------------------- /src/BrickApp/Handle/Open.hs: -------------------------------------------------------------------------------- 1 | module BrickApp.Handle.Open where 2 | 3 | import Control.Monad.IO.Class 4 | 5 | import qualified Brick.Focus as F 6 | import qualified Brick.Main as M 7 | import qualified Brick.Types as T 8 | import Brick.Widgets.Edit as E 9 | import qualified Graphics.Vty as V 10 | import Graphics.Vty.Input.Events ( Event ) 11 | 12 | import BrickApp.Types 13 | import BrickApp.Types.Names 14 | import BrickApp.Types.Helpers 15 | import BrickApp.ModeAction.Open 16 | 17 | -- | The Brick application event handler for open config mode. See: UI.appEvent and 18 | --- Brick.Main.appHandleEvent. 19 | openConfigEventHandler 20 | :: GopherBrowserState -> Event -> T.EventM AnyName (T.Next GopherBrowserState) 21 | openConfigEventHandler gbs e = case e of 22 | V.EvKey V.KBackTab [] -> M.continue (updateGbs gbs focusPrev) 23 | V.EvKey (V.KChar '\t') [] -> M.continue (updateGbs gbs focusNext) 24 | V.EvKey (V.KChar 's') [V.MCtrl] -> liftIO (saveConfig (getOpenConfig gbs)) >> M.continue (addSavedPopup gbs) 25 | -- FIXME: ctrl+c quits! 26 | V.EvKey V.KEsc [] -> M.continue $ returnFormerGbs gbs 27 | _ -> handleFieldTypingEvent e gbs (getFocusRing gbs) 28 | 29 | -- TODO/FIXME: i'm told i must fix this with lenses 30 | -- | Handle typing in a field and produce an event for the open associations 31 | -- configuration editor's `focusRing`. 32 | handleFieldTypingEvent 33 | :: Event 34 | -> GopherBrowserState 35 | -> F.FocusRing AnyName 36 | -> T.EventM AnyName (T.Next GopherBrowserState) 37 | handleFieldTypingEvent e gbs ring = 38 | M.continue =<< case F.focusGetCurrent ring of 39 | -- This replicates a lot of the data structure of the lookup map implemented for item type to field info FIXME TODO 40 | -- Should also have a lookup for fieldname to item type and the reverse. 41 | Just (FieldName FileField) -> updateFieldEvent editFile (\oc x -> oc { editFile = x }) 42 | Just (FieldName DirectoryField) -> updateFieldEvent editDirectory (\oc x -> oc { editDirectory = x }) 43 | Just (FieldName CsoPhoneBookServerField) -> updateFieldEvent editCsoPhoneBookServer (\oc x -> oc { editCsoPhoneBookServer = x }) 44 | Just (FieldName ErrorField) -> updateFieldEvent editError (\oc x -> oc { editError = x }) 45 | Just (FieldName BinHexedMacintoshFileField) -> updateFieldEvent editBinHexedMacintoshFile (\oc x -> oc { editBinHexedMacintoshFile = x }) 46 | Just (FieldName DosBinaryArchiveField) -> updateFieldEvent editDosBinaryArchive (\oc x -> oc { editDosBinaryArchive = x }) 47 | Just (FieldName UnixUuencodedFileField) -> updateFieldEvent editUnixUuencodedFile (\oc x -> oc { editUnixUuencodedFile = x }) 48 | Just (FieldName IndexSearchServerField) -> updateFieldEvent editIndexSearchServer (\oc x -> oc { editIndexSearchServer = x }) 49 | Just (FieldName TextBasedTelnetSessionField) -> updateFieldEvent editTextBasedTelnetSession (\oc x -> oc { editTextBasedTelnetSession = x }) 50 | Just (FieldName BinaryFileField) -> updateFieldEvent editBinaryFile (\oc x -> oc { editBinaryFile = x }) 51 | Just (FieldName RedundantServerField) -> updateFieldEvent editRedundantServer (\oc x -> oc { editRedundantServer = x }) 52 | Just (FieldName GifFileField) -> updateFieldEvent editGifFile (\oc x -> oc { editGifFile = x }) 53 | Just (FieldName ImageFileField) -> updateFieldEvent editImageFile (\oc x -> oc { editImageFile = x }) 54 | Just (FieldName Tn3270SessionField) -> updateFieldEvent editTn3270Session (\oc x -> oc { editTn3270Session = x }) 55 | Just (FieldName DocField) -> updateFieldEvent editDoc (\oc x -> oc { editDoc = x }) 56 | Just (FieldName HtmlFileField) -> updateFieldEvent editHtmlFile (\oc x -> oc { editHtmlFile = x }) 57 | Just (FieldName InformationalMessageField) -> updateFieldEvent editInformationalMessage (\oc x -> oc { editInformationalMessage = x }) 58 | Just (FieldName SoundFileField) -> updateFieldEvent editSoundFile (\oc x -> oc { editSoundFile = x }) 59 | Just _ -> error "this should be impossible..." 60 | Nothing -> pure gbs 61 | where 62 | updateFieldEvent recordFunc updater = 63 | let relevantEditor = recordFunc (getOpenConfig gbs) 64 | updateFileEditor x = gbs { gbsBuffer = OpenConfigBuffer $ updater (getOpenConfig gbs) x } 65 | in updateFileEditor <$> E.handleEditorEvent e relevantEditor 66 | 67 | 68 | -------------------------------------------------------------------------------- /src/BrickApp/Handle/Progress.hs: -------------------------------------------------------------------------------- 1 | -- | Handle events for `ProgressMode` 2 | module BrickApp.Handle.Progress where 3 | 4 | import qualified Graphics.Vty as V 5 | import qualified Brick.Main as M 6 | import qualified Brick.Types as T 7 | 8 | import BrickApp.Types 9 | import BrickApp.Types.Names 10 | import BrickApp.ModeAction.Progress 11 | 12 | -- FIXME: maybe this needs to just have generic B.BrickEvent MyName CustomEvent 13 | -- and match from there 14 | -- TODO: handleProgressEvents 15 | -- FIXME: no need for this left/right nonsense because they're both 16 | -- B.BrickEvent MyName CustomEvent and you can decipher from there like in UI... 17 | -- should do this soon... 18 | progressEventHandler 19 | :: GopherBrowserState 20 | -> Either (T.BrickEvent AnyName CustomEvent) V.Event 21 | -> T.EventM AnyName (T.Next GopherBrowserState) 22 | progressEventHandler gbs (Left e) = case e of 23 | -- This is extremely hacky! 24 | T.AppEvent (NewStateEvent gbs') -> M.continue gbs' 25 | T.AppEvent (FinalNewStateEvent gbs') -> modeTransition >> M.continue gbs' 26 | _ -> M.continue gbs 27 | progressEventHandler gbs (Right _) = M.continue gbs 28 | -------------------------------------------------------------------------------- /src/BrickApp/Handle/Save.hs: -------------------------------------------------------------------------------- 1 | -- FIXME: put a lot of this into ModeAction/Save.hs 2 | -- | Handle events for `SaveMode` 3 | module BrickApp.Handle.Save where 4 | 5 | import Control.Monad.IO.Class 6 | 7 | import qualified Brick.Main as M 8 | import qualified Brick.Types as T 9 | import qualified Brick.Widgets.FileBrowser as FB 10 | import qualified Graphics.Vty as V 11 | 12 | import BrickApp.Types 13 | import BrickApp.Types.Names 14 | import BrickApp.Types.Helpers 15 | 16 | -- FIXME, TODO: document the features in handleFileBrowserEvent! 17 | -- FIXME: only need to return GopherBrowserState actually 18 | -- TODO: could just use built-in editor? 19 | -- | Overrides handling file browse revents because we have a special text entry mode! 20 | --- See also: handleFileBrowserEvent 21 | handleFileBrowserEvent' 22 | :: (Ord n) 23 | => GopherBrowserState 24 | -> V.Event 25 | -> FB.FileBrowser n 26 | -> (GopherBrowserState, T.EventM n (FB.FileBrowser n)) 27 | handleFileBrowserEvent' gbs e b 28 | | 29 | -- FIXME: okay this is very wrong/messed up. take another look at regular handleFIleBrowserEvent' 30 | not isNamingFile && e == V.EvKey (V.KChar 'n') [] 31 | = (initiateNamingState, pure b) 32 | -- If we are naming a file, then interpret events as we are in the file name input... 33 | | isNamingFile 34 | = case e of 35 | -- Enter key means we're done naming the file. 36 | V.EvKey V.KEnter [] -> 37 | ( finalOutFilePath $ FB.getWorkingDirectory b <> "/" <> curOutFilePath 38 | , pure b 39 | ) 40 | -- Delete a character. 41 | V.EvKey V.KBS [] -> 42 | ( updateOutFilePath $ take (length curOutFilePath - 1) curOutFilePath 43 | , pure b 44 | ) 45 | -- Entering in a character/appending a letter to name a file! 46 | V.EvKey (V.KChar c) [] -> 47 | (updateOutFilePath $ curOutFilePath ++ [c], pure b) 48 | _ -> (gbs, FB.handleFileBrowserEvent e b) 49 | -- Otherwise send things off to the default brick event handler! 50 | | otherwise 51 | = (gbs, FB.handleFileBrowserEvent e b) 52 | where 53 | initiateNamingState :: GopherBrowserState 54 | initiateNamingState = 55 | let cb x = x { fbIsNamingFile = True 56 | , fbFileOutPath = fbOriginalFileName (getSaveBrowser gbs) 57 | } 58 | in updateFileBrowserBuffer gbs cb 59 | 60 | finalOutFilePath :: FilePath -> GopherBrowserState 61 | finalOutFilePath p = 62 | let cb x = x { fbFileOutPath = p, fbIsNamingFile = False } 63 | in updateFileBrowserBuffer gbs cb 64 | 65 | isNamingFile :: Bool 66 | isNamingFile = fbIsNamingFile (getSaveBrowser gbs) 67 | 68 | updateOutFilePath :: String -> GopherBrowserState 69 | updateOutFilePath p = 70 | let cb x = x { fbFileOutPath = p } in updateFileBrowserBuffer gbs cb 71 | 72 | curOutFilePath :: String 73 | curOutFilePath = fbFileOutPath (getSaveBrowser gbs) 74 | 75 | saveEventHandler 76 | :: GopherBrowserState 77 | -> V.Event 78 | -> T.EventM AnyName (T.Next GopherBrowserState) 79 | saveEventHandler gbs e = case e of 80 | -- instances of 'b' need to tap into gbsbuffer 81 | -- TODO: document why this does so many checks to allow ESC to former state 82 | V.EvKey V.KEsc [] 83 | | not 84 | (FB.fileBrowserIsSearching $ fromFileBrowserBuffer (getSaveBrowser gbs)) 85 | -> M.continue $ returnFormerState gbs 86 | -- Handle a file browser event with Brick's file brower event handler, but 87 | -- with some added magic! 88 | _ -> do 89 | let (gbs', bUnOpen') = handleFileBrowserEvent' 90 | gbs 91 | e 92 | (fromFileBrowserBuffer $ getSaveBrowser gbs) 93 | b' <- bUnOpen' 94 | -- If the browser has a selected file after handling the 95 | -- event (because the user pressed Enter), shut down. 96 | let fileOutPath = fbFileOutPath (getSaveBrowser gbs') 97 | if isNamingFile gbs' 98 | then M.continue (upFileBrowserBuffer gbs' b') 99 | -- this errors now 100 | else if not (null $ getOutFilePath gbs') 101 | then liftIO (doCallBack fileOutPath) >>= M.continue 102 | else M.continue (upFileBrowserBuffer gbs' b') 103 | where 104 | (_, _, _, formerRenderMode, _) = gbsLocation gbs 105 | fromFileBrowserBuffer = fbFileBrowser 106 | returnFormerState g = g { gbsBuffer = fbFormerBufferState $ getSaveBrowser g 107 | , gbsRenderMode = formerRenderMode 108 | } 109 | isNamingFile g = fbIsNamingFile (getSaveBrowser g) 110 | 111 | -- FIXME: redundant? 112 | upFileBrowserBuffer g bu = 113 | let cb x = x { fbFileBrowser = bu } in updateFileBrowserBuffer g cb 114 | 115 | getOutFilePath g = fbFileOutPath (getSaveBrowser g) 116 | doCallBack a = do 117 | fbCallBack (getSaveBrowser gbs) a 118 | pure $ gbs { gbsBuffer = fbFormerBufferState $ getSaveBrowser gbs 119 | , gbsRenderMode = formerRenderMode 120 | } 121 | -------------------------------------------------------------------------------- /src/BrickApp/Handle/Search.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module BrickApp.Handle.Search where 4 | 5 | import Control.Monad.IO.Class 6 | 7 | import qualified Brick.Main as M 8 | import qualified Brick.Types as T 9 | import Brick.Widgets.Edit as E 10 | import qualified Graphics.Vty as V 11 | import Graphics.Vty.Input.Events ( Event ) 12 | 13 | import BrickApp.Types 14 | import BrickApp.Types.Names 15 | import BrickApp.Types.Helpers 16 | import BrickApp.ModeAction.Search 17 | 18 | -- | The Brick application event handler for search mode. See: UI.appEvent and 19 | --- Brick.Main.appHandleEvent. 20 | searchEventHandler 21 | :: GopherBrowserState -> Event -> T.EventM AnyName (T.Next GopherBrowserState) 22 | searchEventHandler gbs e = case e of 23 | -- FIXME: esc quits! Change key... 24 | V.EvKey V.KEsc [] -> M.continue $ returnSearchFormerState gbs 25 | V.EvKey V.KEnter [] -> liftIO (mkSearchResponseState gbs) >>= M.continue 26 | _ -> M.continue =<< editorEventHandler gbs e 27 | where 28 | returnSearchFormerState g = g { gbsBuffer = sbFormerBufferState $ getSearch g 29 | , gbsRenderMode = MenuMode 30 | } 31 | 32 | -- | A modification of the default Brick.Widgets.Edit event handler; changed to 33 | -- return a GopherBrowserState instead of just an editor state. 34 | editorEventHandler 35 | :: GopherBrowserState -> Event -> T.EventM AnyName GopherBrowserState 36 | editorEventHandler gbs' e' = 37 | let updateEditorInBuffer x = 38 | updateSearchBuffer gbs' (\s -> s { sbEditorState = x }) 39 | in updateEditorInBuffer 40 | <$> E.handleEditorEvent e' (sbEditorState $ getSearch gbs) 41 | -------------------------------------------------------------------------------- /src/BrickApp/Handle/TextFile.hs: -------------------------------------------------------------------------------- 1 | module BrickApp.Handle.TextFile where 2 | 3 | import Control.Monad.IO.Class 4 | 5 | import qualified Graphics.Vty as V 6 | import qualified Brick.Types as T 7 | import qualified Brick.Main as M 8 | 9 | import BrickApp.Types 10 | import BrickApp.Utils 11 | import BrickApp.Types.Names 12 | import BrickApp.ModeAction.Progress 13 | 14 | -- | Basic text file controls, modularized so that the Help screen can use 15 | -- too, without including the history stuff. See the Help module. 16 | basicTextFileEventHandler 17 | :: GopherBrowserState 18 | -> V.Event 19 | -> T.EventM AnyName (T.Next GopherBrowserState) 20 | basicTextFileEventHandler gbs e = case e of 21 | -- What about left and right?! 22 | V.EvKey (V.KChar 'j') [] -> M.vScrollBy textViewportScroll 1 >> M.continue gbs 23 | V.EvKey (V.KChar 'k') [] -> M.vScrollBy textViewportScroll (-1) >> M.continue gbs 24 | V.EvKey (V.KChar 'l') [] -> M.hScrollBy textViewportScroll 1 >> M.continue gbs 25 | V.EvKey (V.KChar 'h') [] -> M.hScrollBy textViewportScroll (-1) >> M.continue gbs 26 | _ -> M.continue gbs 27 | 28 | -- | Event handler for a text file location in gopherspace. 29 | textFileEventHandler 30 | :: GopherBrowserState 31 | -> V.Event 32 | -> T.EventM AnyName (T.Next GopherBrowserState) 33 | textFileEventHandler gbs e = case e of 34 | V.EvKey (V.KChar 's') [V.MCtrl] -> 35 | liftIO (initProgressMode gbs Nothing (host, port, resource, FileBrowserMode, displayString)) >>= M.continue 36 | -- FIXME: these aren't specific to text file mode! i should modularize 37 | V.EvKey (V.KChar 'u') [] -> liftIO (goParentDirectory gbs) >>= M.continue 38 | V.EvKey (V.KChar 'f') [] -> liftIO (goHistory gbs 1) >>= M.continue 39 | V.EvKey (V.KChar 'b') [] -> liftIO (goHistory gbs (-1)) >>= M.continue 40 | _ -> basicTextFileEventHandler gbs e 41 | where 42 | (host, port, resource, _, displayString) = gbsLocation gbs 43 | -------------------------------------------------------------------------------- /src/BrickApp/ModeAction/Bookmarks.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- TODO: this doesn't even make sense here atm because there's no mode its just menu mode etc 4 | -- | UI for editing the open config for setting commands associated with 5 | -- opening a menu item of specific types. 6 | module BrickApp.ModeAction.Bookmarks where 7 | 8 | import qualified Data.Map as Map 9 | import Data.Maybe ( fromJust ) 10 | import qualified Data.Text as T 11 | import Data.List ( intercalate ) 12 | 13 | import qualified Brick.Widgets.Dialog as D 14 | import Brick.Widgets.Edit as E 15 | import Brick.Widgets.Core ( str ) 16 | import qualified Data.ConfigFile as CF 17 | 18 | import Bookmarks 19 | import BrickApp.Types.Names 20 | import BrickApp.Utils ( menuToMenuBuffer, renderModeToItemChar ) 21 | import Gopher 22 | import Config.Bookmarks 23 | import BrickApp.Types 24 | import BrickApp.Types.Helpers 25 | import BrickApp.ModeAction.Menu.State ( selectedMenuLine ) 26 | 27 | initAddBookmarkMode :: GopherBrowserState -> GopherBrowserState 28 | initAddBookmarkMode gbs = gbs 29 | { gbsRenderMode = AddBookmarkMode 30 | , gbsStatus = Just $ StatusEditor { seLabel = "Bookmark Name: " 31 | , seEditorState = E.editor (MyName EditorViewport) Nothing "" 32 | , seFormerMode = gbsRenderMode gbs 33 | } 34 | } 35 | 36 | -- | Remove the selected bookmark, writing to file, and then give back 37 | -- a new version of the `GopherBrowserState` that has the bookmark 38 | -- removed from the menu. 39 | removeSelectedBookmark :: GopherBrowserState -> IO GopherBrowserState 40 | removeSelectedBookmark gbs = do 41 | let selectedLine = case selectedMenuLine (getMenu gbs) of 42 | Just l -> l 43 | Nothing -> error "nothing selected" 44 | let sectionSpec = case selectedLine of 45 | Parsed parsedLine -> T.unpack $ glDisplayString parsedLine 46 | Unparseable _ -> error "Unparseable line in bookmarks!" 47 | removeBookmark sectionSpec 48 | initBookmarksMode gbs 49 | 50 | -- FIXME: a hack right now 51 | initBookmarksMode :: GopherBrowserState -> IO GopherBrowserState 52 | initBookmarksMode gbs = do 53 | bookmarks <- bookmarksMenuText 54 | pure $ gbs { gbsBuffer = menuToMenuBuffer $ makeGopherMenu $ bookmarks 55 | , gbsRenderMode = BookmarksMode 56 | , gbsStatus = Nothing 57 | , gbsPopup = Nothing 58 | , gbsLocation = ("", 0, "", MenuMode, Just "Bookmarks") 59 | } 60 | 61 | -- | Create the display string/SectionSpec using the URI of 62 | -- the spec (no schema included [gopher://]) and the input 63 | -- from when the user was prompted to enter a label. 64 | createDisplayString :: String -> String -> CF.SectionSpec 65 | createDisplayString uri inputString = 66 | let strippedStart = dropWhile (== ' ') inputString 67 | stripped = reverse $ dropWhile (== ' ') $ reverse strippedStart 68 | in if stripped == "" 69 | then uri 70 | else stripped ++ " (" ++ uri ++ ")" 71 | 72 | -- | Create a URI string, without gopher:// scheme, from the 73 | -- hostname (`Text`), port (`Int`), item type character (`Char`), 74 | -- and the resource (`Text`). 75 | createUriString :: T.Text -> Int -> Char -> T.Text -> String 76 | createUriString hostName port itemTypeChar resource = 77 | intercalate "/" [ T.unpack hostName ++ ":" ++ (show port) 78 | , [itemTypeChar] 79 | , removeLeadSlash $ T.unpack resource 80 | ] 81 | where 82 | removeLeadSlash s = if take 1 s == "/" then drop 1 s else s 83 | 84 | -- FIXME: should popup with a prompt asking for a label? with inputPopupUI 85 | -- | Bookmark the current `Location` and create a popup saying "bookmark added!" 86 | bookmarkCurrentLocation :: GopherBrowserState -> IO GopherBrowserState 87 | bookmarkCurrentLocation gbs = 88 | -- FIXME: this get contents should be in utils or something 89 | -- FIXME: fromJust is bad!. Also this could have displayString as default 90 | let (hostName, port, resource, renderMode, _) = gbsLocation gbs 91 | uri = createUriString hostName port itemTypeChar resource 92 | inputValue = T.unpack $ T.filter (/= '\n') $ T.unlines (E.getEditContents $ seEditorState $ fromJust $ gbsStatus gbs) 93 | label = createDisplayString uri inputValue 94 | itemTypeChar = renderModeToItemChar renderMode 95 | bookmark = (label, T.unpack hostName, port, T.unpack resource, itemTypeChar) 96 | popup = Popup 97 | { pDialogWidget = D.dialog (Just "Added Bookmark") (Just (0, [ ("Ok", Ok) ])) 50--wtf what about max width for bug 98 | , pDialogMap = Map.fromList [("Ok", pure . closePopup)] 99 | , pDialogBody = str $ "Added: " ++ inputValue 100 | } 101 | -- FIXME: fromJust! 102 | in addBookmark bookmark >> pure (gbs { gbsPopup = Just popup, gbsStatus = Nothing, gbsRenderMode = seFormerMode (fromJust . gbsStatus $ gbs) } ) 103 | 104 | -- should have ability to accept defaults for input fields (in the case of bookmarking a page, 105 | -- vs. raw input on the bookmarks page) 106 | -- addBookmarkPopup :: GopherBrowserState -> ... 107 | 108 | -- addBookmark :: URI -> ... 109 | -------------------------------------------------------------------------------- /src/BrickApp/ModeAction/Goto.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- | The heavy-lifting/actual actions of `GotoMode`. 4 | module BrickApp.ModeAction.Goto where 5 | 6 | import Control.Monad.IO.Class 7 | import Data.Maybe 8 | import qualified Data.Text as T 9 | 10 | import qualified Brick.Types as B 11 | import qualified Brick.Main as B 12 | import Brick.Widgets.Edit as E 13 | 14 | import BrickApp.Types 15 | import BrickApp.Types.Names 16 | import BrickApp.Utils.WaffleAddresses 17 | 18 | initGotoMode :: GopherBrowserState -> GopherBrowserState 19 | initGotoMode gbs = gbs 20 | { gbsRenderMode = GotoMode 21 | , gbsStatus = Just $ StatusEditor { seLabel = "Goto: " 22 | , seEditorState = E.editor (MyName EditorViewport) Nothing "" 23 | , seFormerMode = gbsRenderMode gbs 24 | } 25 | } 26 | 27 | -- FIXME: huge pages are sooo slow in text mode 28 | -- FIXME: if I go to sdf.org it's fine and the goto status bar disappears. if i go to 29 | -- tilde.black:70/users/brool/stoned.txt it stays put (i hav eto also remov eport because that crashes because of read) 30 | -- FIXME: what if bad input?! what if can't resolve? errors in network need better handling 31 | -- FIXME: what if NOT a menu! 32 | -- should this be a part of progress? or ge called by progress instead? 33 | --mkGotoResponseState :: GopherBrowserState -> IO GopherBrowserState 34 | mkGotoResponseState :: GopherBrowserState -> B.EventM AnyName (B.Next GopherBrowserState) 35 | mkGotoResponseState gbs = 36 | -- get the host, port, selector 37 | let unparsedURI = T.filter (/= '\n') 38 | $ T.unlines (E.getEditContents $ seEditorState $ fromJust $ gbsStatus gbs) 39 | formerGbs = formerMode gbs 40 | -- here is where i detect type first 41 | -- I should modularize this to be used elsewhere like home or follow links? 42 | in liftIO (loadAddress formerGbs unparsedURI Nothing) >>= B.continue 43 | 44 | -- | Revert to mode prior to `GotoMode` being initiated. 45 | formerMode :: GopherBrowserState -> GopherBrowserState 46 | formerMode g = g { gbsRenderMode = seFormerMode $ fromJust $ gbsStatus g, gbsStatus = Nothing } 47 | -------------------------------------------------------------------------------- /src/BrickApp/ModeAction/Help.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | -- | The actual doing-stuff for `HelpMode`. 5 | module BrickApp.ModeAction.Help where 6 | 7 | import qualified Data.Text as T 8 | import qualified Data.Text.Encoding as TE 9 | 10 | import Data.FileEmbed 11 | import Brick.Widgets.Core ( txt ) 12 | 13 | import BrickApp.Types 14 | 15 | helpText :: T.Text 16 | helpText = TE.decodeUtf8 $(embedFile "data/help.txt") 17 | 18 | -- Would this be better as a helper function in UI.Types.Helpers? 19 | -- | Initialize help mode. 20 | modifyGbsForHelp :: GopherBrowserState -> IO GopherBrowserState 21 | modifyGbsForHelp gbs = do 22 | pure gbs { gbsBuffer = HelpBuffer $ Help { hText = TextFile { tfContents = txt helpText, tfTitle = "Help: Using Waffle" }, hFormerGbs = gbs }, gbsRenderMode = HelpMode } 23 | -------------------------------------------------------------------------------- /src/BrickApp/ModeAction/Homepage.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | -- | The controller stuff for the homepage feature. 3 | module BrickApp.ModeAction.Homepage where 4 | 5 | import qualified Data.Text as T 6 | import qualified Data.Map as Map 7 | 8 | import Brick.Widgets.Core (txt) 9 | import qualified Brick.Widgets.Dialog as D 10 | 11 | import BrickApp.Utils 12 | import BrickApp.Types 13 | import BrickApp.Types.Helpers 14 | import Config 15 | import Config.Homepage 16 | import BrickApp.Utils.WaffleAddresses 17 | 18 | 19 | -- | Function for setting current location as the homepage 20 | setHomeDialog :: GopherBrowserState -> IO GopherBrowserState 21 | setHomeDialog gbs = 22 | let (domain, port, resource, renderMode, displayString) = gbsLocation gbs 23 | itemType = T.pack [renderModeToItemChar renderMode] 24 | uri = T.unpack $ "gopher://" <> domain <> ":" <> (T.pack $ show port) <> "/" <> itemType <> resource 25 | -- FIXME: maybe should have a helper function since this gets repeated so dang much! 26 | -- this new gbs below will replace the current home dialog with a success dialog 27 | choices = [ ("Ok", Ok) ] 28 | pop = Popup 29 | { pDialogWidget = D.dialog (Just "Homepage Set!") (Just (0, choices)) 50--wtf what about max width for bug 30 | , pDialogMap = Map.fromList [("Ok", pure . closePopup)] 31 | , pDialogBody = txt "Success: Current page set as homepage!" 32 | } 33 | newGbs = gbs { gbsPopup = Just pop } 34 | in setHomepage uri (fmap T.unpack displayString) >> pure newGbs 35 | 36 | -- | The dialog for OK/cancel setting homepage to current 37 | createHomeDialog :: GopherBrowserState -> GopherBrowserState 38 | createHomeDialog gbs = 39 | let choices = [ ("Ok", Ok), ("Cancel", Cancel) ] 40 | pop = Popup 41 | { pDialogWidget = D.dialog (Just "Set Homepage?") (Just (0, choices)) 50--wtf what about max width for bug 42 | , pDialogMap = Map.fromList [("Ok", setHomeDialog), ("Cancel", pure . closePopup)] 43 | , pDialogBody = txt "Set current page as homepage?" 44 | } 45 | in gbs { gbsPopup = Just pop } 46 | 47 | goHome :: GopherBrowserState -> IO GopherBrowserState 48 | goHome gbs = do 49 | configParser <- getUserHomepageConfig 50 | unparsedURI <- readConfigParserValue configParser "homepage" "uri" 51 | displayString <- readConfigParserValue configParser "homepage" "display" -- What happens if this is blank? 52 | loadAddress gbs (T.pack $ unparsedURI) (Just displayString) 53 | -------------------------------------------------------------------------------- /src/BrickApp/ModeAction/Menu.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module BrickApp.ModeAction.Menu where 4 | 5 | import qualified Data.Map as Map 6 | import Data.List as List 7 | import Data.Maybe 8 | 9 | import qualified Brick.Widgets.Dialog as D 10 | import qualified Brick.Widgets.List as BrickList 11 | import Brick.Widgets.Core ( txt ) 12 | 13 | import BrickApp.ModeAction.Menu.State 14 | import BrickApp.Types 15 | import BrickApp.Types.Helpers 16 | import BrickApp.ModeAction.Progress 17 | import Gopher 18 | 19 | -- | Used by `jumpNextLink` and `jumpPrevLink` for creating a new 20 | -- menu that uses the updated list position. 21 | updateMenuPosition :: Menu -> Int -> Menu 22 | updateMenuPosition menu next = 23 | let (Menu (gm, l, fl)) = menu in Menu (gm, BrickList.listMoveTo next l, fl) 24 | 25 | -- | Jump to the next line (wraps around). 26 | nextLine :: Menu -> Menu 27 | nextLine menu = updateMenuPosition menu next 28 | where 29 | (Menu (_, l, _)) = menu 30 | 31 | next = case BrickList.listSelected l of 32 | Just currentIndex -> 33 | if currentIndex == length l - 1 34 | then 0 35 | else currentIndex + 1 36 | Nothing -> 0 37 | 38 | -- | Jump to the previous line (wraps around). 39 | previousLine :: Menu -> Menu 40 | previousLine menu = updateMenuPosition menu next 41 | where 42 | (Menu (_, l, _)) = menu 43 | 44 | next = case BrickList.listSelected l of 45 | Just currentIndex -> 46 | if currentIndex == 0 47 | then length l - 1 48 | else currentIndex - 1 49 | Nothing -> 0 50 | 51 | -- FIXME: move away form getMenu gbs and using gbs 52 | -- | Jump to the next link (wraps around). Basically, skips info items. 53 | jumpNextLink :: Menu -> Menu 54 | jumpNextLink menu = updateMenuPosition menu next 55 | where 56 | (Menu (_, l, focusLines)) = menu 57 | 58 | headOr a [] = a 59 | headOr _ (x : _) = x 60 | 61 | next = case BrickList.listSelected l of 62 | -- NOTE: using "find" for this feels inefficient... oh well! 63 | Just currentIndex -> 64 | -- Try to find a line # bigger than the currently selected line in 65 | -- the focusLines to give us the new/next line to jump to. 66 | -- 67 | -- If we cannot find a line # bigger than the currently selected line 68 | -- we wrap to the first link. However, if there is no "first link," 69 | -- something that would happen if there's no elements in focusLines, 70 | -- we just return the active line. 71 | fromMaybe (headOr currentIndex focusLines) 72 | (find (> currentIndex) focusLines) 73 | -- If there's no currently selected line let's select line 0! 74 | Nothing -> headOr 0 focusLines 75 | 76 | -- | Jump to previous link (wraps around). Basically, skips info items. 77 | -- Be sure to see `jumpNextLink` (most of my code comments are in there). 78 | jumpPrevLink :: Menu -> Menu 79 | jumpPrevLink menu = updateMenuPosition menu next 80 | where 81 | (Menu (_, l, focusLines)) = menu 82 | 83 | lastOr a [] = a 84 | lastOr _ xs = last xs 85 | 86 | next = case BrickList.listSelected l of 87 | Just currentIndex -> fromMaybe 88 | (lastOr currentIndex focusLines) 89 | (find (< currentIndex) $ reverse focusLines) 90 | Nothing -> lastOr 0 focusLines 91 | 92 | -- | Make a request based on the currently selected Gopher menu item and open 93 | -- the file! 94 | newStateFromOpenItem :: GopherBrowserState -> IO GopherBrowserState 95 | newStateFromOpenItem gbs = 96 | initOpenMode gbs (host, port, resource, FileBrowserMode, Nothing) lineType -- render mode not needed 97 | where 98 | menu = getMenu gbs 99 | (host, port, resource, lineType) = case selectedMenuLine menu of 100 | -- ParsedLine 101 | Just (Parsed gl) -> (glHost gl, glPort gl, glSelector gl, glType gl) 102 | -- FIXME: why even error here? 103 | -- Unrecognized/unparseable line 104 | Just (Unparseable _ ) -> error "Can't do anything with unrecognized line." 105 | Nothing -> error "Nothing is selected!" 106 | 107 | -- | Describe the currently selected line in the menu/map. 108 | lineInfoPopup :: GopherBrowserState -> GopherBrowserState 109 | lineInfoPopup gbs = 110 | let menu = getMenu gbs 111 | currentLineInfo = case selectedMenuLine menu of 112 | Just gopherLine -> explainLine gopherLine 113 | Nothing -> "Nothing is selected!" 114 | in gbs 115 | { gbsPopup = 116 | Just $ Popup 117 | { pDialogWidget = D.dialog (Just "Currently Selected Line Info") (Just (0, [ ("Ok", Ok) ])) 50--wtf what about max width for bug 118 | , pDialogMap = Map.fromList [("Ok", pure . closePopup)] 119 | , pDialogBody = txt currentLineInfo 120 | } 121 | } 122 | -------------------------------------------------------------------------------- /src/BrickApp/ModeAction/Menu/Find.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- TODO: this doesn't even make sense here atm because there's no mode its just menu mode etc 4 | -- | UI for editing the open config for setting commands associated with 5 | -- opening a menu item of specific types. 6 | module BrickApp.ModeAction.Menu.Find where 7 | 8 | import qualified Data.Text as T 9 | 10 | import Brick.Widgets.List 11 | 12 | import BrickApp.Types 13 | import BrickApp.Utils ( getSearchEditorContents ) 14 | import BrickApp.Types.Helpers 15 | 16 | selectFirstFound :: GopherBrowserState -> GopherBrowserState 17 | selectFirstFound gbs = 18 | if T.null $ inputValue 19 | then gbs 20 | else 21 | let Menu (gopherMenu, brickList, focusLines) = getMenu gbs 22 | newList = listFindBy (compareText inputValue) brickList 23 | in gbs { gbsBuffer = MenuBuffer $ Menu (gopherMenu, newList, focusLines) } 24 | where 25 | inputValue = getSearchEditorContents gbs 26 | compareText x y = T.toLower x `T.isInfixOf` (T.toLower y) 27 | -------------------------------------------------------------------------------- /src/BrickApp/ModeAction/Menu/Jump.hs: -------------------------------------------------------------------------------- 1 | -- | Does the heavy-lifting, the actual stuff for `MenuJumpMode`. 2 | module BrickApp.ModeAction.Menu.Jump where 3 | 4 | import qualified Data.Text as T -- FIXME 5 | 6 | import Brick.Widgets.List ( listMoveTo ) 7 | import Brick.Widgets.Edit as E 8 | 9 | import BrickApp.Types 10 | 11 | -- REDUNDANT CODE/DUPLICATE 12 | -- | Used by `jumpNextLink` and `jumpPrevLink` for creating a new 13 | -- menu that uses the updated list position. 14 | updateMenuPosition :: Menu -> Int -> Menu 15 | updateMenuPosition menu next = 16 | let (Menu (gm, l, fl)) = menu in Menu (gm, listMoveTo next l, fl) 17 | 18 | jumpToLink :: Menu -> Int -> Menu 19 | jumpToLink menu linkNumber = updateMenuPosition menu jumpToIndex 20 | where 21 | jumpToIndex = 22 | let (Menu (_, _, focusLines)) = menu 23 | ind = min linkNumber $ length focusLines - 1 24 | in focusLines !! ind 25 | 26 | -- TODO: getStatusEditorText 27 | -- FIXME: fromJust is very bad! 28 | -- this should be a generic util function or something in repr just for status editor 29 | 30 | getEditText :: Editor T.Text n -> T.Text 31 | getEditText x = T.filter (/= '\n') $ T.unlines (E.getEditContents x) 32 | -------------------------------------------------------------------------------- /src/BrickApp/ModeAction/Menu/State.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- | Network state I guess? 4 | module BrickApp.ModeAction.Menu.State ( newStateFromSelectedMenuItem, selectedMenuLine ) where 5 | 6 | import qualified Data.Text as T 7 | 8 | import Lens.Micro ( (^.) ) 9 | import qualified Brick.Widgets.List as BrickList 10 | import Brick.Widgets.Edit as E 11 | import Web.Browser 12 | 13 | 14 | import BrickApp.ModeAction.Progress 15 | import Gopher 16 | import BrickApp.Types 17 | import BrickApp.Types.Names 18 | import BrickApp.Types.Helpers 19 | 20 | -- | Get the `MenuLine` which is currently selected, or Nothing. 21 | selectedMenuLine :: Menu -> Maybe MenuLine 22 | selectedMenuLine menu = case l ^. BrickList.listSelectedL of 23 | Just lineNumber -> Just $ menuLine gopherMenu lineNumber 24 | Nothing -> Nothing 25 | where (Menu (gopherMenu, l, _)) = menu 26 | 27 | -- | Make a request based on the currently selected Gopher menu item and change 28 | -- the application state (GopherBrowserState) to reflect the change. 29 | newStateFromSelectedMenuItem :: GopherBrowserState -> IO GopherBrowserState 30 | newStateFromSelectedMenuItem gbs = case lineType of -- FIXME: it's itemType 31 | (Canonical ct) -> case ct of 32 | Directory -> initProgressMode gbs Nothing (host, port, resource, MenuMode, Just displayString) 33 | File -> initProgressMode gbs Nothing (host, port, resource, TextFileMode, Just displayString) 34 | IndexSearchServer -> pure gbs 35 | { gbsRenderMode = SearchMode 36 | , gbsBuffer = SearchBuffer $ Search 37 | { sbQuery = "" 38 | , sbFormerBufferState = gbsBuffer gbs 39 | , sbSelector = resource 40 | , sbPort = port 41 | , sbHost = host 42 | , sbEditorState = E.editor (MyName MyViewport) Nothing "" 43 | } 44 | } 45 | ImageFile -> 46 | initProgressMode gbs Nothing (host, port, resource, FileBrowserMode, Nothing) 47 | -- FIXME: it's possible this could be an incorrect exception if everything isn't covered, like telnet 48 | -- so I need to implement those modes above and then of course this can be the catchall... 49 | _ -> initProgressMode gbs Nothing (host, port, resource, FileBrowserMode, Nothing) 50 | (NonCanonical nct) -> case nct of 51 | HtmlFile -> openBrowser (T.unpack $ T.drop 4 resource) >> pure gbs 52 | InformationalMessage -> pure gbs 53 | -- FIXME: same as previous comment... 54 | _ -> initProgressMode gbs Nothing (host, port, resource, FileBrowserMode, Nothing) 55 | where 56 | menu = getMenu gbs 57 | (host, port, resource, lineType, displayString) = case selectedMenuLine menu of 58 | -- ParsedLine 59 | Just (Parsed gl) -> (glHost gl, glPort gl, glSelector gl, glType gl, glDisplayString gl) 60 | -- FIXME: why even error here? 61 | -- Unrecognized/unparseable line 62 | Just (Unparseable _ ) -> error "Can't do anything with unrecognized line." 63 | Nothing -> error "Nothing is selected!" 64 | -------------------------------------------------------------------------------- /src/BrickApp/ModeAction/Open.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- | UI for editing the open config for setting commands associated with 4 | -- opening a menu item of specific types. 5 | module BrickApp.ModeAction.Open where 6 | 7 | import Data.List ( intersperse ) 8 | 9 | import qualified Data.Map as Map 10 | import qualified Brick.Widgets.Dialog as D 11 | import qualified Brick.Focus as F 12 | import Brick.Widgets.Core 13 | ( (<+>) 14 | , hLimit 15 | , vLimit 16 | , str 17 | , txt 18 | , visible 19 | ) 20 | import qualified Brick.Main as M 21 | import qualified Brick.Types as T 22 | import Brick.Widgets.Edit as E 23 | import qualified Data.ConfigFile as CF 24 | 25 | import BrickApp.Types.Helpers 26 | import BrickApp.Utils ( myNameScroll ) 27 | import Config.ConfigOpen 28 | import Config 29 | import BrickApp.Types 30 | import BrickApp.Types.Names 31 | 32 | -- All this field name stuff should probably go in UI.Types! TODO FIXME 33 | allFieldNames :: [AnyName] 34 | allFieldNames = map FieldName [FileField ..] 35 | 36 | firstFieldName :: AnyName 37 | firstFieldName = head allFieldNames 38 | 39 | lastFieldName :: AnyName 40 | lastFieldName = last allFieldNames 41 | 42 | beginningScroll :: T.EventM AnyName () 43 | beginningScroll = M.vScrollToBeginning myNameScroll >> M.vScrollBy myNameScroll 3 44 | 45 | --initConfigOpenMode :: GopherBrowserState -> GopherBrowserState 46 | initConfigOpenMode :: 47 | GopherBrowserState 48 | -> IO GopherBrowserState 49 | initConfigOpenMode gbs = gbsToGiveBack 50 | where 51 | gbsToGiveBack :: IO GopherBrowserState 52 | gbsToGiveBack = do 53 | initState <- initialState gbs 54 | pure $ gbs 55 | { gbsRenderMode = OpenConfigMode 56 | , gbsBuffer = OpenConfigBuffer initState 57 | } 58 | 59 | initialState :: GopherBrowserState -> IO OpenConfigState 60 | initialState gbs' = do 61 | configParser <- getUserOpenConfig 62 | fileFieldValue <- (readConfigParserValue configParser "open-assocs" "File") 63 | directoryFieldValue <- (readConfigParserValue configParser "open-assocs" "Directory") 64 | csoPhoneBookServerFieldValue <- (readConfigParserValue configParser "open-assocs" "CsoPhoneBookServer") 65 | errorFieldValue <- (readConfigParserValue configParser "open-assocs" "Error") 66 | binHexedMacintoshFileValue <- (readConfigParserValue configParser "open-assocs" "BinHexedMacintoshFile") 67 | dosBinaryArchiveValue <- (readConfigParserValue configParser "open-assocs" "DosBinaryArchive") 68 | unixUuencodedFileValue <- (readConfigParserValue configParser "open-assocs" "UnixUuencodedFile") 69 | indexSearchServerValue <- (readConfigParserValue configParser "open-assocs" "IndexSearchServer") 70 | textBasedTelnetSessionValue <- (readConfigParserValue configParser "open-assocs" "TextBasedTelnetSession") 71 | binaryFileValue <- (readConfigParserValue configParser "open-assocs" "BinaryFile") 72 | redundantServerValue <- (readConfigParserValue configParser "open-assocs" "RedundantServer") 73 | gifFileValue <- (readConfigParserValue configParser "open-assocs" "GifFile") 74 | imageFileValue <- (readConfigParserValue configParser "open-assocs" "ImageFile") 75 | tn3270SessionValue <- (readConfigParserValue configParser "open-assocs" "Tn3270Session") 76 | docValue <- (readConfigParserValue configParser "open-assocs" "Doc") 77 | htmlFileValue <- (readConfigParserValue configParser "open-assocs" "HtmlFile") 78 | informationalMessageValue <- (readConfigParserValue configParser "open-assocs" "InformationalMessage") 79 | soundFileValue <- (readConfigParserValue configParser "open-assocs" "SoundFile") 80 | pure $ OpenConfigState gbs' 81 | (F.focusRing allFieldNames) 82 | (E.editor (FieldName FileField) Nothing fileFieldValue) 83 | (E.editor (FieldName DirectoryField) Nothing directoryFieldValue) 84 | (E.editor (FieldName CsoPhoneBookServerField) Nothing csoPhoneBookServerFieldValue) 85 | (E.editor (FieldName ErrorField) Nothing errorFieldValue) 86 | (E.editor (FieldName BinHexedMacintoshFileField) Nothing binHexedMacintoshFileValue) 87 | (E.editor (FieldName DosBinaryArchiveField) Nothing dosBinaryArchiveValue) 88 | (E.editor (FieldName UnixUuencodedFileField) Nothing unixUuencodedFileValue) 89 | (E.editor (FieldName IndexSearchServerField) Nothing indexSearchServerValue) 90 | (E.editor (FieldName TextBasedTelnetSessionField) Nothing textBasedTelnetSessionValue) 91 | (E.editor (FieldName BinaryFileField) Nothing binaryFileValue) 92 | (E.editor (FieldName RedundantServerField) Nothing redundantServerValue) 93 | (E.editor (FieldName GifFileField) Nothing gifFileValue) 94 | (E.editor (FieldName ImageFileField) Nothing imageFileValue) 95 | (E.editor (FieldName Tn3270SessionField) Nothing tn3270SessionValue) 96 | (E.editor (FieldName DocField) Nothing docValue) 97 | (E.editor (FieldName HtmlFileField) Nothing htmlFileValue) 98 | (E.editor (FieldName InformationalMessageField) Nothing informationalMessageValue) 99 | (E.editor (FieldName SoundFileField) Nothing soundFileValue) 100 | 101 | -- TODO: this could go in Types 102 | -- | FIXME: isn't this redundant because of the representation 103 | editFields :: [([Char], OpenConfigState -> Editor String AnyName)] 104 | editFields = 105 | [ ("File (plaintext)", editFile) 106 | , ("Directory", editDirectory) 107 | , ("CSO phonebook server", editCsoPhoneBookServer) 108 | , ("Gopher error", editError) 109 | , ("Bin-hexed Macintosh file", editBinHexedMacintoshFile) 110 | , ("DOS binary archive", editDosBinaryArchive) 111 | , ("Unix Uuencoded File", editUnixUuencodedFile) 112 | , ("Index search server", editIndexSearchServer) 113 | , ("Text-based Telnet session", editTextBasedTelnetSession) 114 | , ("Binary file", editBinaryFile) 115 | , ("Redundant server", editRedundantServer) 116 | , ("GIF file", editGifFile) 117 | , ("Image file", editImageFile) 118 | , ("TN3270 Session", editTn3270Session) 119 | , ("Document", editDoc) 120 | , ("HTML/web", editHtmlFile) 121 | , ("Info message", editInformationalMessage) 122 | , ("Sound file", editSoundFile) 123 | ] 124 | 125 | editWidgets :: OpenConfigState -> [T.Widget AnyName] 126 | editWidgets openConfigState = 127 | intersperse (str " ") $ map makeField editFields 128 | where 129 | -- if it is the current focus add "visible" 130 | customRenderEditor :: Bool -> E.Editor String AnyName -> T.Widget AnyName 131 | customRenderEditor hasFocus theEditor = 132 | if hasFocus 133 | then visible $ E.renderEditor (str . unlines) hasFocus theEditor 134 | else E.renderEditor (str . unlines) hasFocus theEditor 135 | 136 | fieldWidth = 30 137 | 138 | --makeField :: (String, * -> *) -> [Widget n] 139 | makeField (label, someEdit) = 140 | let editField = F.withFocusRing (focusRing openConfigState) customRenderEditor (someEdit openConfigState) 141 | in str (label ++ ": ") <+> (vLimit 1 $ hLimit fieldWidth editField) 142 | 143 | -- | Used to return the `GopherBrowserState` from before `OpenConfigMode` was activated. 144 | returnFormerGbs :: GopherBrowserState -> GopherBrowserState 145 | returnFormerGbs gbs = 146 | let (OpenConfigBuffer openConfigState) = gbsBuffer gbs 147 | in formerState openConfigState 148 | 149 | -- FIXME: could just be a refocus by taking F.focusNext or F.focusPrev as arg 150 | focusNext :: OpenConfigState -> OpenConfigState 151 | focusNext openConfigState = 152 | let modified = F.focusNext $ focusRing openConfigState 153 | in openConfigState { focusRing = modified } 154 | 155 | focusPrev :: OpenConfigState -> OpenConfigState 156 | focusPrev openConfigState = 157 | let modified = F.focusPrev $ focusRing openConfigState 158 | in openConfigState { focusRing = modified } 159 | 160 | -- | Update the `GopherBrowserState` with the new `OpenConfigState` 161 | updateGbs :: GopherBrowserState -> (OpenConfigState -> OpenConfigState) -> GopherBrowserState 162 | updateGbs gbs performOnOpenConfigState = 163 | let (OpenConfigBuffer openConfigState) = gbsBuffer gbs 164 | mutatedOpenConfigState = performOnOpenConfigState openConfigState 165 | in gbs { gbsBuffer = OpenConfigBuffer mutatedOpenConfigState } 166 | 167 | -- FIXME: scrollBy should just be an enum of scroll up or scroll down 168 | --scrollFocus :: FocusRing -> ViewportScroll n -> Int -> () 169 | {- 170 | scrollFocus ring viewport' scrollBy 171 | | scrollBy > numberOfFocusEntries = M.vScrollToBeginning viewport' 172 | | 173 | where 174 | numberOfFocusEntries = focusRingLength ring 175 | -} 176 | 177 | {- 178 | scrollFocus ... 179 | focusRingCursor getFocusRing gbs 180 | where 181 | getFocusRing :: GopherBrowserState -> FocusRing n 182 | getFocusRing gbs = do 183 | let (OpenConfigBuffer openConfigState) = gbsBuffer gbs 184 | in focusRing openConfigState 185 | -} 186 | 187 | -- FIXME: Hacky and hard-coded... minor improvemnt would be to 188 | -- LENGTH the head and footer... 189 | scrollFocusNext :: F.FocusRing AnyName -> T.EventM AnyName () 190 | scrollFocusNext ring = 191 | case F.focusGetCurrent ring of 192 | Just someFieldName -> 193 | if someFieldName == lastFieldName 194 | -- FIXME 195 | then beginningScroll 196 | else M.vScrollBy myNameScroll 2 197 | Nothing -> beginningScroll 198 | 199 | -- FIXME: SHOULD REPLACE WITH SHOW MAP ENUM THING OF ITEMTYPES 200 | -- in gopher.hs, like an all types enum bounds 201 | allTypesAsStrings :: [[Char]] 202 | allTypesAsStrings = 203 | [ "File" 204 | , "Directory" 205 | , "CsoPhonebookServer" 206 | , "Error" 207 | , "BinHexedMacintoshFile" 208 | , "DosBinaryArchive" 209 | , "UnixUuencodedFile" 210 | , "IndexSearchServer" 211 | , "TextBasedTelnetSession" 212 | , "BinaryFile" 213 | , "RedundantServer" 214 | , "GifFile" 215 | , "ImageFile" 216 | , "TN3270Session" 217 | , "Document" 218 | , "HtmlFile" 219 | , "InformationalMessage" 220 | , "SoundFile" 221 | ] 222 | 223 | scrollFocusPrev :: F.FocusRing AnyName -> T.EventM AnyName () 224 | scrollFocusPrev ring = 225 | case F.focusGetCurrent ring of 226 | Just someFieldName -> 227 | if someFieldName == firstFieldName 228 | -- FIXME 229 | then endScroll 230 | else M.vScrollBy myNameScroll (-2) 231 | Nothing -> endScroll 232 | where 233 | endScroll = M.vScrollToEnd myNameScroll >> M.vScrollBy myNameScroll (-2) 234 | 235 | -- Should send notification about being saved TODO in status 236 | saveConfig :: OpenConfigState -> IO () 237 | saveConfig openConfig = do 238 | -- First create the new config from the editor values (don't save yet!)... 239 | -- I feel like this could be easily accomplished with fold monad... 240 | let emptyConf = case (CF.add_section customEmptyCP "open-assocs") of 241 | Left readError -> error (show readError) 242 | Right cp -> cp 243 | pendingConf = foldl (\b a -> pendingSet b a) emptyConf allTypesAsStrings 244 | 245 | -- Now read the existing config, do a merge and write! 246 | userConfig <- getUserOpenConfig 247 | let finalConfig = CF.merge userConfig pendingConf 248 | outPath <- getUserOpenConfigPath 249 | writeFile outPath (CF.to_string finalConfig) 250 | where 251 | -- There will always be at least [""] due to the way edit fields work in `Brick`. 252 | getEditValue recordFunc = head $ E.getEditContents (recordFunc openConfig) 253 | 254 | -- TODO: need to handle with Either 255 | --pendingSet :: CF.ConfigParser -> String -> CF.ConfigParser 256 | pendingSet conf itemType = 257 | -- This logic could be a higher order function for config 258 | let val = CF.set conf "open-assocs" itemType (getEditValue (itemTypeStrToEdit itemType)) 259 | in case val of 260 | Left readError -> error (show readError) 261 | Right cp -> cp 262 | 263 | itemTypeStrToEdit itemType = 264 | -- TODO: this should really be a general map somewhere to do a lookup 265 | case itemType of 266 | "File" -> editFile 267 | "Directory" -> editDirectory 268 | "CsoPhonebookServer" -> editCsoPhoneBookServer 269 | "Error" -> editError 270 | "BinHexedMacintoshFile" -> editBinHexedMacintoshFile 271 | "DosBinaryArchive" -> editDosBinaryArchive 272 | "UnixUuencodedFile" -> editUnixUuencodedFile 273 | "IndexSearchServer" -> editIndexSearchServer 274 | "TextBasedTelnetSession" -> editTextBasedTelnetSession 275 | "BinaryFile" -> editBinaryFile 276 | "RedundantServer" -> editRedundantServer 277 | "GifFile" -> editGifFile 278 | "ImageFile" -> editImageFile 279 | "TN3270Session" -> editTn3270Session 280 | "Document" -> editDoc 281 | "HtmlFile" -> editHtmlFile 282 | "InformationalMessage" -> editInformationalMessage 283 | "SoundFile" -> editSoundFile 284 | _ -> error "impossible. placeholder here." 285 | 286 | addSavedPopup :: GopherBrowserState -> GopherBrowserState 287 | addSavedPopup gbs = 288 | let choices = [ ("Ok", Ok) ] 289 | pop = Popup 290 | { pDialogWidget = D.dialog (Just "Saved!") (Just (0, choices)) 50--wtf what about max width for bug 291 | , pDialogMap = Map.fromList [("Ok", pure . closePopup)] 292 | , pDialogBody = txt "Saved successfully to ~/.config/waffle/open.ini" 293 | } 294 | in gbs { gbsPopup = Just pop } 295 | -------------------------------------------------------------------------------- /src/BrickApp/ModeAction/Progress.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- FIXME: implement network error dialog boxes here and return state if fail? 4 | -- this would imply the need to have a fallback state, right? 5 | -- | Handle indication of download progress for various UI.Util.RenderMode types, like downloading 6 | -- menus, text files, and binary file downloads. 7 | module BrickApp.ModeAction.Progress where 8 | 9 | import qualified Data.Map as Map 10 | import Control.Exception 11 | import Data.Text.Encoding.Error (lenientDecode) 12 | import Data.Text.Encoding as E 13 | import qualified Data.Text as T 14 | import Data.Foldable 15 | import qualified Data.ByteString as ByteString 16 | import Control.Concurrent ( forkIO ) 17 | import System.Directory ( renameFile ) 18 | 19 | import qualified Brick.Widgets.Dialog as D 20 | import System.FilePath ( takeFileName ) 21 | import Network.Simple.TCP 22 | import qualified Brick.Widgets.FileBrowser as FB 23 | import Brick.Widgets.Core ( txt, cached, viewport, hLimitPercent ) 24 | import qualified Brick.Main as M 25 | import qualified Brick.BChan 26 | import qualified Data.ByteString.Char8 as B8 27 | import qualified Brick.Types as T 28 | import System.IO.Temp ( emptySystemTempFile ) 29 | 30 | import BrickApp.Types 31 | import BrickApp.Types.Names 32 | import BrickApp.Types.Helpers 33 | import BrickApp.Utils 34 | import Gopher 35 | import GopherNet ( writeAllBytes ) 36 | import Open ( openItem ) 37 | 38 | -- TODO: implement OPEN 39 | 40 | -- FIXME: also used by save.hs 41 | selectNothing :: FB.FileInfo -> Bool 42 | selectNothing _ = False 43 | 44 | -- FIXME: need to combine vScroll and hScroll into a single event! because otherwise 45 | -- it's only giving back the event for hScroll! 46 | -- Things to do when switching modes! Namely reset viewports... 47 | modeTransition :: T.EventM AnyName () 48 | modeTransition = do 49 | --M.vScrollToBeginning myNameScroll 50 | traverse_ M.vScrollToBeginning [myNameScroll, mainViewportScroll, menuViewportScroll, textViewportScroll] 51 | traverse_ M.hScrollToBeginning [myNameScroll, mainViewportScroll, menuViewportScroll, textViewportScroll] 52 | 53 | -- FIXME: could reset the scroll here...? 54 | -- | The entrypoint for using "progress mode" which... 55 | initProgressMode :: GopherBrowserState -> Maybe History -> Location -> IO GopherBrowserState 56 | initProgressMode gbs history location@(_, _, _, mode, _) = 57 | let 58 | (downloader, message) = case mode of 59 | TextFileMode -> (progressCacheable, "text file 📄") 60 | MenuMode -> (progressCacheable, "menu 📂") 61 | FileBrowserMode -> (progressDownloadBytes, "binary file") 62 | -- This error should be a dialog box instead... 63 | m -> error $ "Unsupported mode requested for progress mode: " ++ show m 64 | initialProgGbs = gbs 65 | { gbsRenderMode = ProgressMode 66 | , gbsBuffer = ProgressBuffer $ Progress 67 | { pbBytesDownloaded = 0 68 | , pbInitGbs = gbs 69 | , pbConnected = False 70 | , pbIsFromCache = isCached location (gbsCache gbs) 71 | , pbMessage = "Downloading a " <> message 72 | } 73 | } 74 | -- Should catch network error in a popup (representational). 75 | in forkIO (downloader initialProgGbs history location) >> pure initialProgGbs 76 | 77 | -- FIXME: merge with initProgressMode 78 | initOpenMode :: GopherBrowserState -> Location -> ItemType -> IO GopherBrowserState 79 | initOpenMode gbs location itemType = 80 | let 81 | initialProgGbs = gbs 82 | { gbsRenderMode = ProgressMode 83 | , gbsBuffer = ProgressBuffer $ Progress 84 | { pbBytesDownloaded = 0 85 | , pbInitGbs = gbs 86 | , pbConnected = False 87 | , pbIsFromCache = isCached location (gbsCache gbs) 88 | , pbMessage = "Downloading a " <> T.pack (show itemType) 89 | } 90 | } 91 | -- Should catch network error in a popup (representational). 92 | in forkIO (progressOpen initialProgGbs itemType location) >> pure initialProgGbs 93 | 94 | -- FIXME: This could basically be turned into a higher level function with progressDownloadBytes or whatever which combo 95 | progressOpen :: GopherBrowserState -> ItemType -> Location -> IO () 96 | progressOpen gbs itemType (host, port, resource, _, _) = 97 | connect (T.unpack host) (show port) $ \(connectionSocket, _) -> do 98 | let chan = gbsChan gbs 99 | initialGBS = pbInitGbs (getProgress gbs) -- FIXME: not needed 100 | send connectionSocket (B8.pack $ T.unpack $ resource <> "\r\n") 101 | -- FIXME: what if this is left over from last time? 102 | tempFilePath <- emptySystemTempFile "waffle.download.tmp" 103 | Brick.BChan.writeBChan chan (NewStateEvent gbs) 104 | -- need to only fetch as many bytes as it takes to get period on a line by itself to 105 | -- close the connection. 106 | writeAllBytes (Just counterMutator) (Just gbs) connectionSocket tempFilePath 107 | -- open with the propper association 108 | _ <- openItem itemType tempFilePath 109 | -- Final event is reverting to former event! 110 | -- should we be using doFinalEvent instead? 111 | Brick.BChan.writeBChan chan (FinalNewStateEvent initialGBS) 112 | pure () 113 | 114 | -- THIS IS A CALLBACK FOR GOPHERNET 115 | counterMutator :: GopherBrowserState -> Maybe ByteString.ByteString -> IO GopherBrowserState 116 | counterMutator gbs someBytes = 117 | let bytesReceived = case someBytes of 118 | Nothing -> 0 119 | -- We count the bytes each time because the second-to-last response can have 120 | -- under the recvChunkSize. The last response will always be Nothing. 121 | (Just n) -> ByteString.length n 122 | newGbs = addProgBytes' gbs bytesReceived 123 | in Brick.BChan.writeBChan (gbsChan gbs) (NewStateEvent newGbs) >> pure newGbs 124 | where 125 | --addProgBytes :: GopherBrowserState -> Int -> GopherBrowserState 126 | addProgBytes' gbs' nbytes = 127 | let cb x = x 128 | { pbBytesDownloaded = pbBytesDownloaded (getProgress gbs') + nbytes 129 | , pbConnected = True 130 | } 131 | in updateProgressBuffer gbs' cb 132 | 133 | -- FIXME: redocument 134 | -- TODO: better name? 135 | -- | Handle a connection, including reporting exceptions by creating a new 136 | -- `GopherBrowserState` that has a popup containing the exception message, 137 | -- which is sent by a `FinalNewStateEvent`. 138 | -- 139 | -- "handler" is a function which does some `IO ()` action with the 140 | -- `(Socket, SockAddr)` in the event that nothing went wrong when 141 | -- establishing the socket connection. 142 | gracefulSock :: GopherBrowserState -> Location -> ((Socket, SockAddr) -> IO ()) -> IO () 143 | gracefulSock gbs (host, port, _, _, _) handler = do 144 | result <- try $ connectSock (T.unpack host) (show port) :: IO (Either SomeException (Socket, SockAddr)) 145 | case result of 146 | -- Left means exception: we want to make a popup to display that error. 147 | Left ex -> makeErrorPopup gbs $ T.pack (show ex) 148 | -- Right means we connected to the sock; let's give back the handler. 149 | Right val -> handler val 150 | 151 | -- FIXME: redocument 152 | -- | This is pretty much only for `gracefulSock`. 153 | -- 154 | -- Handle making a new state which has a popup for a socket connection exception. 155 | -- This new state is based on the former state, that is the state which came 156 | -- before `ProgressMode` we're currently in. This allows us to gracefully exit 157 | -- `ProgressMode` in the event of being unable to establish a socket connection. 158 | makeErrorPopup :: GopherBrowserState -> T.Text -> IO () 159 | makeErrorPopup gbs' exMsg = 160 | let formerGbs = pbInitGbs (getProgress gbs') 161 | -- TODO: why are we getting the gbsStatus formerGbs here? FIXME 162 | -- Get the `RenderMode` of the `GopherBrowserState` which proceeded the 163 | -- `ProgressMode` we're currently in. If the mode which activated 164 | -- `ProgressMode` was `GotoMode` we get the associated `gbsStatus` if 165 | -- it exists, so we can get the mode preceeding `GotoMode`! However, 166 | -- if no such `gbsStatus` is set (if it is `Nothing`) we know that... 167 | formerMode = case gbsRenderMode formerGbs of 168 | GotoMode -> case gbsStatus formerGbs of 169 | -- I DON'T UNDERSTAND THE MEANING OF THIS FIXME 170 | Just n -> seFormerMode n 171 | -- ... SAME HERE... plus I think no status will inevitably result in error? it needs to be able 172 | -- to return to former state! I think this happens because in Goto.hs' `mkGotoResponseState` 173 | -- will set the status to `Nothing` if it passes all the checks, however this final check 174 | -- results in a problem with that: you cannot return to the mode preceeding Goto if there's an 175 | -- error here, because that mode has been cleared! 176 | Nothing -> gbsRenderMode formerGbs 177 | x -> x 178 | newBuffState = formerGbs { gbsRenderMode = formerMode } 179 | popup = Popup 180 | { pDialogWidget = D.dialog (Just "Network/Goto Error!") (Just (0, [ ("Ok", Ok) ])) 50--wtf what about max width for bug 181 | , pDialogMap = Map.fromList [("Ok", pure . closePopup)] 182 | , pDialogBody = txt exMsg 183 | } 184 | errorPopup = Just popup 185 | finalState = newBuffState { gbsPopup = errorPopup }-- TODO, FIXME: deactivate status 186 | chan = gbsChan finalState 187 | in Brick.BChan.writeBChan chan (FinalNewStateEvent finalState) 188 | 189 | -- | Download bytes via Gopher, using progress events to report status. Eventually 190 | -- gives back the path to the new temporary file it has created. This is used to 191 | -- download bytes and create a new temp/cache file based on the download, while 192 | -- handling progress events. This is not for downloading binary files, but instead 193 | -- for downloading textual data to be displayed by Waffle. 194 | -- 195 | -- If the history argument is Nothing, then the new history will be updated with the 196 | -- new location. Otherwise the history supplied will be used in the application state. 197 | -- This is important for refreshing or navigating history (you don't want to update 198 | -- the history in those cases, so you supply Nothing). 199 | progressGetBytes :: GopherBrowserState -> Maybe History -> Location -> IO () 200 | progressGetBytes initialProgGbs history location@(_, _, resource, _, _) = 201 | gracefulSock initialProgGbs location handleResult 202 | where 203 | handleResult (connectionSocket, _) = do 204 | -- Send the magic/selector string (request a path) to the websocket we're connected to. 205 | -- This allows us to later receive the bytes located at this "path." 206 | send connectionSocket (B8.pack $ T.unpack resource ++ "\r\n") 207 | -- Send the first event which is just the GBS we received to begin with... IDK, actually, 208 | -- why I even bother to do this! 209 | let chan = gbsChan initialProgGbs 210 | Brick.BChan.writeBChan chan (NewStateEvent initialProgGbs) 211 | -- Now we fill a temporary file with the contents we receive via TCP, as mentioned earlier, 212 | -- since we've selected the remote file with the selector string. We get back the path 213 | -- to the temporary file and we also get its contents. The file path is used for the cache. 214 | -- The contents is used to update GBS with the appropriate mode (as a UTF8 string). 215 | tempFilePath <- emptySystemTempFile "waffle.cache.tmp"-- TODO: needs better template/pattern filename 216 | writeAllBytes (Just counterMutator) (Just initialProgGbs) connectionSocket tempFilePath 217 | -- NOTE: it's a bit silly to write all bytes and then read from the file we wrote, but 218 | -- I'll mark this fix as a TODO, because I just did a major refactor and it's not a huge 219 | -- deal... 220 | contents <- ByteString.readFile tempFilePath 221 | -- Prepare the cache with this new temporary file that was created above. 222 | -- FIXME: what if location already exists? like if we're refreshing? 223 | let newCache = cacheInsert location tempFilePath (gbsCache initialProgGbs) 224 | -- We setup the final event with a GBS of the specified render mode. 225 | doFinalEvent chan initialProgGbs history location (E.decodeUtf8With lenientDecode contents) newCache 226 | -- Finally we close the socket! We're done! 227 | closeSock connectionSocket 228 | 229 | -- | This is for final events that change the render mode based on the contents. 230 | doFinalEvent 231 | :: Brick.BChan.BChan CustomEvent 232 | -> GopherBrowserState 233 | -> Maybe History 234 | -> Location 235 | -> T.Text 236 | -> Cache 237 | -> IO () 238 | doFinalEvent chan initialProgGbs history location@(_, _, _, mode, _) contents newCache = do 239 | let 240 | finalState = case mode of 241 | TextFileMode -> initialProgGbs 242 | { gbsLocation = location 243 | -- FIXME: what the heck?!?! this needs to go in textfile or util or something. need to change tfcontents to tfviewport thing idk 244 | , gbsBuffer = TextFileBuffer $ TextFile { tfContents = viewport (MyName TextViewport) T.Both $ hLimitPercent 100 $ cached (MyName TextViewport) $ txt $ cleanAll contents, tfTitle = locationAsString location } 245 | , gbsRenderMode = TextFileMode 246 | , gbsHistory = maybeHistory 247 | , gbsCache = newCache 248 | } 249 | MenuMode -> newStateForMenu 250 | chan 251 | (makeGopherMenu contents)--FIXME: doesn't this need clean first? or is this handled by newStateForMenu? 252 | location 253 | maybeHistory 254 | newCache 255 | m -> error $ "Cannot create a final progress state for: " ++ show m 256 | -- TEST FIXME 257 | Brick.BChan.writeBChan chan $ ClearCacheEvent M.invalidateCache 258 | Brick.BChan.writeBChan chan (FinalNewStateEvent finalState) 259 | -- The final progress event, which changes the state to the render mode specified, using 260 | -- the GBS created above. 261 | Brick.BChan.writeBChan chan (FinalNewStateEvent finalState) 262 | pure () 263 | where 264 | maybeHistory = case history of 265 | (Just h) -> h 266 | Nothing -> newChangeHistory initialProgGbs location 267 | 268 | -- FIXME: the initial message should say something about loading cache if it is loading from cache 269 | -- | The progress downloader for resources we want to cache, which also end 270 | -- in a render mode associated with the resource requested. Not for save mode. 271 | progressCacheable :: GopherBrowserState -> Maybe History -> Location -> IO () 272 | progressCacheable gbs history location@(_, _, _, _, _) = 273 | case cacheLookup location $ gbsCache gbs of 274 | -- There is a cache for the requested location, so let's load that, instead... 275 | (Just pathToCachedFile) -> do 276 | contents <- ByteString.readFile pathToCachedFile 277 | -- We use "doFinalEvent" because it will switch the mode/state for the content of the cache file! 278 | doFinalEvent (gbsChan gbs) gbs history location (E.decodeUtf8With lenientDecode contents) (gbsCache gbs) 279 | -- There is no cache for the requested location, so we must make a request and cache it! 280 | Nothing -> progressGetBytes gbs history location 281 | 282 | -- TODO: make a version of this for huge text files, or even huge menus! 283 | -- | Emits events of a new application state (GBS). Starts by only 284 | -- updating the progress buffer until the download is finished. When finished, 285 | -- a new application state is given which uses the NextState info which contains 286 | -- the new RenderMode and Buffer, which is the final event emitted. 287 | -- | Download a binary file to a temporary locationkk 288 | -- Emits an Brick.T.AppEvent 289 | progressDownloadBytes :: GopherBrowserState -> Maybe History -> Location -> IO () 290 | progressDownloadBytes gbs _ (host, port, resource, _, _) = 291 | connect (T.unpack host) (show port) $ \(connectionSocket, _) -> do 292 | let chan = gbsChan gbs 293 | formerBufferState = gbsBuffer $ pbInitGbs (getProgress gbs) -- FIXME: not needed 294 | send connectionSocket (B8.pack $ T.unpack $ resource <> "\r\n") 295 | -- FIXME: what if this is left over from last time? 296 | tempFilePath <- emptySystemTempFile "waffle.download.tmp" 297 | Brick.BChan.writeBChan chan (NewStateEvent gbs) 298 | -- need to only fetch as many bytes as it takes to get period on a line by itself to 299 | -- close the connection. 300 | writeAllBytes (Just counterMutator) (Just gbs) connectionSocket tempFilePath 301 | -- when exist should just emit a final event which has contents? 302 | -- will you need transactional buffer? how else can you put into next state? 303 | -- you COULD overwrite next state with new content as pwer writebytes o in callback 304 | -- of save :) easy peasy 305 | --pure $ wow 306 | -- THE FINAL EVENT... 307 | x <- FB.newFileBrowser selectNothing (MyName MyViewport) Nothing 308 | let finalState = gbs 309 | { gbsRenderMode = FileBrowserMode 310 | , gbsBuffer = FileBrowserBuffer $ SaveBrowser 311 | { fbFileBrowser = x -- FIXME 312 | -- FIXME: move temp to specified location 313 | , fbCallBack = (tempFilePath `renameFile`) 314 | , fbIsNamingFile = False 315 | , fbFileOutPath = "" 316 | , fbOriginalFileName = takeFileName $ T.unpack resource 317 | , fbFormerBufferState = formerBufferState 318 | } 319 | } 320 | -- We don't use doFinalEvent, because the file saver (which this is for) works a bit differently! 321 | Brick.BChan.writeBChan chan (FinalNewStateEvent finalState) 322 | pure () 323 | 324 | -- FIXME: this is a hacky way to avoid circular imports 325 | -- FIXME: the only reason not using progress is because of progress auto history 326 | -- FIXME: can get an index error! should resolve with a dialog box. 327 | -- Shares similarities with menu item selection 328 | goHistory :: GopherBrowserState -> Int -> IO GopherBrowserState 329 | goHistory gbs when = do 330 | let 331 | (history, historyMarker) = gbsHistory gbs 332 | unboundIndex = historyMarker + when 333 | historyLastIndex = length history - 1 334 | newHistoryMarker 335 | | unboundIndex > historyLastIndex = historyLastIndex 336 | | unboundIndex < 0 = 0 337 | | otherwise = unboundIndex 338 | location = history !! newHistoryMarker 339 | newHistory = (history, newHistoryMarker) 340 | if historyMarker == newHistoryMarker 341 | then pure gbs 342 | else initProgressMode gbs (Just newHistory) location 343 | 344 | -- | Create a new history after visiting a new page. 345 | -- 346 | -- The only way to change the list of locations in history. Everything after 347 | -- the current location is dropped, then the new location is appended, and 348 | -- the history index increased. Thus, the new location is as far "forward" 349 | -- as the user can now go. 350 | -- 351 | -- See also: GopherBrowserState. 352 | newChangeHistory :: GopherBrowserState -> Location -> History 353 | newChangeHistory gbs newLoc = 354 | let (history, historyMarker) = gbsHistory gbs 355 | newHistory = take (historyMarker + 1) history ++ [newLoc] 356 | newHistoryMarker = historyMarker + 1 357 | in (newHistory, newHistoryMarker) 358 | 359 | -- | Go up a directory; go to the parent menu of whatever the current selector is. 360 | goParentDirectory :: GopherBrowserState -> IO GopherBrowserState 361 | goParentDirectory gbs = do 362 | let (host, port, magicString, _, _) = gbsLocation gbs 363 | parentMagicString = parentDirectory magicString 364 | case parentMagicString of 365 | Nothing -> pure gbs 366 | Just newLocation -> initProgressMode gbs Nothing (host, port, newLocation, MenuMode, Nothing) 367 | -------------------------------------------------------------------------------- /src/BrickApp/ModeAction/Search.hs: -------------------------------------------------------------------------------- 1 | module BrickApp.ModeAction.Search where 2 | 3 | import qualified Data.Text as T 4 | 5 | import Brick.Widgets.Edit as E 6 | 7 | import Gopher 8 | import BrickApp.Types 9 | import BrickApp.Types.Helpers 10 | import BrickApp.ModeAction.Progress 11 | 12 | -- | Form a new application state based on a Gopher search request. 13 | mkSearchResponseState :: GopherBrowserState -> IO GopherBrowserState 14 | mkSearchResponseState gbs = do 15 | let host = sbHost $ getSearch gbs 16 | port = sbPort $ getSearch gbs 17 | resource = sbSelector $ getSearch gbs 18 | query = T.unlines (E.getEditContents $ sbEditorState $ getSearch gbs) 19 | selector = searchSelector resource query 20 | initProgressMode gbs Nothing (host, port, selector, MenuMode, Nothing) 21 | -------------------------------------------------------------------------------- /src/BrickApp/Types.hs: -------------------------------------------------------------------------------- 1 | -- | UI models/types used in rendering the TUI. For the names see 2 | -- `UI.Types.Names`. Some of these models can be complex, so there 3 | -- are helper functions at `UI.Types.Helpers`. 4 | 5 | module BrickApp.Types where 6 | 7 | import qualified Data.Map as Map 8 | import qualified Data.Text as T 9 | 10 | import qualified Brick.Widgets.Dialog as D 11 | import Brick.Widgets.FileBrowser ( FileBrowser ) 12 | import Brick.Widgets.Edit as E 13 | import qualified Brick.BChan 14 | import qualified Brick.Types as T 15 | import qualified Brick.Widgets.List as BrickList -- (List)? FIXME 16 | import qualified Brick.Focus as F 17 | 18 | import Gopher ( GopherMenu ) 19 | import BrickApp.Types.Names 20 | 21 | -- | Used for rendering the TUI that changes the commands associated with 22 | -- opening specific menu items. 23 | data OpenConfigState = 24 | OpenConfigState { formerState :: GopherBrowserState 25 | , focusRing :: F.FocusRing AnyName 26 | , editFile :: E.Editor String AnyName 27 | , editDirectory :: E.Editor String AnyName 28 | , editCsoPhoneBookServer :: E.Editor String AnyName 29 | , editError :: E.Editor String AnyName 30 | , editBinHexedMacintoshFile :: E.Editor String AnyName 31 | , editDosBinaryArchive :: E.Editor String AnyName 32 | , editUnixUuencodedFile :: E.Editor String AnyName 33 | , editIndexSearchServer :: E.Editor String AnyName 34 | , editTextBasedTelnetSession :: E.Editor String AnyName 35 | , editBinaryFile :: E.Editor String AnyName 36 | , editRedundantServer :: E.Editor String AnyName 37 | , editGifFile :: E.Editor String AnyName 38 | , editImageFile :: E.Editor String AnyName 39 | , editTn3270Session :: E.Editor String AnyName 40 | , editDoc :: E.Editor String AnyName 41 | , editHtmlFile :: E.Editor String AnyName 42 | , editInformationalMessage :: E.Editor String AnyName 43 | , editSoundFile :: E.Editor String AnyName 44 | } 45 | 46 | -- This is used to indicate how many bytes have been downloaded 47 | -- of a menu or a save a text file etc, anything! 48 | data Progress = Progress { pbBytesDownloaded :: Int 49 | , pbMessage :: T.Text -- BETTER NAME NEEDED 50 | , pbInitGbs :: GopherBrowserState 51 | , pbConnected :: Bool 52 | , pbIsFromCache :: Bool 53 | } 54 | 55 | data SaveBrowser = SaveBrowser { fbFileBrowser :: FileBrowser AnyName 56 | , fbCallBack :: FilePath -> IO () 57 | , fbIsNamingFile :: Bool 58 | , fbFileOutPath :: FilePath 59 | , fbFormerBufferState :: Buffer 60 | , fbOriginalFileName :: FilePath 61 | } 62 | 63 | data Search = Search { sbQuery :: T.Text 64 | , sbFormerBufferState :: Buffer 65 | , sbSelector :: T.Text 66 | , sbPort :: Int 67 | , sbHost :: T.Text 68 | , sbEditorState :: EditorState 69 | } 70 | 71 | data Help = Help { hText :: TextFile 72 | , hFormerGbs :: GopherBrowserState 73 | } 74 | 75 | -- The first string is the locationAsString and the second is filepath to the 76 | -- tempfile. Maybe I should define "String" type as synonym CacheKey? or... 77 | -- LocationString? 78 | type Cache = Map.Map T.Text FilePath 79 | 80 | emptyCache :: Cache 81 | emptyCache = Map.empty 82 | 83 | -- FIXME: stop using List and use GenericList 84 | -- | For MenuBuffer... 85 | -- Simply used to store the current GopherMenu when viewing one during MenuMode. 86 | -- The second element is the widget which is used when rendering a GopherMenu. 87 | -- Simply used to store the current GopherMenu when viewing one during MenuMode. 88 | newtype Menu = Menu (GopherMenu, BrickList.List AnyName T.Text, FocusLines) 89 | 90 | -- | This is for the contents of a File to be rendered when in TextFileMode. 91 | -- this should be a combination of things. it should have the addres of the temporary file 92 | -- which should then be moved to the picked location 93 | data TextFile = TextFile { tfContents :: T.Widget AnyName-- Should actually be txt 94 | , tfTitle :: T.Text 95 | } 96 | 97 | -- TODO: maybe break down buffer items into separate rep file and make rep subpackage... 98 | -- | The data from which a UI is rendered. 99 | data Buffer 100 | = MenuBuffer Menu 101 | | TextFileBuffer TextFile 102 | | FileBrowserBuffer SaveBrowser 103 | | SearchBuffer Search 104 | | ProgressBuffer Progress 105 | | HelpBuffer Help 106 | | OpenConfigBuffer OpenConfigState 107 | 108 | -- | The line #s which have linkable entries. Used for jumping by number and n and p hotkeys and display stuff. 109 | -- use get elemIndex to enumerate 110 | type FocusLines = [Int] 111 | 112 | -- | The HistoryIndex is the index in the list of locations in the history. 113 | -- 0 is the oldest location in history. See also: GopherBrowserState. 114 | type HistoryIndex = Int 115 | 116 | -- TODO: maybe the location stack could be called history stack or something like that 117 | -- TODO: what if history also saved which line # you were on in cas eyou go back and forward 118 | -- The history is a list of locations, where 0th element is the oldest and new 119 | -- locations are appended. See also: newChangeHistory. 120 | type History = ([Location], HistoryIndex) 121 | 122 | -- FIXME, TODO: there's an actual HostName, ServiceName in Network.TCP.Simple 123 | -- FIXME: maybe at this point better to use record syntax 124 | -- | Gopher location in the form of domain, port, resource/magic string, 125 | -- the BrowserMode used to render it, and finally an optional display string. 126 | type Location = (T.Text, Int, T.Text, RenderMode, Maybe T.Text) 127 | 128 | -- FinalNewStateEvent is used for transition handlers and for sending the new state (like the new page; setting it as the new gbs) 129 | -- | Carries through the entire state I guess! 130 | -- think of this right now as a progress event 131 | data CustomEvent = NewStateEvent GopherBrowserState | FinalNewStateEvent GopherBrowserState | ClearCacheEvent (T.EventM AnyName ()) 132 | 133 | -- FIXME: move on from Popup to Dialog! or just have somethign else? maybe pair with a handler 134 | -- FIXME: But what if we don't want a label, widgets, help? maybe there should be different 135 | -- types of popups! 136 | {- 137 | data Popup = Popup 138 | { pLabel :: T.Text 139 | , pWidgets :: [T.Widget AnyName] 140 | , pHelp :: T.Text 141 | } 142 | -} 143 | 144 | data PopupDialogChoice = Ok | Cancel deriving Show 145 | 146 | -- In the future this will replace Popup because all popups can be dialogs (like with an "ok" button) 147 | data Popup = Popup 148 | { pDialogWidget :: D.Dialog PopupDialogChoice 149 | -- pDialogWidget :: D.Dialog PopupDialogChoice 150 | -- ^ The dialog widget itself. Will be rendered with the popup renderer, 151 | -- which is mostly just D.renderDialog... 152 | , pDialogMap :: Map.Map String (GopherBrowserState -> IO GopherBrowserState) 153 | , pDialogBody :: T.Widget AnyName 154 | --, pDialogHandler :: Event -> Dialog a -> EventM n (Dialog a) 155 | } 156 | 157 | -- Works in conjunction with other modes like GotoMode which handles editing the statusEditor state 158 | -- and using that to go to a certain URL. 159 | -- Note that GotoMode isn't necessarily a "rendermode" but an event mode... 160 | data StatusEditor = StatusEditor { seLabel :: T.Text, seEditorState :: EditorState, seFormerMode :: RenderMode } 161 | 162 | -- TODO: maybe define an empty gbs? 163 | -- | The application state for Brick. 164 | data GopherBrowserState = GopherBrowserState 165 | { gbsBuffer :: Buffer 166 | -- | The current location. 167 | , gbsLocation :: Location 168 | , gbsRenderMode :: RenderMode -- Should just be "gbsMode" and "Mode" FIXME 169 | -- See: History 170 | , gbsHistory :: History 171 | , gbsChan :: Brick.BChan.BChan CustomEvent 172 | , gbsPopup :: Maybe Popup 173 | , gbsCache :: Cache 174 | , gbsStatus :: Maybe StatusEditor 175 | } 176 | 177 | type EditorState = E.Editor T.Text AnyName 178 | 179 | -- FIXME: maybe "rendermode" is bad now and should jsut be called "mode" 180 | -- TODO: maybe rename filebrowsermode to SaveMode or SaveFileMode 181 | -- | Related to Buffer. Namely exists for History. 182 | data RenderMode = MenuMode 183 | | TextFileMode 184 | | FileBrowserMode 185 | | SearchMode 186 | | ProgressMode 187 | | HelpMode 188 | | GotoMode 189 | | OpenConfigMode 190 | | MenuJumpMode 191 | | BookmarksMode 192 | | AddBookmarkMode 193 | | MenuFindMode 194 | deriving (Eq, Show) 195 | -------------------------------------------------------------------------------- /src/BrickApp/Types/Helpers.hs: -------------------------------------------------------------------------------- 1 | -- | Access and update helpers for handling types from `UI.Types`. 2 | -- Functions for navigating `Ui.Types`. 3 | 4 | module BrickApp.Types.Helpers where 5 | 6 | import Data.Maybe ( isJust ) 7 | 8 | import qualified Brick.Focus as F 9 | import qualified Brick.Types as T 10 | 11 | import BrickApp.Types 12 | import BrickApp.Types.Names 13 | 14 | 15 | -- | Return the `focusRing` from the `GopherBrowserState`'s 16 | -- `OpenConfigState`. 17 | getFocusRing :: GopherBrowserState -> F.FocusRing AnyName 18 | getFocusRing gbs = 19 | let (OpenConfigBuffer openConfigState) = gbsBuffer gbs 20 | in focusRing openConfigState 21 | 22 | -- | Construct a new `MenuBuffer` in the `GopherBrowserState` using 23 | -- the supplied `Menu`. 24 | newMenuBuffer :: GopherBrowserState -> Menu -> GopherBrowserState 25 | newMenuBuffer gbs menu = gbs { gbsBuffer = MenuBuffer $ menu } 26 | 27 | -- | Get `Menu` out of the buffer in `GopherBrowserState`. 28 | getMenu :: GopherBrowserState -> Menu 29 | getMenu gbs = let (MenuBuffer m) = gbsBuffer gbs in m 30 | 31 | getOpenConfig :: GopherBrowserState -> OpenConfigState 32 | getOpenConfig gbs = let (OpenConfigBuffer openConfig) = gbsBuffer gbs in openConfig 33 | 34 | -- help file should have title "Help" FIXME 35 | -- Could use with below TODO NOTE 36 | getHelp :: GopherBrowserState -> Help 37 | getHelp gbs = let (HelpBuffer help) = gbsBuffer gbs in help 38 | 39 | getHelpTextFileContents :: GopherBrowserState -> T.Widget AnyName -- txt 40 | getHelpTextFileContents gbs = let (HelpBuffer help) = gbsBuffer gbs in tfContents $ hText help 41 | 42 | updateFileBrowserBuffer :: GopherBrowserState -> (SaveBrowser -> SaveBrowser) -> GopherBrowserState 43 | updateFileBrowserBuffer gbs f = 44 | let (FileBrowserBuffer sb) = gbsBuffer gbs 45 | in gbs { gbsBuffer = FileBrowserBuffer (f sb) } 46 | 47 | getProgress :: GopherBrowserState -> Progress 48 | getProgress gbs = let (ProgressBuffer p) = gbsBuffer gbs in p 49 | 50 | updateProgressBuffer :: GopherBrowserState -> (Progress -> Progress) -> GopherBrowserState 51 | updateProgressBuffer gbs f = 52 | let (ProgressBuffer p) = gbsBuffer gbs 53 | in gbs { gbsBuffer = ProgressBuffer (f p) } 54 | 55 | -- | Get the SaveBrowser from Buffer 56 | getSaveBrowser :: GopherBrowserState -> SaveBrowser 57 | getSaveBrowser gbs = let (FileBrowserBuffer sb) = gbsBuffer gbs in sb 58 | 59 | -- | Get the TextFile from Buffer. 60 | getTextFile :: GopherBrowserState -> TextFile 61 | getTextFile gbs = let (TextFileBuffer tf) = gbsBuffer gbs in tf 62 | 63 | getSearch :: GopherBrowserState -> Search 64 | getSearch gbs = let (SearchBuffer s) = gbsBuffer gbs in s 65 | 66 | updateSearchBuffer :: GopherBrowserState -> (Search -> Search) -> GopherBrowserState 67 | updateSearchBuffer gbs f = 68 | let (SearchBuffer sb) = gbsBuffer gbs 69 | in gbs { gbsBuffer = SearchBuffer (f sb) } 70 | 71 | isStatusEditing :: GopherBrowserState -> Bool 72 | isStatusEditing gbs = case gbsStatus gbs of 73 | -- Is this pattern even right? FIXME 74 | (Just StatusEditor {}) -> True 75 | _ -> False 76 | 77 | -- Should this go in Popup.hs? NOTE 78 | hasPopup :: GopherBrowserState -> Bool 79 | hasPopup gbs = isJust $ gbsPopup gbs 80 | 81 | -- NOTE same as above: should be in Popup.hs probably! 82 | closePopup :: GopherBrowserState -> GopherBrowserState 83 | closePopup gbs = gbs { gbsPopup = Nothing } 84 | -------------------------------------------------------------------------------- /src/BrickApp/Types/Names.hs: -------------------------------------------------------------------------------- 1 | module BrickApp.Types.Names where 2 | 3 | -- FIXME: this is not specific! Should be OpenConfigFieldNames! 4 | data FieldName = FileField 5 | | DirectoryField 6 | | CsoPhoneBookServerField 7 | | ErrorField 8 | | BinHexedMacintoshFileField 9 | | DosBinaryArchiveField 10 | | UnixUuencodedFileField 11 | | IndexSearchServerField 12 | | TextBasedTelnetSessionField 13 | | BinaryFileField 14 | | RedundantServerField 15 | | GifFileField 16 | | ImageFileField 17 | | Tn3270SessionField 18 | | DocField 19 | | HtmlFileField 20 | | InformationalMessageField 21 | | SoundFileField 22 | deriving (Bounded, Enum, Show, Ord, Eq) 23 | 24 | data AnyName = FieldName FieldName | MyName MyName 25 | deriving (Show, Eq, Ord) 26 | 27 | data MyName = MyViewport | MainViewport | EditorViewport | MyWidget | TextViewport | MenuViewport 28 | deriving (Show, Eq, Ord) 29 | 30 | -- FIXME: This name is very bad! 31 | data EditName = Edit1 deriving (Ord, Show, Eq) 32 | 33 | -------------------------------------------------------------------------------- /src/BrickApp/Utils.hs: -------------------------------------------------------------------------------- 1 | -- FIXME: put status stuff in Utils/StatusEditor.hs? 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | -- | Honestly, this is sloppily just a catchall for things many UI modules use. Should be sorted 5 | -- soon/later. 6 | module BrickApp.Utils 7 | ( makePopupWidget 8 | , defaultBrowserUI 9 | , defaultOptimizedUI 10 | , menuToMenuBuffer 11 | , cacheRemove 12 | , cacheLookup 13 | , isCached 14 | , newStateForMenu 15 | , myNameScroll 16 | , mainViewportScroll 17 | , cacheInsert 18 | , menuViewportScroll 19 | , textViewportScroll 20 | , locationAsString 21 | , selectorToRenderMode 22 | , statusEditorFormerMode 23 | , renderModeToItemChar 24 | , getSearchEditorContents 25 | ) where 26 | 27 | import Data.List (intersperse) 28 | import qualified Data.Text as T 29 | import Data.Maybe 30 | import qualified Data.Vector as Vector 31 | import qualified Data.Map as Map 32 | 33 | import Lens.Micro 34 | import Brick.Widgets.Border 35 | import qualified Brick.Widgets.Dialog as D 36 | import qualified Brick.Widgets.Edit as B 37 | import qualified Brick.BChan as B 38 | import qualified Brick.Main as B 39 | import qualified Brick.Types as B 40 | import Brick.Widgets.Center as B 41 | import Brick.Widgets.Core as B 42 | import Brick.Widgets.Border as B 43 | import Brick.AttrMap as B 44 | import qualified Brick.Widgets.List as BrickList -- (List)? FIXME 45 | 46 | import Gopher 47 | import BrickApp.Types ( GopherBrowserState(..) 48 | , Cache 49 | , History 50 | , Location 51 | , RenderMode(..) 52 | , CustomEvent 53 | , Menu(..) 54 | , Buffer(..) 55 | , StatusEditor(..) 56 | , Popup(..) 57 | ) 58 | import BrickApp.Types.Names ( AnyName(..), MyName(..) ) 59 | import BrickApp.Types.Helpers ( isStatusEditing, hasPopup ) 60 | --import BrickApp.Utils.Popup 61 | import BrickApp.Utils.Style 62 | 63 | {- TODO: 64 | -- | A modification of the default Brick.Widgets.Edit event handler; changed to 65 | -- return a GopherBrowserState instead of just an editor state. 66 | statusEditorEventHandler 67 | :: GopherBrowserState -> V.Event -> T.EventM AnyName GopherBrowserState 68 | -- TODO: e' is unused! 69 | statusEditorEventHandler _ e' = 70 | -- Maybe this should be a general function in Representation. 71 | let updateEditorInStatus x = gbs { gbsStatus = Just $ (fromJust $ gbsStatus gbs) { seEditorState = x } } 72 | in updateEditorInStatus 73 | <$> B.handleEditorEvent e' (seEditorState $ fromJust $ gbsStatus gbs) 74 | -} 75 | 76 | statusEditorFormerMode :: GopherBrowserState -> GopherBrowserState 77 | statusEditorFormerMode g = g { gbsRenderMode = seFormerMode $ fromJust $ gbsStatus g, gbsStatus = Nothing } 78 | 79 | getSearchEditorContents :: GopherBrowserState -> T.Text 80 | getSearchEditorContents gbs = T.filter (/= '\n') $ T.unlines (B.getEditContents $ seEditorState $ fromJust $ gbsStatus gbs) 81 | 82 | -- | Overrides the default Dialog renderer. I overrided it beacuse I want my custom popup 83 | -- styles and a 100% width for popups. 84 | renderDialog :: D.Dialog a -> B.Widget n -> B.Widget n 85 | renderDialog d body = 86 | let buttonPadding = str " " 87 | mkButton (i, (s, _)) = let att = if Just i == d^.D.dialogSelectedIndexL 88 | then buttonSelectedAttr 89 | else D.buttonAttr 90 | in withAttr att $ str $ " " <> s <> " " 91 | buttons = hBox $ intersperse buttonPadding $ 92 | mkButton <$> (zip [0..] (d^.D.dialogButtonsL)) 93 | 94 | doBorder = maybe border (borderWithLabel . withAttr inputDialogLabelAttr . padLeftRight 1) (str <$> d^.D.dialogTitleL) 95 | in centerLayer $ 96 | --withDefAttr D.dialogAttr $ -- This should be popup attr 97 | updateAttrMap (applyAttrMappings borderMappingsInputDialog) $ 98 | withBorderStyle inputDialogBorder $ 99 | doBorder $ 100 | vBox [ body 101 | , padBottom (B.Pad 1) $ hCenter buttons 102 | ] 103 | 104 | -- FIXME: belongs in popup.hs 105 | makePopupWidget :: GopherBrowserState -> B.Widget AnyName 106 | makePopupWidget gbs = 107 | let popupDialog = fromJust $ gbsPopup gbs 108 | in renderDialog (pDialogWidget popupDialog) $ hCenter $ padAll 1 $ (pDialogBody popupDialog) 109 | 110 | -- | Pick out the appropriate `RenderMode` for the supplied `Selector`. 111 | selectorToRenderMode :: Selector -> RenderMode 112 | selectorToRenderMode selector = 113 | case selectorItemType selector of 114 | Just someItemType -> 115 | case someItemType of 116 | Canonical Directory -> MenuMode 117 | Canonical File -> TextFileMode 118 | _ -> FileBrowserMode 119 | Nothing -> FileBrowserMode 120 | 121 | -- FIXME: okay so this is nice and all but how will we handle editor input once activated? how do we tell it's activated? 122 | -- FIXME: poppys and statusWidget both relevant! 123 | -- I need a better name for this, but basically it's the default view you see 124 | -- for everything! There are only a few exceptions. 125 | --defaultBrowserUI :: GopherBrowserState -> B.Viewport -> B.Widget MyName -> B.Widget MyName -> B.Widget MyName -> [B.Widget MyName] 126 | -- FIXME: can make this all name-agnostic if you fix status issue? 127 | defaultBrowserUI :: 128 | GopherBrowserState 129 | -> (B.Widget AnyName -> B.Widget AnyName) 130 | -> B.Widget AnyName 131 | -> B.Widget AnyName 132 | -> B.Widget AnyName 133 | -> [B.Widget AnyName] 134 | defaultBrowserUI gbs mainViewport titleWidget mainWidget statusWidget = defaultOptimizedUI gbs titleWidget mainWidget' statusWidget 135 | where 136 | mainWidget' = mainViewport $ hLimitPercent 100 mainWidget 137 | 138 | -- TODO: replace `defaultBrowserUI` with this! 139 | -- mainWidget should be like: (mainViewport $ hLimitPercent 100 mainWidget) 140 | defaultOptimizedUI :: 141 | GopherBrowserState 142 | -> B.Widget AnyName 143 | -> B.Widget AnyName 144 | -> B.Widget AnyName 145 | -> [B.Widget AnyName] 146 | defaultOptimizedUI gbs titleWidget mainWidget statusWidget = [makePopupWidget gbs | hasPopup gbs] ++ [hCenter $ vCenter view] 147 | where 148 | box :: B.Widget AnyName 149 | box = 150 | updateAttrMap (B.applyAttrMappings borderMappings) 151 | $ withBorderStyle customBorder 152 | $ B.borderWithLabel (withAttr titleAttr titleWidget) 153 | $ mainWidget 154 | 155 | -- Maybe statusWidget should be Maybe so can override? 156 | -- FIXME: this is source of enforcing MyName because seEditorState is always MyName type... what if constructed it here instead based 157 | -- on type of name given 158 | status :: B.Widget AnyName 159 | status = 160 | if isStatusEditing gbs then 161 | let editWidget = withAttr inputFieldAttr $ B.renderEditor (txt . T.unlines) True (seEditorState $ fromJust $ gbsStatus gbs) 162 | editLabelWidget = txt (seLabel $ fromJust $ gbsStatus gbs) 163 | in editLabelWidget <+> editWidget 164 | else 165 | statusWidget 166 | 167 | -- FIXME: could I just use <+> or something here? Try to combinge name N with named other type? impossible? 168 | view :: B.Widget AnyName 169 | view = vBox 170 | [ box 171 | -- This needs to be better... it needs to detect the status mode and then construct the widget for either...? 172 | , vLimit 1 status 173 | -- TODO: status should work like popup. including edit Maybe and put this in represent 174 | -- Maybe have an Either status widget where it's either display status or edit field 175 | ] 176 | 177 | 178 | -- | Basically a URI without the gopher:// scheme. 179 | type CacheKey = T.Text 180 | 181 | -- | Creates a `CacheKey` from a `Location`. 182 | locationToCacheKey :: Location -> CacheKey 183 | locationToCacheKey (host, port, resource, _, _) = 184 | host <> ":" <> (T.pack $ show port) <> resource 185 | 186 | -- | Get the path to the temporary file/cache which corresponds to the `Location`. 187 | cacheLookup :: Location -> Cache -> Maybe FilePath 188 | cacheLookup location = Map.lookup (locationToCacheKey location) 189 | 190 | -- | Remove a cache entry for a given `Location`. 191 | cacheRemove :: Location -> Cache -> Cache 192 | cacheRemove location = Map.delete (locationToCacheKey location) 193 | 194 | -- | Check if a `Location` already exists in the cache. 195 | -- In other words, checks if something is already cached or not. 196 | isCached :: Location -> Cache -> Bool 197 | isCached location cache = case Map.lookup (locationToCacheKey location) cache of 198 | (Just _) -> True 199 | Nothing -> False 200 | 201 | -- | Update the cache so the `FilePath` to the cache temporary file 202 | -- supplied, corresponds to a `Location`. 203 | cacheInsert :: Location -> FilePath -> Cache -> Cache 204 | cacheInsert location = Map.insert (locationToCacheKey location) 205 | 206 | -- FIXME: may as well make location a record? 207 | -- TODO: just make an instance for location? 208 | -- TODO: document and give a repl example 209 | locationAsString :: Location -> T.Text 210 | locationAsString (host, port, resource, mode, displayString) = 211 | case displayString of 212 | Just d -> d 213 | Nothing -> host <> ":" <> (T.pack $ show port) <> resource <> " (" <> (T.pack $ show mode) <> ")" 214 | 215 | -- | From a generic `GopherMenu` to a TUI-specific `Buffer` type. 216 | menuToMenuBuffer :: GopherMenu -> Buffer 217 | menuToMenuBuffer gopherMenu@(GopherMenu ls) = 218 | MenuBuffer $ Menu (gopherMenu, BrickList.list (MyName MyWidget) glsVector 1, mkFocusLinesIndex gopherMenu) 219 | where 220 | glsVector = Vector.fromList $ map lineShow ls 221 | 222 | mkFocusLinesIndex (GopherMenu m) = 223 | map fst $ filter (not . isInfoMsg . snd) (zip [0 ..] m) 224 | 225 | -- | Used for filling up a list with display strings. 226 | lineShow :: MenuLine -> T.Text 227 | lineShow line = case line of 228 | -- It's a GopherLine 229 | (Parsed gl) -> case glType gl of 230 | -- Canonical type 231 | (Canonical _) -> glDisplayString gl 232 | -- Noncanonical type 233 | (NonCanonical nct) -> 234 | if nct == InformationalMessage && glDisplayString gl == "" 235 | then " " 236 | else glDisplayString gl 237 | -- It's a MalformedGopherLine 238 | (Unparseable _) -> menuLineAsText line 239 | 240 | -- FIXME: more like makeState from menu lol. maybe can make do for any state 241 | -- FIXME: update for cache 242 | -- based on passing it the mode and other info! newStateForMenu? 243 | -- 244 | -- probs needs to be IO 245 | -- 246 | -- | Make a new GopherBrowserState for a GopherMenu based on a few 247 | -- necessary parts that must be carried over, like History and 248 | -- Cache. 249 | newStateForMenu 250 | :: B.BChan CustomEvent 251 | -> GopherMenu 252 | -> Location 253 | -> History 254 | -> Cache 255 | -> GopherBrowserState 256 | newStateForMenu chan gm location history cache = GopherBrowserState 257 | { gbsBuffer = menuToMenuBuffer gm 258 | , gbsLocation = location 259 | , gbsHistory = history 260 | , gbsRenderMode = MenuMode 261 | , gbsChan = chan 262 | , gbsPopup = Nothing 263 | , gbsCache = cache-- FIXME: should I be updating this? 264 | , gbsStatus = Nothing 265 | } 266 | 267 | myNameScroll :: B.ViewportScroll AnyName 268 | myNameScroll = B.viewportScroll $ MyName MyViewport 269 | 270 | mainViewportScroll :: B.ViewportScroll AnyName 271 | mainViewportScroll = B.viewportScroll $ MyName MainViewport 272 | 273 | menuViewportScroll :: B.ViewportScroll AnyName 274 | menuViewportScroll = B.viewportScroll $ MyName MenuViewport 275 | 276 | textViewportScroll :: B.ViewportScroll AnyName 277 | textViewportScroll = B.viewportScroll $ MyName TextViewport 278 | 279 | renderModeToItemChar :: RenderMode -> Char 280 | renderModeToItemChar renderMode = 281 | case renderMode of 282 | TextFileMode -> '0' 283 | MenuMode -> '1' 284 | MenuJumpMode -> '1' 285 | FileBrowserMode -> '9' 286 | SearchMode -> '1' 287 | -- FIXME: this shouldn't be an error! 288 | _ -> error $ "Can't bookmark mode " ++ show renderMode 289 | -------------------------------------------------------------------------------- /src/BrickApp/Utils/Popup.hs: -------------------------------------------------------------------------------- 1 | -- FIXME: maybe a lot of this could go into modeaction? 2 | -- FIXME TODO: rename to DialogPopup? 3 | -- | A single-line input dialog box. Being phased out with a Dialog version 4 | -- from `brick`. 5 | module BrickApp.Utils.Popup 6 | ( popOver 7 | , popup 8 | , inputPopupUI 9 | , popupDialogEventHandler 10 | ) where 11 | 12 | import Control.Monad.IO.Class 13 | import qualified Data.Map as Map 14 | import qualified Data.Text as T 15 | 16 | import qualified Brick.Main as B 17 | import qualified Brick.Types as B 18 | import qualified Graphics.Vty as V 19 | import qualified Brick.Widgets.Dialog as B 20 | import qualified Brick.Widgets.Edit as E 21 | import qualified Brick.Types as T 22 | import Brick.Widgets.Center ( center 23 | , hCenter 24 | , vCenter 25 | ) 26 | import Brick.Widgets.Border ( borderWithLabel ) 27 | import Brick.AttrMap ( applyAttrMappings ) 28 | import Brick.Widgets.Core ( vBox 29 | , txt 30 | , hLimit 31 | , vLimit 32 | , withBorderStyle 33 | , padLeftRight 34 | , padTop 35 | , padTopBottom 36 | , withAttr 37 | , updateAttrMap 38 | ) 39 | 40 | import BrickApp.Utils.Style 41 | import BrickApp.Types.Names 42 | import BrickApp.Types 43 | import BrickApp.Types.Helpers 44 | 45 | -- | A vertically-centered, full-width popup box to be displayed over other widgets by putting it before 46 | -- the other widgets in the list of widgets being rendered. 47 | popup :: T.Text -> [T.Widget AnyName] -> T.Text -> [T.Widget AnyName] 48 | popup label widgets helpString = 49 | let 50 | ui = 51 | updateAttrMap (applyAttrMappings borderMappingsInputDialog) 52 | $ withBorderStyle inputDialogBorder 53 | $ borderWithLabel 54 | (withAttr inputDialogLabelAttr $ padLeftRight 1 $ txt label) 55 | $ hCenter 56 | $ padLeftRight 4 57 | $ padTopBottom 1 58 | $ padLeftRight 4 59 | $ hLimit 100 60 | $ vLimit 3 61 | $ vBox 62 | [ vBox widgets 63 | , padTop (T.Pad 1) $ txt helpString 64 | ] 65 | in [ui] 66 | 67 | -- | A full-screen popup which displays nothing underneath it. Centered vertically and horizontally. 68 | popOver :: T.Text -> [T.Widget AnyName] -> T.Text -> [T.Widget AnyName] 69 | popOver label mainWidget helpString = 70 | let 71 | ui = 72 | vCenter 73 | $ hCenter 74 | $ padLeftRight 4 75 | (head $ popup label mainWidget helpString) 76 | in [center ui] 77 | 78 | -- TODO: just make search a popup dialog? 79 | inputPopupUI :: E.Editor T.Text AnyName -> T.Text -> T.Text -> [T.Widget AnyName] 80 | inputPopupUI editorState label helpString = popOver label [editorWidget] helpString 81 | where 82 | editorWidget = withAttr inputFieldAttr $ E.renderEditor (txt . T.unlines) True editorState 83 | 84 | -- | The Brick event handler used when a popup dialog is present. 85 | popupDialogEventHandler 86 | :: GopherBrowserState 87 | -> Popup 88 | -> B.BrickEvent AnyName CustomEvent 89 | -> T.EventM AnyName (T.Next GopherBrowserState) 90 | popupDialogEventHandler gbs n e = 91 | case e of 92 | B.VtyEvent (V.EvKey V.KEsc []) -> B.continue $ closePopup gbs 93 | B.VtyEvent (V.EvKey V.KEnter []) -> B.continue =<< liftIO (doChoice (B.dialogSelection (pDialogWidget n)) gbs) 94 | B.VtyEvent vtyev@(_) -> B.continue =<< (updatePopupWidget gbs <$> B.handleDialogEvent vtyev (pDialogWidget n)) 95 | _ -> B.continue gbs 96 | where 97 | updatePopupWidget gbs' dialog = gbs' { gbsPopup = Just (n { pDialogWidget = dialog } ) } 98 | doChoice Nothing gbs' = pure gbs' 99 | doChoice (Just choice) gbs' = 100 | let (Just popup') = gbsPopup gbs 101 | (Just choiceFunc) = Map.lookup (show choice) (pDialogMap popup') 102 | in choiceFunc gbs' 103 | -------------------------------------------------------------------------------- /src/BrickApp/Utils/Style.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module BrickApp.Utils.Style 3 | ( customBorder 4 | , custom2Attr 5 | , theMap 6 | , inputFieldAttr 7 | , inputDialogBorder 8 | , inputDialogBorderAttr 9 | , borderMappingsInputDialog 10 | , getTheme 11 | , borderMappings 12 | , errorAttr 13 | , inputDialogAttr 14 | , inputDialogLabelAttr 15 | , titleAttr 16 | , customAttr 17 | , asteriskAttr 18 | , numberPrefixAttr 19 | , fileAttr 20 | , indexSearchServerAttr 21 | , linkAttr 22 | , textAttr 23 | , directoryAttr 24 | , genericTypeAttr 25 | , buttonSelectedAttr 26 | ) where 27 | 28 | import Brick.Themes ( Theme 29 | , newTheme 30 | , themeToAttrMap 31 | , loadCustomizations 32 | ) 33 | import qualified Brick.Widgets.List as L 34 | import qualified Graphics.Vty as V 35 | import qualified Brick.Widgets.FileBrowser as FB 36 | import qualified Brick.Widgets.Edit as E 37 | import qualified Brick.AttrMap as A 38 | import qualified Brick.Widgets.Border.Style as BS 39 | import qualified Brick.Widgets.Border as B 40 | import Brick.Util ( fg 41 | , on 42 | ) 43 | 44 | import Config.Theme ( getUserThemePath ) 45 | 46 | -- | In order to use ini-defined themes we need to have a default `Theme`, 47 | -- as that's the way `Brick` works. 48 | defaultTheme :: Theme 49 | defaultTheme = newTheme (V.white `on` V.blue) listMapThingy 50 | 51 | -- | Load the main theme.. 52 | getTheme :: IO A.AttrMap 53 | getTheme = do 54 | userThemePath <- getUserThemePath 55 | perhapsTheme <- loadCustomizations userThemePath defaultTheme 56 | case perhapsTheme of 57 | Left errorMessage -> error errorMessage 58 | Right theme -> pure $ themeToAttrMap theme 59 | 60 | menuLineAttr :: A.AttrName 61 | menuLineAttr = menuAttr <> "line" 62 | 63 | -- TODO: this all feels very messy 64 | customAttr :: A.AttrName 65 | customAttr = menuLineAttr <> "selected" 66 | 67 | custom2Attr :: A.AttrName 68 | custom2Attr = textAttr <> "selected" 69 | 70 | -- | This style attribute is used for the menus in gopherspace. 71 | -- The menus are just a specific kind of list. 72 | menuAttr :: A.AttrName 73 | menuAttr = "menu" 74 | 75 | -- | This is the bit that describes the line's item type 76 | itemDescAttr :: A.AttrName 77 | itemDescAttr = menuLineAttr <> "itemDesc" 78 | 79 | -- | This is used for the item type indicator in menus... 80 | directoryAttr :: A.AttrName 81 | directoryAttr = itemDescAttr <> "directory" 82 | 83 | fileAttr :: A.AttrName 84 | fileAttr = itemDescAttr <> "file" 85 | 86 | indexSearchServerAttr :: A.AttrName 87 | indexSearchServerAttr = itemDescAttr <> "indexSearchServer" 88 | 89 | -- | A catchall, in other words "other." 90 | genericTypeAttr :: A.AttrName 91 | genericTypeAttr = itemDescAttr <> "generic" 92 | 93 | numberPrefixAttr :: A.AttrName 94 | numberPrefixAttr = menuAttr <> "numberPrefix" 95 | 96 | linkAttr :: A.AttrName 97 | linkAttr = menuLineAttr <> "linkString" 98 | 99 | textAttr :: A.AttrName 100 | textAttr = menuLineAttr <> "info" 101 | 102 | -- TODO: bad name now... 103 | asteriskAttr :: A.AttrName 104 | asteriskAttr = menuAttr <> "asterisk" 105 | 106 | titleAttr :: A.AttrName 107 | titleAttr = "titleAttr" 108 | 109 | errorAttr :: A.AttrName 110 | errorAttr = "error" 111 | 112 | inputFieldAttr :: A.AttrName 113 | inputFieldAttr = "inputField" 114 | 115 | popupAttr :: A.AttrName 116 | popupAttr = "popup" 117 | 118 | inputDialogLabelAttr :: A.AttrName 119 | inputDialogLabelAttr = popupAttr <> "label" 120 | 121 | -- I don't think this is being used FIXME 122 | inputDialogAttr :: A.AttrName 123 | inputDialogAttr = "inputDialogAttr" 124 | 125 | buttonAttr :: A.AttrName 126 | buttonAttr = "button" 127 | 128 | buttonSelectedAttr :: A.AttrName 129 | buttonSelectedAttr = buttonAttr <> "selected" 130 | 131 | listMapThingy :: [(A.AttrName, V.Attr)] 132 | listMapThingy = 133 | [ (L.listAttr, V.yellow `on` V.rgbColor (0 :: Int) (0 :: Int) (0 :: Int)) 134 | -- The forecolor below effectively does *nothing* 135 | , ( L.listSelectedAttr 136 | , (V.defAttr `V.withStyle` V.bold) `V.withForeColor` V.white 137 | ) 138 | , ( inputDialogAttr-- FIXME: unused? 139 | , V.rgbColor (255 :: Int) (255 :: Int) (0 :: Int) 140 | `on` V.rgbColor (0 :: Int) (0 :: Int) (0 :: Int) 141 | ) 142 | , (directoryAttr , fg V.red) 143 | , (fileAttr , fg V.cyan) 144 | , (indexSearchServerAttr, fg V.magenta) 145 | , (linkAttr, fg (V.rgbColor (28 :: Int) (152 :: Int) (255 :: Int))) 146 | , (textAttr, fg (V.rgbColor (255 :: Int) (255 :: Int) (0 :: Int))) 147 | , (genericTypeAttr , fg V.green) 148 | , (numberPrefixAttr, fg (V.rgbColor (252 :: Int) (40 :: Int) (254 :: Int))) 149 | , (customAttr, (V.defAttr `V.withStyle` V.bold) `V.withForeColor` V.white) 150 | , (custom2Attr , fg V.yellow) 151 | , ( titleAttr 152 | , (V.defAttr `V.withStyle` V.reverseVideo) 153 | `V.withStyle` V.bold 154 | `V.withForeColor` V.white 155 | ) 156 | , ( inputDialogLabelAttr 157 | , (V.defAttr `V.withStyle` V.reverseVideo) 158 | `V.withStyle` V.bold 159 | `V.withForeColor` V.yellow 160 | ) 161 | , (asteriskAttr , fg V.white) 162 | , (buttonAttr , (V.black `on` V.yellow)) 163 | , (buttonSelectedAttr , (V.defAttr `V.withStyle` V.bold) `V.withForeColor` V.rgbColor (0 :: Int) (0 :: Int) (0 :: Int) `V.withBackColor` V.rgbColor (255 :: Int) (255 :: Int) (0 :: Int)) 164 | , (E.editAttr , V.white `on` V.brightBlack) 165 | , (E.editFocusedAttr , V.white `on` V.brightBlack) 166 | , (FB.fileBrowserCurrentDirectoryAttr, V.white `on` V.blue) 167 | , (FB.fileBrowserSelectionInfoAttr , V.white `on` V.blue) 168 | , (FB.fileBrowserDirectoryAttr , fg V.blue) 169 | , (FB.fileBrowserBlockDeviceAttr , fg V.magenta) 170 | , (FB.fileBrowserCharacterDeviceAttr , fg V.green) 171 | , (FB.fileBrowserNamedPipeAttr , fg V.yellow) 172 | , (FB.fileBrowserSymbolicLinkAttr , fg V.cyan) 173 | , (FB.fileBrowserUnixSocketAttr , fg V.red) 174 | , (FB.fileBrowserSelectedAttr , V.white `on` V.magenta) 175 | , (errorAttr , fg V.red) 176 | ] 177 | 178 | theMap :: A.AttrMap 179 | theMap = A.attrMap 180 | V.defAttr listMapThingy 181 | 182 | -- FIXME: better name and make configurable through INI 183 | customBorder :: BS.BorderStyle 184 | customBorder = BS.BorderStyle { BS.bsCornerTL = '▚' 185 | , BS.bsCornerTR = '▚' 186 | , BS.bsCornerBR = '▚' 187 | , BS.bsCornerBL = '▚' 188 | , BS.bsIntersectFull = ' ' 189 | , BS.bsIntersectL = ' ' 190 | , BS.bsIntersectR = ' ' 191 | , BS.bsIntersectT = ' ' 192 | , BS.bsIntersectB = ' ' 193 | , BS.bsHorizontal = '▚' 194 | , BS.bsVertical = ' ' 195 | } 196 | 197 | -- FIXME: make configurable through INI 198 | -- Round oval 199 | inputDialogBorder :: BS.BorderStyle 200 | inputDialogBorder = BS.BorderStyle { BS.bsCornerTL = '░' 201 | , BS.bsCornerTR = '░' 202 | , BS.bsCornerBR = '░' 203 | , BS.bsCornerBL = '░' 204 | , BS.bsIntersectFull = ' ' 205 | , BS.bsIntersectL = ' ' 206 | , BS.bsIntersectR = ' ' 207 | , BS.bsIntersectT = ' ' 208 | , BS.bsIntersectB = ' ' 209 | , BS.bsHorizontal = '▓' 210 | , BS.bsVertical = '▒' 211 | } 212 | 213 | inputDialogBorderAttr :: A.AttrName 214 | inputDialogBorderAttr = "inputDialogBorderAttr" 215 | 216 | borderMappingsInputDialog :: [(A.AttrName, V.Attr)] 217 | borderMappingsInputDialog = 218 | -- [ (inputDialogBorderAttr, V.red `on` V.rgbColor (55 :: Int) (175 :: Int) (200 :: Int)) ] 219 | [ ( B.borderAttr 220 | , V.yellow `on` V.rgbColor (55 :: Int) (175 :: Int) (200 :: Int) 221 | ) 222 | ] 223 | 224 | borderMappings :: [(A.AttrName, V.Attr)] 225 | borderMappings = 226 | [(B.borderAttr, V.cyan `on` V.rgbColor (0 :: Int) (0 :: Int) (0 :: Int))] 227 | -------------------------------------------------------------------------------- /src/BrickApp/Utils/WaffleAddresses.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- Support waffle:// addresses which simply point to various config and 4 | -- information screens. 5 | module BrickApp.Utils.WaffleAddresses where 6 | 7 | import Data.Text as T 8 | import qualified Data.Map as Map 9 | 10 | import Brick.Widgets.Core ( txt ) 11 | import Network.URI 12 | 13 | import qualified Brick.Widgets.Dialog as D 14 | import BrickApp.ModeAction.Help 15 | import BrickApp.ModeAction.Open 16 | import BrickApp.ModeAction.Bookmarks 17 | import BrickApp.Types 18 | import BrickApp.Utils 19 | import BrickApp.ModeAction.Progress 20 | import BrickApp.Types.Helpers 21 | import Gopher 22 | 23 | 24 | -- Geets the proper mode initializer (this should be a hierarchical thign in my code) for the address 25 | -- FIXME: pass gbs, e 26 | -- NOTE: all of these will check doEventIfModes for making sure it can't open itself while its active. 27 | -- The waffle address after the waffle:// scheme mapped to a certain init mode...? 28 | waffleAddresses 29 | :: Map.Map T.Text (GopherBrowserState -> IO GopherBrowserState) 30 | waffleAddresses = 31 | Map.fromList 32 | [ ("bookmarks", \gbs -> initBookmarksMode gbs) 33 | , ("help", \gbs -> modifyGbsForHelp gbs) 34 | , ("assocs", \gbs -> initConfigOpenMode gbs) 35 | --, ("homeconf", setHomeConfig) 36 | ] 37 | 38 | -- | Drops waffle:// from supplied address, but give back Nothing 39 | -- if (a) the result of doing so results in a blank `Text` or 40 | -- (b) the `Text` does not start with `waffle://`. 41 | dropWaffleScheme :: T.Text -> Maybe T.Text 42 | dropWaffleScheme address = 43 | if "waffle://" `T.isPrefixOf` address 44 | then case T.drop (T.length "waffle://") address of 45 | "" -> Nothing 46 | withoutWaffleScheme -> Just withoutWaffleScheme 47 | else Nothing 48 | 49 | -- | Will produce an appropriate event for the Waffle address supplied, or Nothing 50 | -- if it is not an actual waffle address. 51 | waffleAddressEvent 52 | :: GopherBrowserState 53 | -> T.Text 54 | -> Maybe (IO GopherBrowserState) 55 | waffleAddressEvent gbs address = 56 | let withoutWaffleScheme = dropWaffleScheme address 57 | in case withoutWaffleScheme of 58 | Nothing -> Nothing 59 | Just without -> case Map.lookup without waffleAddresses of 60 | Just eventFunction -> Just $ eventFunction gbs 61 | Nothing -> Nothing 62 | 63 | -- | Either load the appropriate waffle:// mode from address, or load an actual 64 | -- URI/destination in gopherspace as specified by supplied address. 65 | loadAddress :: GopherBrowserState -> T.Text -> Maybe String -> IO GopherBrowserState 66 | loadAddress gbs unparsedURI maybeDisplayString = 67 | case waffleAddressEvent gbs unparsedURI of 68 | -- It was a valid waffle:// address 69 | Just event -> event 70 | -- It was not a valid waffle:// address and is (hopefully) some valid gopher:// address 71 | Nothing -> either (errorPopup gbs unparsedURI) (initProgressMode gbs Nothing) (tryLocationOrFail unparsedURI) 72 | where 73 | errorPopup :: GopherBrowserState -> T.Text -> T.Text -> IO GopherBrowserState 74 | errorPopup gbs' someBadURI message = 75 | let pop = Popup 76 | { pDialogWidget = D.dialog (Just "Goto input error!") (Just (0, [ ("Ok", Ok) ])) 50--wtf what about max width for bug 77 | , pDialogMap = Map.fromList [("Ok", pure . closePopup)] 78 | , pDialogBody = txt $ (message <> "Invalid: " <> someBadURI) 79 | } 80 | 81 | in pure $ gbs' { gbsPopup = Just pop } 82 | 83 | -- | Try to parse a `Location` from `Text` (which is hopefully 84 | -- some kind of valid URI), or give back an error message. 85 | tryLocationOrFail :: T.Text -> Either T.Text (T.Text, Int, T.Text, RenderMode, Maybe T.Text) 86 | tryLocationOrFail potentialURI = do 87 | parsedURI <- case (parseURI . T.unpack $ prefixSchemeIfMissing potentialURI) of 88 | Just uri -> Right uri 89 | Nothing -> Left "Cannot even begin to parse supplied URI!" 90 | authority' <- case uriAuthority parsedURI of 91 | Just auth -> Right auth 92 | Nothing -> Left $ "Invalid URI (no authority)." 93 | regName <- case uriRegName authority' of 94 | "" -> Left "Invalid URI (no regname/host)." 95 | rn -> Right rn 96 | port <- case uriPort authority' of 97 | "" -> Right 70 98 | ':':p -> Right (read p :: Int) 99 | _ -> Left $ "Invalid URI (bad port)." -- I don' think this ever can occur with Network.URI... 100 | let resource = uriPath parsedURI 101 | Right (T.pack regName, port, removeGopherType $ T.pack resource, selectorToRenderMode $ T.pack resource, fmap T.pack maybeDisplayString) 102 | 103 | prefixSchemeIfMissing :: T.Text -> T.Text 104 | prefixSchemeIfMissing potentialURI 105 | | "gopher://" `T.isPrefixOf` potentialURI = potentialURI 106 | | otherwise = "gopher://" <> potentialURI 107 | 108 | -------------------------------------------------------------------------------- /src/Config.hs: -------------------------------------------------------------------------------- 1 | module Config where 2 | 3 | import System.Directory 4 | import System.FilePath 5 | 6 | import Data.ConfigFile 7 | 8 | -- | Basically `emptyCP`, but doesn't toLower the options. 9 | customEmptyCP :: ConfigParser 10 | customEmptyCP = emptyCP { optionxform = id } 11 | 12 | -- | Get the directory where Waffle's configs should be located. 13 | getConfigDirectory :: IO FilePath 14 | getConfigDirectory = do 15 | homeDirectory <- getHomeDirectory 16 | pure $ joinPath [homeDirectory, ".config", "waffle"] 17 | 18 | doIfPathDoesntExist :: FilePath -> IO () -> IO () 19 | doIfPathDoesntExist filePath someAction = do 20 | pathExists <- doesPathExist filePath 21 | if pathExists 22 | then pure () 23 | else someAction 24 | 25 | -- | Create Waffle's config directory. 26 | setupConfigDirectory :: IO () 27 | setupConfigDirectory = do 28 | configDirectory <- getConfigDirectory 29 | doIfPathDoesntExist configDirectory (createDirectory configDirectory) 30 | 31 | -- | Create the default config for opening menu items (gophermaps) with 32 | -- commands. 33 | --setupOpenConfig :: IO () 34 | --setupOpenConfig = do 35 | 36 | -- | Setup the config directory and all the associated configs. 37 | --setupConfigs :: IO () 38 | --setupConfigs = do 39 | -- let (kk 40 | 41 | readConfigParser :: FilePath -> IO ConfigParser 42 | readConfigParser filePath = do 43 | val <- readfile customEmptyCP filePath 44 | case val of 45 | Left readError -> error (show readError) 46 | Right cp -> pure cp 47 | 48 | readConfigParserValue :: ConfigParser -> SectionSpec -> OptionSpec -> IO String 49 | readConfigParserValue configParser section option = 50 | let val = get configParser section option 51 | in case val of 52 | Left readError -> error (show readError) 53 | Right cp -> pure cp 54 | -------------------------------------------------------------------------------- /src/Config/Bookmarks.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | -- | Config stuff for open associations... 4 | 5 | module Config.Bookmarks where 6 | 7 | import Control.Monad.Except 8 | import System.FilePath 9 | import qualified Data.ByteString.Lazy as BL 10 | 11 | import Data.FileEmbed 12 | import Data.ConfigFile 13 | 14 | import Config 15 | ( getConfigDirectory 16 | , readConfigParser 17 | , doIfPathDoesntExist 18 | , customEmptyCP 19 | ) 20 | 21 | defaultBookmarks :: BL.ByteString 22 | defaultBookmarks = BL.fromStrict $(embedFile "data/bookmarks.ini") 23 | 24 | -- TODO: maybe should be setupFactoryBookmarks 25 | setupDefaultBookmarks :: IO () 26 | setupDefaultBookmarks = do 27 | userBookmarksPath <- getUserBookmarksPath 28 | doIfPathDoesntExist userBookmarksPath (BL.writeFile userBookmarksPath defaultBookmarks) 29 | 30 | -- | Get the `FilePath` to the user's open/associations configuration file. 31 | getUserBookmarksPath :: IO FilePath 32 | getUserBookmarksPath = do 33 | configDir <- getConfigDirectory 34 | pure $ joinPath [configDir, "bookmarks.ini"] 35 | 36 | -- | The default open.ini list of associations between item types and 37 | -- commands to open them. 38 | getUserBookmarks :: IO ConfigParser 39 | getUserBookmarks = getUserBookmarksPath >>= readConfigParser 40 | 41 | -- FIX: Should be (SectionSpec, HostName, PortNumber, Resource, ItemChar... 42 | type BookmarkEntry = (SectionSpec, String, Int, String, Char) 43 | 44 | addBookmark :: BookmarkEntry -> IO () 45 | addBookmark (sectionSpec, host, port, resource, itemType) = do 46 | userBookmarksPath <- getUserBookmarksPath 47 | -- Trust me, I know how this looks, but that's how the `Data.ConfigFile` author 48 | -- wants it done. It's an interface I don't appreciate much. 49 | outCP <- runExceptT $ 50 | do 51 | cp <- join $ liftIO $ readfile customEmptyCP userBookmarksPath 52 | cp' <- add_section cp sectionSpec 53 | cp'' <- set cp' sectionSpec "host" (host) 54 | cp''' <- set cp'' sectionSpec "port" (show port) 55 | cp'''' <- set cp''' sectionSpec "resource" resource 56 | cp''''' <- set cp'''' sectionSpec "type" (itemType:[]) 57 | pure cp''''' 58 | 59 | -- Handle errors from the building the output configuration parser 60 | case outCP of 61 | Left (exception, _) -> 62 | -- FIXME: needs to catch the other exceptions... 63 | case exception of 64 | -- Rewrite in case of the section already existing! 65 | SectionAlreadyExists _' -> pure () 66 | ParseError errorMessage -> error $ "Parse error: " ++ errorMessage 67 | NoSection errorMessage -> error $ "No such section: " ++ errorMessage 68 | NoOption errorMessage -> error $ "No such option: " ++ errorMessage -- FIXME: this should never happen. 69 | InterpolationError errorMessage -> error $ "No such option: " ++ errorMessage -- FIXME: this should never happen. 70 | OtherProblem errorMessage -> error $ "Error: " ++ errorMessage 71 | Right cp -> do 72 | outPath <- getUserBookmarksPath 73 | writeFile outPath (to_string cp) 74 | 75 | -- | Remove a bookmark from the user's bookmark configuration. 76 | removeBookmark :: SectionSpec -> IO () 77 | removeBookmark sectionSpec = do 78 | userBookmarks <- getUserBookmarks 79 | outPath <- getUserBookmarksPath 80 | let outCp = case remove_section userBookmarks sectionSpec of 81 | Left operationError -> error (show operationError) 82 | Right cp -> cp 83 | writeFile outPath (to_string outCp) 84 | -------------------------------------------------------------------------------- /src/Config/ConfigOpen.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | -- | Config stuff for open associations... 4 | 5 | module Config.ConfigOpen where 6 | 7 | import System.FilePath 8 | import qualified Data.ByteString.Lazy as BL 9 | 10 | import Data.FileEmbed 11 | import Data.ConfigFile 12 | 13 | import Config ( getConfigDirectory, readConfigParser, doIfPathDoesntExist ) 14 | 15 | defaultOpenConfig :: BL.ByteString 16 | defaultOpenConfig = BL.fromStrict $(embedFile "data/open.ini") 17 | 18 | -- TODO: maybe should be setupFactoryOpenConfig 19 | setupDefaultOpenConfig :: IO () 20 | setupDefaultOpenConfig = do 21 | userOpenConfigPath <- getUserOpenConfigPath 22 | doIfPathDoesntExist userOpenConfigPath (BL.writeFile userOpenConfigPath defaultOpenConfig) 23 | 24 | -- | Get the `FilePath` to the user's open/associations configuration file. 25 | getUserOpenConfigPath :: IO FilePath 26 | getUserOpenConfigPath = do 27 | configDir <- getConfigDirectory 28 | pure $ joinPath [configDir, "open.ini"] 29 | 30 | -- | The default open.ini list of associations between item types and 31 | -- commands to open them. 32 | getUserOpenConfig :: IO ConfigParser 33 | getUserOpenConfig = getUserOpenConfigPath >>= readConfigParser 34 | -------------------------------------------------------------------------------- /src/Config/Homepage.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | -- Module for managing a homepage. 4 | 5 | module Config.Homepage where 6 | 7 | import Data.Maybe (fromMaybe) 8 | import Control.Monad.Except 9 | import System.FilePath 10 | import qualified Data.ByteString.Lazy as BL 11 | 12 | import Data.FileEmbed 13 | import Data.ConfigFile 14 | 15 | import Config ( customEmptyCP, getConfigDirectory, readConfigParser, doIfPathDoesntExist ) 16 | 17 | defaultHomepageConfig :: BL.ByteString 18 | defaultHomepageConfig = BL.fromStrict $(embedFile "data/homepage.ini") 19 | 20 | setupDefaultHomepageConfig :: IO () 21 | setupDefaultHomepageConfig = do 22 | userHomepageConfigPath <- getUserHomepageConfigPath 23 | doIfPathDoesntExist userHomepageConfigPath (BL.writeFile userHomepageConfigPath defaultHomepageConfig) 24 | 25 | -- | Get the `FilePath` to the user's open/associations configuration file. 26 | getUserHomepageConfigPath :: IO FilePath 27 | getUserHomepageConfigPath = do 28 | configDir <- getConfigDirectory 29 | pure $ joinPath [configDir, "homepage.ini"] 30 | 31 | -- | The default open.ini list of associations between item types and 32 | -- commands to open them. 33 | getUserHomepageConfig :: IO ConfigParser 34 | getUserHomepageConfig = getUserHomepageConfigPath >>= readConfigParser 35 | 36 | setHomepage :: String -> Maybe String -> IO () 37 | setHomepage homepageURI maybeDisplayString = do 38 | userHomepagePath <- getUserHomepageConfigPath 39 | -- Trust me, I know how this looks, but that's how the `Data.ConfigFile` author 40 | -- wants it done. It's an interface I don't appreciate much. 41 | outCP <- runExceptT $ 42 | do 43 | cp <- join $ liftIO $ readfile customEmptyCP userHomepagePath 44 | cp' <- set cp "homepage" "uri" (homepageURI) 45 | cp'' <- set cp' "homepage" "display" (fromMaybe homepageURI maybeDisplayString) 46 | pure cp'' 47 | 48 | -- Handle errors from the building the output configuration parser 49 | case outCP of 50 | Left (exception, _) -> 51 | -- FIXME: needs to catch the other exceptions... 52 | case exception of 53 | -- Rewrite in case of the section already existing! 54 | SectionAlreadyExists _' -> pure () 55 | ParseError errorMessage -> error $ "Parse error: " ++ errorMessage 56 | NoSection errorMessage -> error $ "No such section: " ++ errorMessage 57 | NoOption errorMessage -> error $ "No such option: " ++ errorMessage -- FIXME: this should never happen. 58 | InterpolationError errorMessage -> error $ "No such option: " ++ errorMessage -- FIXME: this should never happen. 59 | OtherProblem errorMessage -> error $ "Error: " ++ errorMessage 60 | Right cp -> do 61 | outPath <- getUserHomepageConfigPath 62 | writeFile outPath (to_string cp) 63 | 64 | 65 | -------------------------------------------------------------------------------- /src/Config/Theme.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | -- | Configuration for themes, namely handling theme.ini. 4 | 5 | module Config.Theme ( setupDefaultTheme, getUserThemePath ) where 6 | 7 | import System.FilePath 8 | import qualified Data.ByteString.Lazy as BL 9 | 10 | import Data.FileEmbed 11 | 12 | import Config ( getConfigDirectory, doIfPathDoesntExist ) 13 | 14 | -- | The standard theme.ini which ships with waffle; before it gets copied 15 | -- to the user's config directory. 16 | defaultThemeContents :: BL.ByteString 17 | defaultThemeContents = BL.fromStrict $(embedFile "data/theme.ini") 18 | 19 | -- | Writes a theme.ini to the user's config directory if they don't have one already. 20 | setupDefaultTheme :: IO () 21 | setupDefaultTheme = do 22 | userThemePath <- getUserThemePath 23 | doIfPathDoesntExist userThemePath (BL.writeFile userThemePath defaultThemeContents) 24 | 25 | -- | Get the `FilePath` to the user's open/associations configuration file. 26 | getUserThemePath :: IO FilePath 27 | getUserThemePath = do 28 | configDir <- getConfigDirectory 29 | pure $ joinPath [configDir, "theme.ini"] 30 | -------------------------------------------------------------------------------- /src/GopherNet.hs: -------------------------------------------------------------------------------- 1 | -- TODO: use FileSig. maybe chain telling from selector and then file ext and as last resort magic string? 2 | module GopherNet 3 | ( writeAllBytes 4 | ) where 5 | 6 | import Data.Maybe 7 | import qualified Data.ByteString as ByteString 8 | import qualified Data.ByteString.UTF8 as U8 9 | 10 | import Network.Simple.TCP 11 | 12 | -- MAYBE TELL TYPE TOO! 13 | -- use mimetype function USING this 14 | -- TODO: add docstring. needs to be both Just or both Nothing! will error otherwise! 15 | writeAllBytes 16 | :: Maybe (a -> Maybe U8.ByteString -> IO a) 17 | -> Maybe a 18 | -> Socket 19 | -> String 20 | -> IO () 21 | writeAllBytes stateMutator someState connectionSocket tempFilePath = do 22 | gosh <- recv connectionSocket recvChunkSize 23 | newState <- case stateMutator of 24 | (Just sm) -> Just <$> sm (fromJust someState) gosh-- FIXME: bad to use fromJust 25 | Nothing -> pure Nothing 26 | case gosh of 27 | Nothing -> pure () 28 | -- Doesn't set to started in status TODO FIXME 29 | Just chnk -> 30 | ByteString.appendFile tempFilePath chnk 31 | >> writeAllBytes stateMutator newState connectionSocket tempFilePath 32 | where 33 | recvChunkSize = 1024 34 | -------------------------------------------------------------------------------- /src/Open.hs: -------------------------------------------------------------------------------- 1 | -- FIXME, TODO: why isn't this just in Config/ConfigOpen? 2 | -- | Open a file with the proper association set as a command in 3 | -- the config. 4 | 5 | module Open (openItem) where 6 | 7 | import System.Process (runCommand, ProcessHandle) 8 | 9 | import Config 10 | import Config.ConfigOpen 11 | import Gopher ( ItemType(..) 12 | ) 13 | 14 | openItemCommand :: ItemType -> IO String 15 | openItemCommand itemType = do 16 | configParser <- getUserOpenConfig 17 | case itemType of 18 | Canonical canonType -> readConfigParserValue configParser "open-assocs" (show canonType) 19 | NonCanonical nonCanonType -> readConfigParserValue configParser "open-assocs" (show nonCanonType) 20 | 21 | openItem :: ItemType -> FilePath -> IO ProcessHandle 22 | openItem itemType filePath = do 23 | command <- openItemCommand itemType 24 | runCommand $ command ++ " \"" ++ filePath ++ "\"" 25 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-15.7 2 | extra-deps: 3 | - HsYAML-0.2.1.0@sha256:e4677daeba57f7a1e9a709a1f3022fe937336c91513e893166bd1f023f530d68,5311 4 | - HsYAML-aeson-0.2.0.0@sha256:04796abfc01cffded83f37a10e6edba4f0c0a15d45bef44fc5bb4313d9c87757,1791 5 | 6 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: HsYAML-0.2.1.0@sha256:e4677daeba57f7a1e9a709a1f3022fe937336c91513e893166bd1f023f530d68,5311 9 | pantry-tree: 10 | size: 1340 11 | sha256: 21f61bf9cad31674126b106071dd9b852e408796aeffc90eec1792f784107eff 12 | original: 13 | hackage: HsYAML-0.2.1.0@sha256:e4677daeba57f7a1e9a709a1f3022fe937336c91513e893166bd1f023f530d68,5311 14 | - completed: 15 | hackage: HsYAML-aeson-0.2.0.0@sha256:04796abfc01cffded83f37a10e6edba4f0c0a15d45bef44fc5bb4313d9c87757,1791 16 | pantry-tree: 17 | size: 234 18 | sha256: 67cc9ba17c79e71d3abdb465a3ee2825477856fff3b8b7d543cbbbefdae9a9d9 19 | original: 20 | hackage: HsYAML-aeson-0.2.0.0@sha256:04796abfc01cffded83f37a10e6edba4f0c0a15d45bef44fc5bb4313d9c87757,1791 21 | snapshots: 22 | - completed: 23 | size: 491389 24 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/7.yaml 25 | sha256: 92ab6303fe20ec928461c82ce0980b4d17c06f4e66205a2967e476474f686c17 26 | original: lts-15.7 27 | -------------------------------------------------------------------------------- /test/MyLibTest.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Test.DocTest 4 | 5 | main :: IO () 6 | main = doctest ["-isrc", "src/Gopher.hs"] 7 | -------------------------------------------------------------------------------- /waffle.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | 3 | -- Initial package description 'waffle.cabal' generated by 'cabal init'. 4 | -- For further documentation, see http://haskell.org/cabal/users-guide/ 5 | 6 | -- The name of the package. 7 | name: waffle 8 | 9 | -- The package version. See the Haskell package versioning policy (PVP) 10 | -- for standards guiding when and how versions should be incremented. 11 | -- https://pvp.haskell.org 12 | -- PVP summary: +-+------- breaking API changes 13 | -- | | +----- non-breaking API additions 14 | -- | | | +--- code changes with no API change 15 | version: 0.24.0.0 16 | 17 | -- A short (one-line) description of the package. 18 | synopsis: Gopher protocol TUI client 19 | 20 | -- A longer description of the package. 21 | description: 22 | Waffle is a [Gopher 23 | protocol](https://en.wikipedia.org/wiki/Gopher_%28protocol%29) text interface 24 | client written in Haskell, implemented according to [RFC 25 | 1436](https://tools.ietf.org/html/rfc1436). 26 | 27 | -- URL for the project homepage or repository. 28 | homepage: https://github.com/hyperrealgopher/waffle 29 | 30 | -- A URL where users can report bugs. 31 | bug-reports: https://github.com/hyperrealgopher/waffle/issues 32 | 33 | -- The license under which the package is released. 34 | license: GPL-3.0-only 35 | 36 | -- The file containing the license text. 37 | license-file: LICENSE 38 | 39 | -- The package author(s). 40 | author: Hyperreal Gopher 41 | 42 | -- An email address to which users can send suggestions, bug reports, and 43 | -- patches. 44 | maintainer: hyperrealgopher@protonmail.ch 45 | 46 | -- A copyright notice. 47 | -- copyright: 48 | 49 | category: Network 50 | 51 | -- Extra files to be distributed with the package, such as examples or a 52 | -- README. 53 | extra-source-files: 54 | README.md 55 | CHANGELOG.md 56 | data/help.txt 57 | data/bookmarks.ini 58 | data/open.ini 59 | 60 | 61 | common shared-properties 62 | 63 | -- NOTE: THIS SHOULD BE FINE ON EVERYTHING... 64 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Werror 65 | 66 | -- NO SEGFAULT: ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Werror 67 | -- ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Werror 68 | -- SEGFAULTS, STATIC: ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Werror -O2 -static -optc-static -optl-static -optl-pthread 69 | 70 | -- ghc-options: -Wall -O2 -static -threaded 71 | -- cc-options: -static 72 | -- ld-options: -static -pthread 73 | 74 | other-modules: 75 | Paths_waffle 76 | 77 | autogen-modules: 78 | Paths_waffle 79 | 80 | build-depends: 81 | base >=4.7, 82 | brick >= 0.53, 83 | bytestring >= 0.10.8, 84 | containers >= 0.6.0, 85 | text >= 1.2.3, 86 | directory >= 1.3.3, 87 | filepath >= 1.4.2, 88 | microlens >= 0.4.11, 89 | vector >= 0.12.1, 90 | vty >= 5.28.2, 91 | utf8-string >= 1.0.1, 92 | network-simple >= 0.4.5, 93 | network-uri >= 2.6.3, 94 | open-browser >= 0.2.1, 95 | split >= 0.2.3, 96 | temporary >= 1.3, 97 | ConfigFile >= 1.1.4, 98 | -- ^ I chose ConfigFile because they're on Gopherspace!le, 99 | process >= 1.6.8 && < 1.7, 100 | file-embed >= 0.0.12 && < 0.1, 101 | mtl >= 2.2.2 && < 2.3, 102 | 103 | -- LANGUAGE extensions used by modules in this package. 104 | other-extensions: OverloadedStrings 105 | 106 | -- Base language which the package is written in. 107 | default-language: Haskell2010 108 | 109 | 110 | library 111 | -- Modules exported by the library. 112 | import: shared-properties 113 | 114 | -- Other library packages from which modules are imported. 115 | exposed-modules: 116 | Gopher 117 | Open 118 | GopherNet 119 | Bookmarks 120 | 121 | Config 122 | Config.ConfigOpen 123 | Config.Homepage 124 | Config.Bookmarks 125 | Config.Theme 126 | 127 | BrickApp 128 | 129 | BrickApp.Types 130 | BrickApp.Types.Helpers 131 | BrickApp.Types.Names 132 | 133 | BrickApp.Draw 134 | BrickApp.Draw.Help 135 | BrickApp.Draw.Menu 136 | BrickApp.Draw.Open 137 | BrickApp.Draw.Progress 138 | BrickApp.Draw.Save 139 | BrickApp.Draw.Search 140 | BrickApp.Draw.TextFile 141 | 142 | BrickApp.Handle 143 | BrickApp.Handle.Goto 144 | BrickApp.Handle.Bookmarks 145 | BrickApp.Handle.Help 146 | BrickApp.Handle.Menu 147 | BrickApp.Handle.Menu.Jump 148 | BrickApp.Handle.Menu.Find 149 | BrickApp.Handle.Open 150 | BrickApp.Handle.Progress 151 | BrickApp.Handle.Save 152 | BrickApp.Handle.Search 153 | BrickApp.Handle.TextFile 154 | 155 | BrickApp.ModeAction.Goto 156 | BrickApp.ModeAction.Homepage 157 | BrickApp.ModeAction.Help 158 | BrickApp.ModeAction.Menu 159 | BrickApp.ModeAction.Menu.Jump 160 | BrickApp.ModeAction.Menu.State 161 | BrickApp.ModeAction.Menu.Find 162 | BrickApp.ModeAction.Open 163 | BrickApp.ModeAction.Progress 164 | BrickApp.ModeAction.Search 165 | BrickApp.ModeAction.Bookmarks 166 | 167 | BrickApp.Utils 168 | BrickApp.Utils.WaffleAddresses 169 | BrickApp.Utils.Style 170 | BrickApp.Utils.Popup 171 | 172 | -- Modules included in this library but not exported. 173 | -- other-modules: 174 | 175 | -- Directories containing source files. 176 | hs-source-dirs: src 177 | 178 | 179 | executable waffle 180 | import: shared-properties 181 | 182 | -- .hs or .lhs file containing the Main module. 183 | main-is: Main.hs 184 | 185 | -- Modules included in this executable, other than Main. 186 | other-modules: 187 | 188 | -- Directories containing source files. 189 | hs-source-dirs: app 190 | 191 | build-depends: waffle 192 | 193 | 194 | test-suite waffle-test 195 | import: shared-properties 196 | 197 | -- The interface type and version of the test suite. 198 | type: exitcode-stdio-1.0 199 | 200 | -- The directory where the test specifications are found. 201 | hs-source-dirs: test 202 | 203 | -- The entrypoint to the test suite. 204 | main-is: MyLibTest.hs 205 | 206 | build-depends: doctest, 207 | --------------------------------------------------------------------------------