├── .github └── workflows │ └── ci.yml ├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── README.md ├── RELEASE.md ├── app ├── DevelMain.hs ├── devel.hs └── main.hs ├── cabal.project ├── config ├── keter.yml ├── nginx.dev.conf ├── robots.txt └── routes ├── deploy ├── backup.sh ├── nginx.conf ├── pursuit.service ├── remote.sh └── run.sh ├── license-generator ├── generate └── header.txt ├── pursuit.cabal ├── src ├── Application.hs ├── Cheapskate │ └── SmartQuotes.hs ├── EmbeddedDocs.hs ├── Foundation.hs ├── GithubAPI.hs ├── Handler │ ├── Caching.hs │ ├── Common.hs │ ├── Database.hs │ ├── Help.hs │ ├── PackageBadges.hs │ ├── Packages.hs │ ├── Search.hs │ └── Utils.hs ├── Import.hs ├── Import │ └── NoFoundation.hs ├── SearchIndex.hs ├── Settings.hs ├── Settings │ └── EmbedPursuitCss.hs ├── TemplateHelpers.hs ├── TimeUtils.hs └── XMLArrows.hs ├── stack.yaml ├── stack.yaml.lock ├── static ├── css │ ├── extra.css │ └── normalize.css ├── favicon │ ├── android-chrome-192x192.png │ ├── android-chrome-512x512.png │ ├── apple-touch-icon.png │ ├── browserconfig.xml │ ├── favicon-16x16.png │ ├── favicon-32x32.png │ ├── favicon-48x48.png │ ├── favicon.ico │ ├── manifest.json │ ├── mstile-150x150.png │ ├── mstile-310x150.png │ ├── mstile-310x310.png │ ├── mstile-70x70.png │ └── safari-pinned-tab.svg ├── fonts │ ├── glyphicons-halflings-regular.eot │ ├── glyphicons-halflings-regular.svg │ ├── glyphicons-halflings-regular.ttf │ └── glyphicons-halflings-regular.woff ├── help-docs │ ├── authors.md │ ├── index.md │ └── users.md ├── js │ ├── Pursuit.js │ ├── html5shiv.js │ └── js.cookie.js └── opensearchdescription.xml ├── templates ├── analytics.julius ├── default-layout-wrapper.hamlet ├── default-layout.hamlet ├── default-layout.julius ├── homepage.hamlet ├── packageNotFound.hamlet ├── packageVersion.hamlet ├── packageVersionModuleDocs.hamlet ├── packageVersionNotFound.hamlet ├── search.hamlet ├── search.julius ├── search.lucius ├── versionSelector.hamlet └── versionSelector.julius └── test ├── SearchSpec.hs └── Spec.hs /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: 4 | pull_request: 5 | push: 6 | branches: [master] 7 | release: 8 | types: [published] 9 | 10 | env: 11 | BUNDLE_DIR: bundle 12 | 13 | jobs: 14 | build_server: 15 | name: Build server 16 | # Note that this must be kept in sync with the version of Ubuntu which the 17 | # Pursit server is running, otherwise the server binary may fail to run. 18 | runs-on: ubuntu-latest 19 | steps: 20 | - uses: actions/checkout@v2 21 | 22 | - uses: haskell/actions/setup@v1 23 | with: 24 | enable-stack: true 25 | stack-version: "2.5.1" 26 | stack-no-global: true 27 | 28 | - name: Cache dependencies 29 | uses: actions/cache@v2 30 | with: 31 | path: ~/.stack 32 | key: ${{ runner.os }}-stack-${{ hashFiles('stack.yaml.lock') }}-${{ hashFiles('pursuit.cabal') }} 33 | 34 | - name: Build server code 35 | run: | 36 | stack --no-terminal --jobs=2 build --flag pursuit:-dev 37 | 38 | - name: Test server code 39 | run: | 40 | stack --no-terminal --jobs=2 test --flag pursuit:-dev --pedantic 41 | 42 | - name: Build server assets 43 | if: github.event_name == 'release' 44 | run: | 45 | mkdir ${{ env.BUNDLE_DIR }} 46 | cp $(stack path --dist-dir)/build/pursuit/pursuit ${{ env.BUNDLE_DIR }}/ 47 | cp LICENSE ${{ env.BUNDLE_DIR }}/ 48 | cp -r deploy/ ${{ env.BUNDLE_DIR }}/ 49 | tar czf pursuit.tar.gz -C ${{ env.BUNDLE_DIR }}/ . 50 | 51 | - name: Persist server assets 52 | uses: actions/upload-artifact@v2 53 | if: github.event_name == 'release' 54 | with: 55 | name: pursuit.tar.gz 56 | path: pursuit.tar.gz 57 | retention-days: 1 58 | 59 | release: 60 | name: Release 61 | # Note that this must be kept in sync with the version of Ubuntu which the 62 | # Pursit server is running, otherwise the server binary may fail to run. 63 | runs-on: ubuntu-latest 64 | if: github.event_name == 'release' 65 | env: 66 | GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} 67 | needs: 68 | - build_server 69 | steps: 70 | - name: Retrieve server assets 71 | uses: actions/download-artifact@v2 72 | with: 73 | name: pursuit.tar.gz 74 | 75 | - name: Upload assets 76 | uses: softprops/action-gh-release@v1 77 | with: 78 | files: | 79 | pursuit.tar.gz 80 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | yesod-devel/ 3 | config/client_session_key.aes 4 | data 5 | static/tmp/ 6 | license-generator/tmp/ 7 | /.stack-work/ 8 | bundle/ 9 | pursuit.tar.gz 10 | dist-newstyle/ 11 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Pursuit Changelog 2 | 3 | Please see https://github.com/purescript/pursuit/blob/master/CHANGELOG.md for 4 | the most up-to-date version of this file. 5 | 6 | ## Unreleased 7 | 8 | ## v0.9.9 9 | 10 | - Update pursuit.service to 3.5GB max memory (@thomashoneyman) 11 | 12 | ## v0.9.8 13 | 14 | - Update PureScript to `0.15.10` (@JordanMartinez) 15 | 16 | ## v0.9.7 17 | 18 | - Update Pursuit version in `pursuit.cabal` (@JordanMartinez) 19 | 20 | The previous release still indicates `v0.9.4` 21 | 22 | ## v0.9.6 23 | 24 | - Update `purescript` to `0.15.8` (support dark theme) (@JordanMartinez) 25 | - Update documentation uploading instructions (@JordanMartinez) 26 | - Bump CI's Ubuntu version to `latest` (@JordanMartinez) 27 | 28 | ## v0.9.5 29 | 30 | Due to an Ubuntu brownout, CI did not build this release properly. 31 | 32 | ## v0.9.4 33 | 34 | - Fix license generation (@JordanMartinez) 35 | 36 | - Update `purescript` to `0.15.6` (@JordanMartinez) 37 | 38 | ## v0.9.3 39 | 40 | - Fix license generation (@andys8) 41 | 42 | - Bump nginx max body limit to 10m (@thomashoneyman) 43 | 44 | - Add cors headers (@sigma-andex) 45 | 46 | - Update `purescript` to `0.15.4` (@sigma-andex) 47 | 48 | Update to GHC 9.2.3 required by Purescript v0.15.4 49 | 50 | ## v0.9.2 51 | 52 | - Update `purescript` to `0.15.2` (@JordanMartinez) 53 | 54 | This version of the compiler corrects and cleans up 55 | some of the docs for the builtin `Prim` module. 56 | 57 | ## v0.9.1 58 | 59 | - Fix typo in `ncu` command on `authors.md` page (@kRITZCREEK) 60 | 61 | ## v0.9.0 62 | 63 | - Update `purescript` to `0.15.0` (@JordanMartinez) 64 | - Fix publishing instructions (@JordanMartinez) 65 | 66 | ## v0.8.7 67 | 68 | - Update `purescript` to `0.14.5` and `purescript-cst` to `0.4.0.0` (@JordanMartinez) 69 | 70 | ## v0.8.5 71 | 72 | - Fix build command used in CI (@thomashoneyman) 73 | 74 | ## v0.8.4 75 | 76 | - Fix typo in CI release script (@thomashoneyman) 77 | 78 | ## v0.8.3 79 | 80 | - Build against v0.14.3 of the PureScript compiler (#436 by @thomashoneyman) 81 | - Migrate to GitHub Actions for CI (#435 by @thomashoneyman) 82 | - Fix an internal typo (#432 by @i-am-the-slime) 83 | - Added a section on kind signatures (#437 by @JordanMartinez) 84 | 85 | ## v0.8.2 86 | 87 | - Default `constraintKindArgs` to an empty list (#430 by @thomashoneyman) 88 | 89 | ## v0.8.1 90 | 91 | - Update outdated Pursuit version in the .cabal file to 0.8.1 (@thomashoneyman) 92 | 93 | ## v0.8.0 94 | 95 | - Build against release 0.14.0-rc3 of the PureScript compiler (#428 by @thomashoneyman) 96 | 97 | ## v0.7.7 98 | 99 | - Avoid deleting the .git directory in the backup script (@hdgarrood) 100 | 101 | ## v0.7.6 102 | 103 | - Fix backup script (@hdgarrood) 104 | 105 | ## v0.7.5 106 | 107 | - Bump the tag this for release via CI (@hdgarrood) 108 | 109 | ## v0.7.4 110 | 111 | - Include the backup script in the deploy bundle (@hdgarrood) 112 | 113 | ## v0.7.3 114 | 115 | - Build against version 0.13.0 of the PureScript compiler (@hdgarrood) 116 | 117 | ## v0.7.2 118 | 119 | - Fix a bug where Prim submodules did not show up in search results (#387) 120 | - Fix a bug where the `text` field for JSON search results contained HTML, as 121 | opposed to the raw Markdown text present in the source file (#171) 122 | - Recommend viewing docs locally before publishing (#384) 123 | 124 | ## v0.7.1 125 | 126 | - Build against version 0.12.2 of the PureScript compiler (@hdgarrood) 127 | 128 | ## v0.7.0 129 | 130 | - Build against version 0.12.0 of the PureScript compiler (@hdgarrood) 131 | - Make documentation for all builtin modules available, rather than just Prim 132 | (@hdgarrood, #357) 133 | - Fix a bug where incorrect types were displayed in search results for data 134 | constructors with 2 or more arguments (@jonathanlking, #373) 135 | - Add an OpenSearch description file (@hdgarrood, #325) 136 | - Use smart quotes in help pages (@hdgarrood, 358) 137 | 138 | ## v0.6.3 139 | 140 | - Add a "load more" button for display of additional search results 141 | (@felixschl, #305) 142 | - Fix source links in re-exported declarations (@felixschl, #345) 143 | - Display the types of data constructors and type class members in search 144 | results (@hdgarrood, #264) 145 | - Include entries from `Prim` in search results (@hdgarrood, #265) 146 | - Allow data constructors and type class members to be found when searching by 147 | type (@hdgarrood, #303) 148 | - Fix searching for type operators by name (@hdgarrood, #330) 149 | - Slightly promote search results which come from packages with more reverse 150 | dependencies (@hdgarrood, #353) 151 | - Fix an issue where any query which included a hyphen would be treated as a 152 | type, preventing searching by name; this was a problem for queries such as 153 | e.g. "generics-rep" (@hdgarrood, #321) 154 | - Take into account whether type variables match when performing type search. 155 | For example, after this change, `map` ranks higher than `cmap` for the query 156 | "(a -> b) -> f a -> f b"; previously they were equally ranked (@hdgarrood, 157 | #355) 158 | - Add help explaining the search feature (@hdgarrood / @grossbart, #339, #357) 159 | 160 | ## v0.6.2 161 | 162 | - Improve 'package not found' message (@hdgarrood) 163 | - Add favicons (@grossbart) 164 | - Update to PureScript 0.11.7 (@hdgarrood) 165 | - Add publish date to package pages (@hdgarrood) 166 | - Redirect URLs without a version to the latest version (@hdgarrood) 167 | - Strip leading/trailing whitespace before searching (@hdgarrood) 168 | - Allow operators to appear in search results without being wrapped by parens 169 | - (@hdgarrood) 170 | - Add a link to Prim to the homepage (@joneshf) 171 | - Clarify contributing docs (@grossbart) 172 | - Update to stackage LTS 8.18 (@hdgarrood) 173 | 174 | ## v0.6.1 175 | 176 | - Update to `purescript-0.11.4`. 177 | 178 | ## v0.6.0 179 | 180 | - Update `aeson` and `purescript` dependencies for JSON compatibility. 181 | 182 | ## v0.5.0 183 | 184 | - Update to `purescript-0.11.0`. 185 | 186 | ## v0.4.\* 187 | 188 | - Recommend pulp for uploading packages (@hdgarrood) 189 | - Remove the package upload form (@hdgarrood) 190 | - Update for purescript 0.9.x (@jplatte) 191 | - Switch to using an in-memory trie instead of Hoogle for searching (@paf31) 192 | - Group packages by letter (@paf31) 193 | - Add list of latest uploads to homepage (@paf31) 194 | - Include type class members when searching by name (@paf31) 195 | - Add the types of things to search results (@nwolversion) 196 | - Explain what happened when failing to fetch a README (@hdgarrood) 197 | - Changes to help with building with GHC8 and Nix (@abuibrahim) 198 | - Better handling of invalid uploaded gzip data (@hdgarrood) 199 | - Provide Prim docs (@hdgarrood) 200 | - Incredible redesign (@grossbart) 201 | - Some styling fixes (@utatti) 202 | - Improve compareTypes algorithm (@matthewleon) 203 | 204 | ## v0.3.10 205 | 206 | - Update to purescript-0.8.5. 207 | - Use the `barrier` Haskell library for generating SVG badges (#102, 208 | @tfausak). 209 | - Improve error messages when uploading incompatible JSON data from a newer 210 | version of the compiler. 211 | - Invalidate caches for `/` and `/packages` properly (#167). 212 | 213 | ## v0.3.9 214 | 215 | - Update to purescript-0.8.4. Fixes an issue where types with constraints 216 | not in the left-most position were being rendered incorrectly: for 217 | example, `unsafePartial` (#176). 218 | 219 | ## v0.3.8 220 | 221 | - Remove superfluous "licensed" text on package pages. ("MIT licensed 222 | licensed") 223 | - Reject packages which do not have a license. 224 | 225 | ## v0.3.7 226 | 227 | - Re-exported declarations are now included on documentation pages. 228 | - Fix versions being ordered nonsensically on 'No such version' pages (#201, 229 | @stefanholzmueller). 230 | - Improve startup time by not waiting for the Hoogle database generation to 231 | complete (#108). 232 | 233 | ## v0.3.6 234 | 235 | - Keep search queries in the search field, allowing you to e.g. easily edit in 236 | case of typos (#185, @LiamGoodacre). 237 | - Fix links to primitive types (#177, @LiamGoodacre). 238 | - Fix parse errors when searching for operators without parentheses (#175, 239 | @kseo). 240 | - Fix display of module names in link tooltips (#202, @LiamGoodacre). 241 | - Update to v0.8.3 of the compiler library. 242 | - Update Stackage snapshot: lts-5.4 → lts-5.10. 243 | 244 | ## v0.3.5 245 | 246 | - Fix links in search results to declarations with non-URL-safe characters 247 | (#166, @kseo). 248 | 249 | ## Earlier versions 250 | 251 | Versions before v0.3.5 are not included, sorry. 252 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Pursuit 2 | 3 | [![Build Status](https://github.com/purescript/pursuit/workflows/CI/badge.svg?branch=master)](https://github.com/purescript/pursuit/actions?query=workflow%3ACI+branch%3Amaster) 4 | 5 | Pursuit hosts API documentation for PureScript packages. It lets you search by 6 | package, module, and function names, as well as approximate type signatures. 7 | 8 | Pursuit is currently deployed at . 9 | 10 | Information for package authors can be found at 11 | . 12 | 13 | ## Development 14 | 15 | It's recommended to use `stack`: . 16 | 17 | ### Build 18 | 19 | To build in development mode: 20 | 21 | ``` 22 | $ stack build 23 | ``` 24 | 25 | To build in production mode: 26 | 27 | ``` 28 | $ stack build --flag pursuit:-dev 29 | ``` 30 | 31 | ### Develop 32 | 33 | To iterate quickly during development, you can use `ghci`: 34 | 35 | ``` 36 | $ stack ghci 37 | ``` 38 | 39 | Once the REPL has loaded, you can reload the code and then update the web server: 40 | 41 | ``` 42 | > :l DevelMain 43 | > update 44 | ``` 45 | 46 | ### Web server 47 | 48 | To run the web server on : 49 | 50 | ``` 51 | $ stack exec pursuit 52 | ``` 53 | 54 | You might want to add some content to the database (see [Database](#database)), 55 | otherwise you will not be able to browse any packages. The database will be 56 | regenerated from this data source before the server starts listening; this 57 | can take a short time depending on how much data you have. 58 | 59 | ## Database 60 | 61 | Pursuit currently uses the filesystem as a database, since it requires no setup 62 | and it makes it easy to use Git and GitHub for backing up. The data directory 63 | is set via an environment variable (see [Configuration](#configuration), the 64 | default is `data`). 65 | 66 | If you need some sample packages to work with, you can clone the 67 | [pursuit-backups][pursuit-backups] repo and copy the packages you want to the 68 | `verified/` directory. This is more convenient than manually uploading each 69 | package. 70 | 71 | [pursuit-backups]: https://github.com/purescript/pursuit-backups 72 | 73 | ### Database structure 74 | 75 | The database structure is as follows: 76 | 77 | ``` 78 | / 79 | cache/ 80 | packages/ 81 | purescript-prelude/ 82 | 0.1.0/ 83 | index.html 84 | docs/ 85 | Prelude/ 86 | index.html 87 | verified/ 88 | purescript-prelude/ 89 | 0.1.0.json 90 | 0.1.1.json 91 | ``` 92 | 93 | The `cache/` directory has files that mirror the URL structure of the web 94 | application, and contains files which do not change and may be served as-is 95 | without forwarding the request on to the Yesod application. See Handler.Caching 96 | for more details. 97 | 98 | The `verified/` directory stores uploaded packages. Each package has its own 99 | directory, and then there is a JSON file for each version. These JSON files 100 | each contain a serialized `Package GithubUser`; see 101 | Language.PureScript.Docs.Types in the compiler for details about these types. 102 | 103 | The backup process simply involves rsyncing everything in the `verified/` 104 | directory into a git repository, making a commit, and pushing it to GitHub. 105 | 106 | ## Configuration 107 | 108 | All configuration is done at startup via environment variables. The relevant 109 | code is in the Settings module. 110 | 111 | All configuration variable names start with `PURSUIT_` (eg, 112 | `PURSUIT_APPROOT`). All configuration variables are optional; for 113 | development, it is fine to just run `stack exec pursuit` leaving them all 114 | unset. 115 | 116 | See `src/Settings.hs` for more details. 117 | 118 | ## Assets 119 | 120 | The favicon assets in `static/favicon` were taken from the [Purescript Logo](https://github.com/purescript/logo) repository. 121 | -------------------------------------------------------------------------------- /RELEASE.md: -------------------------------------------------------------------------------- 1 | # Release 2 | 3 | ## Instructions for Redeploying Pursuit 4 | 5 | After making a new compiler release, do the following to redeploy Pursuit using the new compiler. 6 | 7 | 1. Submit a PR with the following changes: 8 | - In `pursuit.cabal`, do the following: 9 | - update the `version` field to the next release using the `X.X.X` version schema. 10 | - update the `purescript` version to the next release (e.g. `== 0.15.0`) 11 | - In `stack.yaml`, update `purescript` to use its new version. 12 | - Update the `LICENSE` file by running `./license-generator/generate` which executes [`cabal-plan`](https://github.com/haskell-hvr/cabal-plan) 13 | - Update the CHANGELOG.md to include a new section for the new release 14 | 2. Once the PR is merged, create a new GitHub tagged release using `vX.X.X` as the version schema. The release will trigger a GitHub Actions build. 15 | 3. Wait for the GitHub Actions build to finish (it builds the assets) 16 | 4. Run `./deploy/run.sh vX.X.X`, replacing `X.X.X` with the version you created. 17 | -------------------------------------------------------------------------------- /app/DevelMain.hs: -------------------------------------------------------------------------------- 1 | -- | Running your app inside GHCi. 2 | -- 3 | -- To start up GHCi for usage with Yesod, first make sure you are in dev mode: 4 | -- 5 | -- > cabal configure -fdev 6 | -- 7 | -- Note that @yesod devel@ automatically sets the dev flag. 8 | -- Now launch the repl: 9 | -- 10 | -- > cabal repl --ghc-options="-O0 -fobject-code" 11 | -- 12 | -- To start your app, run: 13 | -- 14 | -- > :l DevelMain 15 | -- > DevelMain.update 16 | -- 17 | -- You can also call @DevelMain.shutdown@ to stop the app 18 | -- 19 | -- You will need to add the foreign-store package to your .cabal file. 20 | -- It is very light-weight. 21 | -- 22 | -- If you don't use cabal repl, you will need 23 | -- to run the following in GHCi or to add it to 24 | -- your .ghci file. 25 | -- 26 | -- :set -DDEVELOPMENT 27 | -- 28 | -- There is more information about this approach, 29 | -- on the wiki: https://github.com/yesodweb/yesod/wiki/ghci 30 | 31 | module DevelMain where 32 | 33 | import Prelude 34 | import Application (getApplicationRepl, shutdownApp) 35 | 36 | import Control.Exception (finally) 37 | import Control.Monad ((>=>)) 38 | import Control.Concurrent 39 | import Data.IORef 40 | import Foreign.Store 41 | import Network.Wai.Handler.Warp 42 | import GHC.Word 43 | 44 | -- | Start or restart the server. 45 | -- newStore is from foreign-store. 46 | -- A Store holds onto some data across ghci reloads 47 | update :: IO () 48 | update = do 49 | mtidStore <- lookupStore tidStoreNum 50 | case mtidStore of 51 | -- no server running 52 | Nothing -> do 53 | done <- storeAction doneStore newEmptyMVar 54 | tid <- start done 55 | _ <- storeAction (Store tidStoreNum) (newIORef tid) 56 | return () 57 | -- server is already running 58 | Just tidStore -> restartAppInNewThread tidStore 59 | where 60 | doneStore :: Store (MVar ()) 61 | doneStore = Store 0 62 | 63 | -- shut the server down with killThread and wait for the done signal 64 | restartAppInNewThread :: Store (IORef ThreadId) -> IO () 65 | restartAppInNewThread tidStore = modifyStoredIORef tidStore $ \tid -> do 66 | killThread tid 67 | withStore doneStore takeMVar 68 | readStore doneStore >>= start 69 | 70 | 71 | -- | Start the server in a separate thread. 72 | start :: MVar () -- ^ Written to when the thread is killed. 73 | -> IO ThreadId 74 | start done = do 75 | (port, site, app) <- getApplicationRepl 76 | forkIO (finally (runSettings (setPort port defaultSettings) app) 77 | -- Note that this implies concurrency 78 | -- between shutdownApp and the next app that is starting. 79 | -- Normally this should be fine 80 | (putMVar done () >> shutdownApp site)) 81 | 82 | -- | kill the server 83 | shutdown :: IO () 84 | shutdown = do 85 | mtidStore <- lookupStore tidStoreNum 86 | case mtidStore of 87 | -- no server running 88 | Nothing -> putStrLn "no Yesod app running" 89 | Just tidStore -> do 90 | withStore tidStore $ readIORef >=> killThread 91 | putStrLn "Yesod app is shutdown" 92 | 93 | tidStoreNum :: Word32 94 | tidStoreNum = 1 95 | 96 | modifyStoredIORef :: Store (IORef a) -> (a -> IO a) -> IO () 97 | modifyStoredIORef store f = withStore store $ \ref -> do 98 | v <- readIORef ref 99 | f v >>= writeIORef ref 100 | -------------------------------------------------------------------------------- /app/devel.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports #-} 2 | import "pursuit" Application (develMain) 3 | import Prelude (IO) 4 | 5 | main :: IO () 6 | main = develMain 7 | -------------------------------------------------------------------------------- /app/main.hs: -------------------------------------------------------------------------------- 1 | import Prelude (IO) 2 | import Application (appMain) 3 | 4 | main :: IO () 5 | main = appMain 6 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | 3 | source-repository-package 4 | type: git 5 | location: https://github.com/PureFunctor/barrier.git 6 | tag: db5e27c8ff8f98b2ea18036ce20f853a92aec595 7 | -------------------------------------------------------------------------------- /config/keter.yml: -------------------------------------------------------------------------------- 1 | # After you've edited this file, remove the following line to allow 2 | # `yesod keter` to build your bundle. 3 | user-edited: false 4 | 5 | # A Keter app is composed of 1 or more stanzas. The main stanza will define our 6 | # web application. See the Keter documentation for more information on 7 | # available stanzas. 8 | stanzas: 9 | 10 | # Your Yesod application. 11 | - type: webapp 12 | 13 | # Name of your executable. You are unlikely to need to change this. 14 | # Note that all file paths are relative to the keter.yml file. 15 | exec: ../dist/build/pursuit/pursuit 16 | 17 | # Command line options passed to your application. 18 | args: [] 19 | 20 | hosts: 21 | # You can specify one or more hostnames for your application to respond 22 | # to. The primary hostname will be used for generating your application 23 | # root. 24 | - www.pursuit.com 25 | 26 | # Enable to force Keter to redirect to https 27 | # Can be added to any stanza 28 | requires-secure: false 29 | 30 | # Static files. 31 | - type: static-files 32 | hosts: 33 | - static.pursuit.com 34 | root: ../static 35 | 36 | # Uncomment to turn on directory listings. 37 | # directory-listing: true 38 | 39 | # Redirect plain domain name to www. 40 | - type: redirect 41 | 42 | hosts: 43 | - pursuit.com 44 | actions: 45 | - host: www.pursuit.com 46 | # secure: false 47 | # port: 80 48 | 49 | # Uncomment to switch to a non-permanent redirect. 50 | # status: 303 51 | 52 | # Use the following to automatically copy your bundle upon creation via `yesod 53 | # keter`. Uses `scp` internally, so you can set it to a remote destination 54 | # copy-to: user@host:/opt/keter/incoming 55 | 56 | # If you would like to have Keter automatically create a PostgreSQL database 57 | # and set appropriate environment variables for it to be discovered, uncomment 58 | # the following line. 59 | # plugins: 60 | # postgres: true 61 | -------------------------------------------------------------------------------- /config/nginx.dev.conf: -------------------------------------------------------------------------------- 1 | 2 | # For caching, see below 3 | map $http_accept $file_suffix { 4 | text/html html; 5 | application/json json; 6 | text/svg svg; 7 | text/plain txt; 8 | } 9 | 10 | server { 11 | listen 80; 12 | server_name falcon localhost; 13 | 14 | # nginx has an "always" parameter for this directive (that is, add_header 15 | # Content-Security-Policy "..." always;) which makes it add the header for 16 | # all responses, as opposed to the default behaviour which is to only add 17 | # it on a specific set of 2xx and 3xx status codes. We should be using 18 | # "always" here, but it is only supported by nginx >= 1.7.5, and I can't be 19 | # bothered to update it on my local machine. 20 | add_header Content-Security-Policy 21 | "default-src 'none'; 22 | script-src 'self' *.google-analytics.com; 23 | style-src 'self' fonts.googleapis.com; 24 | font-src fonts.gstatic.com; 25 | img-src *; 26 | connect-src 'self'; 27 | plugin-types 'none'; 28 | base-uri 'none'"; 29 | 30 | 31 | location / { 32 | # this is really gross. sorry 33 | # it's here because nginx will return 405 Not Allowed by default 34 | # if you try to access a static file using the POST method, and 35 | # we need to be able to do `POST /packages`. 36 | error_page 418 = @backend; 37 | recursive_error_pages on; 38 | 39 | if ($request_method != GET) { 40 | return 418; 41 | } 42 | 43 | root /home/harry/documents/code/pursuit/data/cache; 44 | 45 | try_files $uri/index.$file_suffix @backend; 46 | } 47 | 48 | location @backend { 49 | proxy_pass http://localhost:3000; 50 | } 51 | } 52 | -------------------------------------------------------------------------------- /config/robots.txt: -------------------------------------------------------------------------------- 1 | User-agent: * 2 | -------------------------------------------------------------------------------- /config/routes: -------------------------------------------------------------------------------- 1 | /static StaticR EmbeddedStatic appStatic 2 | 3 | /robots.txt RobotsR GET 4 | 5 | / HomeR GET 6 | 7 | /packages PackageIndexR GET POST 8 | /packages/#PathPackageName PackageR GET 9 | /packages/#PathPackageName/#PathVersion PackageVersionR GET 10 | /packages/#PathPackageName/#PathVersion/docs PackageVersionDocsR GET 11 | /packages/#PathPackageName/#PathVersion/docs/#Text PackageVersionModuleDocsR GET 12 | !/packages/#PathPackageName/docs/#Text PackageModuleDocsR GET 13 | !/packages/#PathPackageName/badge PackageBadgeR GET 14 | !/packages/#PathPackageName/available-versions PackageAvailableVersionsR GET 15 | 16 | /builtins/docs/#Text BuiltinDocsR GET 17 | 18 | /search SearchR GET OPTIONS 19 | 20 | /help HelpR GET 21 | /help/authors HelpAuthorsR GET 22 | /help/users HelpUsersR GET 23 | -------------------------------------------------------------------------------- /deploy/backup.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | # Pursuit data backup script 4 | # Arguments: 5 | # SOURCE_DIR - The directory containing all of the package data, within 6 | # Pursuit's data directory. 7 | # DEST_DIR - A directory containing a git repository, with an upstream 8 | # already set up, which the data should be rsync'd to, and then 9 | # committed, and pushed. 10 | 11 | set -e # exit on error 12 | set -u # make undefined variables cause errors 13 | set -o pipefail # propagatee errors in pipelines 14 | 15 | function die() { 16 | echo "$1" >&2 17 | exit 1 18 | } 19 | 20 | for required_cmd in rsync git; do 21 | which "$required_cmd" >/dev/null || 22 | die "The program '$required_cmd' is required but could not be found." 23 | done 24 | 25 | if [ $# -ne 2 ]; then 26 | die "Usage: $0 SOURCE_DIR DEST_DIR" 27 | fi 28 | 29 | SOURCE_DIR="$1" 30 | DEST_DIR="$2" 31 | 32 | rsync --archive --verbose --delete --exclude .git "$SOURCE_DIR" "$DEST_DIR" 33 | pushd "$DEST_DIR" 34 | 35 | git add . # add new files 36 | git add --update . # remove deleted files 37 | git commit -m "Automated backup" 38 | git push 39 | -------------------------------------------------------------------------------- /deploy/nginx.conf: -------------------------------------------------------------------------------- 1 | 2 | # For caching, see below 3 | map $http_accept $file_suffix { 4 | text/html html; 5 | application/json json; 6 | text/svg svg; 7 | text/plain txt; 8 | } 9 | 10 | server { 11 | listen 80 default_server; 12 | listen [::]:80 default_server; 13 | 14 | location /.well-known { 15 | root /var/www/letsencrypt-webroot; 16 | } 17 | 18 | location / { 19 | return 301 https://$host$request_uri; 20 | } 21 | } 22 | 23 | server { 24 | server_name pursuit.purescript.org; 25 | 26 | listen 443 ssl http2; 27 | listen [::]:443 ssl http2; 28 | 29 | # Some package resolutions (web-html, halogen, etc.) exceed the 1m default 30 | # size set by nginx, so we expand that limit. 31 | # https://nginx.org/en/docs/http/ngx_http_core_module.html#client_max_body_size 32 | client_max_body_size 10m; 33 | 34 | # SSL configuration 35 | # based on https://ssl-config.mozilla.org/ 36 | ssl_certificate /etc/letsencrypt/live/pursuit.purescript.org/fullchain.pem; 37 | ssl_trusted_certificate /etc/letsencrypt/live/pursuit.purescript.org/fullchain.pem; 38 | ssl_certificate_key /etc/letsencrypt/live/pursuit.purescript.org/privkey.pem; 39 | ssl_session_timeout 1d; 40 | ssl_session_cache shared:ssl:10m; 41 | ssl_session_tickets off; 42 | ssl_stapling on; 43 | ssl_stapling_verify on; 44 | ssl_dhparam /etc/nginx/ssl_dhparam; 45 | ssl_protocols TLSv1.2 TLSv1.3; 46 | ssl_ciphers ECDHE-ECDSA-AES128-GCM-SHA256:ECDHE-RSA-AES128-GCM-SHA256:ECDHE-ECDSA-AES256-GCM-SHA384:ECDHE-RSA-AES256-GCM-SHA384:ECDHE-ECDSA-CHACHA20-POLY1305:ECDHE-RSA-CHACHA20-POLY1305:DHE-RSA-AES128-GCM-SHA256:DHE-RSA-AES256-GCM-SHA384; 47 | ssl_prefer_server_ciphers off; 48 | 49 | # HSTS 50 | # Maybe enable this later 51 | # Low max-age to start with, just in case 52 | # add_header Strict-Transport-Security "max-age=60" always; 53 | 54 | # Pursuit-specific configuration 55 | add_header Content-Security-Policy 56 | "default-src 'none'; script-src 'self' *.google-analytics.com; style-src 'self' 'unsafe-inline' fonts.googleapis.com; font-src fonts.gstatic.com; img-src *; connect-src 'self'; manifest-src 'self'; plugin-types 'none'; base-uri 'none'" always; 57 | 58 | location / { 59 | # this is really gross. sorry 60 | # it's here because nginx will return 405 Not Allowed by default 61 | # if you try to access a static file using the POST method, and 62 | # we need to be able to do `POST /packages`. 63 | error_page 418 = @backend; 64 | recursive_error_pages on; 65 | 66 | if ($request_method != GET) { 67 | return 418; 68 | } 69 | 70 | root /var/www/pursuit/data/cache; 71 | 72 | try_files $uri/index.$file_suffix @backend; 73 | } 74 | 75 | location @backend { 76 | proxy_pass http://127.0.0.1:3000; 77 | } 78 | } 79 | 80 | -------------------------------------------------------------------------------- /deploy/pursuit.service: -------------------------------------------------------------------------------- 1 | [Unit] 2 | Description=Web service for hosting of PureScript API documentation 3 | 4 | [Service] 5 | Type=simple 6 | User=www-data 7 | ExecStart=/usr/local/bin/pursuit +RTS -N1 -A128m -M3.5G -RTS 8 | Restart=always 9 | RestartSec=5s 10 | Environment="PURSUIT_APPROOT=https://pursuit.purescript.org" 11 | Environment="PURSUIT_HOST=127.0.0.1" 12 | Environment="PURSUIT_PORT=3000" 13 | Environment="PURSUIT_DATA_DIR=/var/www/pursuit/data" 14 | Environment="PURSUIT_MINIMUM_COMPILER_VERSION=0.10.0" 15 | EnvironmentFile=/var/www/pursuit/secrets 16 | 17 | [Install] 18 | WantedBy=multi-user.target 19 | -------------------------------------------------------------------------------- /deploy/remote.sh: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env bash 2 | 3 | set -ex 4 | 5 | # This script should be run on the Pursuit server to deploy a new version. It 6 | # does not attempt to take care of any of the following: 7 | # 8 | # - configuration of secrets/credentials 9 | # - data migrations, 10 | # - nginx SSL configuration, 11 | # - periodic running of the backup script 12 | # 13 | # so whenever any of these are needed, they must be done manually. 14 | 15 | if [ $(id --user) -ne 0 ] 16 | then 17 | echo >&2 "This script must be run as root" 18 | exit 1 19 | fi 20 | 21 | pursuit_version="$1" 22 | 23 | if [ "$pursuit_version" = "" ] 24 | then 25 | echo >&2 "Need to provide a version" 26 | exit 1 27 | fi 28 | 29 | download_url="https://github.com/purescript/pursuit/releases/download/${pursuit_version}/pursuit.tar.gz" 30 | 31 | echo "[$(date)] $0: starting pursuit install" 32 | 33 | # set up directories for deploying into 34 | if [ ! -d /var/www/pursuit ]; then 35 | mkdir -p /var/www/pursuit 36 | chown -R www-data:www-data /var/www/pursuit 37 | fi 38 | 39 | # clone database files if not present 40 | if [ ! -d /var/www/pursuit/data/verified ]; then 41 | sudo -u www-data sh -c 'cd /var/www/pursuit && git clone https://github.com/purescript/pursuit-backups data/verified' 42 | fi 43 | 44 | # download release 45 | tmpdir="$(sudo -u www-data mktemp -d)" 46 | pushd "$tmpdir" 47 | sudo -u www-data wget "$download_url" 48 | sudo -u www-data tar xzf pursuit.tar.gz -C /var/www/pursuit --overwrite 49 | # We install the binary to a location outside of /var/www/pursuit so that we 50 | # can extract tar.gz files into /var/www/pursuit safely in future deploys. 51 | install /var/www/pursuit/pursuit /usr/local/bin/pursuit 52 | popd 53 | rm -r "$tmpdir" 54 | 55 | # install nginx config 56 | cp /var/www/pursuit/deploy/nginx.conf /etc/nginx/sites-enabled/pursuit.conf 57 | systemctl reload nginx 58 | 59 | # install systemd service confing 60 | cp /var/www/pursuit/deploy/pursuit.service /etc/systemd/system/pursuit.service 61 | systemctl daemon-reload 62 | systemctl restart pursuit.service 63 | 64 | echo "[$(date)] $0: done pursuit install" 65 | -------------------------------------------------------------------------------- /deploy/run.sh: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env bash 2 | 3 | set -ex 4 | 5 | # This script can be run to deploy a new version of Pursuit. 6 | 7 | pursuit_version="$1" 8 | 9 | if [ "$pursuit_version" = "" ] 10 | then 11 | echo >&2 "Need to provide a version" 12 | exit 1 13 | fi 14 | 15 | deploy_script="deploy-pursuit.sh" 16 | scp deploy/remote.sh "root@pursuit.purescript.org:${deploy_script}" 17 | ssh root@pursuit.purescript.org "bash ${deploy_script} ${pursuit_version}" 18 | -------------------------------------------------------------------------------- /license-generator/generate: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # Generates the LICENSE file and prints it to standard output. 3 | # Example use: 4 | # 5 | # ./license-generator/generate 6 | # 7 | 8 | set -e # exit on error 9 | set -u # exit on undefined variable 10 | set -o pipefail # propagate nonzero exit codes through pipelines 11 | 12 | # Ensure Cabal knows of the new PureScript package 13 | # (and any deps needed by 'cabal-plan' if it's not already installed) 14 | cabal update 15 | 16 | if ! which cabal-plan >/dev/null; then 17 | echo "$0: The program 'cabal-plan' is required." >&2 18 | echo "$0: see Hackage: https://hackage.haskell.org/package/cabal-plan" >&2 19 | echo "$0: repo: https://github.com/haskell-hvr/cabal-plan" >&2 20 | echo "$0:" >&2 21 | echo "$0: In a new directory:" 22 | echo "$0: 1. Run 'git clone https://github.com/haskell-hvr/cabal-plan.git && cabal build'" 23 | echo "$0: 2. Make sure 'cabal-plan' (cabal >=3.6, ghc >= 9.2) is on the PATH by adding it manually or running `cabal install`" >&2 24 | exit 1 25 | fi 26 | 27 | # Create "dist-newstyle" for cabal-plan using cabal and the same compiler version as stack 28 | echo "Building Pursuit" 29 | ghc=$(stack path --compiler-exe) 30 | cabal build --with-compiler="$ghc" 31 | 32 | echo "Regenerating LICENSE" 33 | { 34 | cat license-generator/header.txt 35 | echo "" 36 | cabal-plan license-report exe:pursuit | sed 's/## /### /; s/# /## /;' 37 | } > LICENSE 38 | 39 | echo "Done!" -------------------------------------------------------------------------------- /license-generator/header.txt: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2015 Phil Freeman, (c) 2015 Harry Garrood 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of 6 | this software and associated documentation files (the "Software"), to deal in 7 | the Software without restriction, including without limitation the rights to 8 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of 9 | the Software, and to permit persons to whom the Software is furnished to do so, 10 | subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS 17 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR 18 | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER 19 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 20 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | 22 | --- 23 | 24 | Pursuit makes use of a number of libraries from Hackage. These libraries and 25 | their licenses are listed below: 26 | -------------------------------------------------------------------------------- /pursuit.cabal: -------------------------------------------------------------------------------- 1 | name: pursuit 2 | version: 0.9.9 3 | cabal-version: >= 1.8 4 | build-type: Simple 5 | license: MIT 6 | license-file: LICENSE 7 | extra-source-files: 8 | CHANGELOG.md 9 | 10 | Flag dev 11 | Description: Turn on development settings, like auto-reload templates. 12 | Default: False 13 | 14 | Flag library-only 15 | Description: Build for use with "yesod devel" 16 | Default: False 17 | 18 | library 19 | hs-source-dirs: src, app 20 | exposed-modules: Application 21 | Cheapskate.SmartQuotes 22 | EmbeddedDocs 23 | Foundation 24 | GithubAPI 25 | Handler.Caching 26 | Handler.Common 27 | Handler.Database 28 | Handler.Help 29 | Handler.PackageBadges 30 | Handler.Packages 31 | Handler.Search 32 | Handler.Utils 33 | Import 34 | Import.NoFoundation 35 | SearchIndex 36 | Settings 37 | Settings.EmbedPursuitCss 38 | TemplateHelpers 39 | TimeUtils 40 | XMLArrows 41 | 42 | other-modules: Paths_pursuit 43 | 44 | if flag(dev) || flag(library-only) 45 | cpp-options: -DDEVELOPMENT 46 | ghc-options: -Wall -fwarn-tabs -O0 47 | else 48 | ghc-options: -Wall -fwarn-tabs -O2 49 | 50 | extensions: TemplateHaskell 51 | QuasiQuotes 52 | OverloadedStrings 53 | NoImplicitPrelude 54 | CPP 55 | MultiParamTypeClasses 56 | TypeFamilies 57 | GADTs 58 | GeneralizedNewtypeDeriving 59 | FlexibleContexts 60 | EmptyDataDecls 61 | NoMonomorphismRestriction 62 | DeriveDataTypeable 63 | DeriveGeneric 64 | ViewPatterns 65 | TupleSections 66 | RecordWildCards 67 | ScopedTypeVariables 68 | StandaloneDeriving 69 | LambdaCase 70 | 71 | build-depends: base >= 4 && < 5 72 | , yesod >= 1.6 && < 1.7 73 | , yesod-core >= 1.6 && < 1.7 74 | , yesod-static >= 1.6 && < 1.7 75 | , yesod-form >= 1.6 && < 1.7 76 | , classy-prelude >= 0.10.2 77 | , classy-prelude-conduit >= 0.10.2 78 | , classy-prelude-yesod >= 0.10.2 79 | , bytestring >= 0.11.3.1 80 | , bytestring-trie 81 | , text 82 | , template-haskell 83 | , shakespeare 84 | , hjsmin 85 | , monad-control 86 | , wai-extra 87 | , yaml 88 | , http-conduit 89 | , deepseq 90 | , directory 91 | , warp 92 | , data-default 93 | , aeson 94 | , conduit 95 | , monad-logger 96 | , fast-logger 97 | , wai-logger 98 | , parallel 99 | , file-embed 100 | , safe 101 | , unordered-containers 102 | , containers 103 | , vector 104 | , time 105 | , purescript ==0.15.10 106 | , bower-json 107 | , blaze-builder 108 | , blaze-markup 109 | , blaze-html 110 | , blaze-svg 111 | , filepath 112 | , dlist 113 | , cheapskate 114 | , split 115 | , mtl 116 | , shakespeare 117 | , colour 118 | , hxt 119 | , base64-bytestring 120 | , http-types 121 | , case-insensitive 122 | , conduit-extra 123 | , aeson-better-errors 124 | , exceptions 125 | , transformers 126 | , cookie 127 | , xss-sanitize 128 | , barrier 129 | , mono-traversable 130 | , streaming-commons 131 | if flag(dev) 132 | build-depends: foreign-store 133 | 134 | executable pursuit 135 | if flag(library-only) 136 | Buildable: False 137 | 138 | main-is: main.hs 139 | hs-source-dirs: app 140 | build-depends: base, pursuit 141 | 142 | ghc-options: -threaded -O2 -rtsopts -with-rtsopts=-N -Wunused-packages 143 | 144 | test-suite test 145 | type: exitcode-stdio-1.0 146 | main-is: Spec.hs 147 | other-modules: SearchSpec 148 | hs-source-dirs: test 149 | ghc-options: -Wall 150 | 151 | extensions: TemplateHaskell 152 | QuasiQuotes 153 | OverloadedStrings 154 | NoImplicitPrelude 155 | CPP 156 | MultiParamTypeClasses 157 | TypeFamilies 158 | GADTs 159 | GeneralizedNewtypeDeriving 160 | FlexibleContexts 161 | EmptyDataDecls 162 | NoMonomorphismRestriction 163 | DeriveDataTypeable 164 | ViewPatterns 165 | TupleSections 166 | 167 | build-depends: base 168 | , pursuit 169 | , yesod-test >= 1.6 && < 1.7 170 | , yesod-core 171 | , yesod 172 | , hspec >= 2.0.0 173 | , classy-prelude 174 | , classy-prelude-yesod 175 | , QuickCheck 176 | -------------------------------------------------------------------------------- /src/Application.hs: -------------------------------------------------------------------------------- 1 | -- To work around a bug in GHC 8.0.1: 2 | -- See https://groups.google.com/forum/#!topic/yesodweb/DlyXqFM7ZnY 3 | {-# LANGUAGE NoDisambiguateRecordFields #-} 4 | {-# LANGUAGE PackageImports #-} 5 | {-# OPTIONS_GHC -fno-warn-orphans #-} 6 | -- We disable the orphan instance warning because mkYesodDispatch defines an 7 | -- orphan instance for the App type. 8 | module Application 9 | ( getApplicationDev 10 | , appMain 11 | , develMain 12 | , makeFoundation 13 | -- * for DevelMain 14 | , getApplicationRepl 15 | , shutdownApp 16 | -- * for GHCI 17 | , handler 18 | ) where 19 | 20 | import Import 21 | import "monad-logger" Control.Monad.Logger (liftLoc) 22 | import Language.Haskell.TH.Syntax (qLocation) 23 | import Control.Concurrent (forkIO, threadDelay) 24 | import Control.Parallel.Strategies (withStrategy) 25 | import Network.Wai.Handler.Warp 26 | (Settings, defaultSettings, defaultShouldDisplayException, runSettings, 27 | setHost, setOnException, setPort, getPort) 28 | import Network.Wai.Middleware.RequestLogger 29 | (Destination (Logger), IPAddrSource (..), OutputFormat (..), destination, 30 | mkRequestLogger, outputFormat) 31 | import System.Log.FastLogger 32 | (defaultBufSize, newStdoutLoggerSet, toLogStr) 33 | import qualified Yesod.Core.Unsafe as Unsafe 34 | 35 | -- Import all relevant handler modules here. 36 | -- Don't forget to add new modules to your cabal file! 37 | import Handler.Common 38 | import Handler.Database 39 | import Handler.Packages 40 | import Handler.Search 41 | import Handler.PackageBadges 42 | import Handler.Help 43 | import SearchIndex (emptySearchIndex, createSearchIndex, evalSearchIndex) 44 | 45 | -- This line actually creates our YesodDispatch instance. It is the second half 46 | -- of the call to mkYesodData which occurs in Foundation.hs. Please see the 47 | -- comments there for more details. 48 | mkYesodDispatch "App" resourcesApp 49 | 50 | -- | This function allocates resources (such as a database connection pool), 51 | -- performs initialization and return a foundation datatype value. This is also 52 | -- the place to put your migrate statements to have automatic database 53 | -- migrations handled by Yesod. 54 | makeFoundation :: AppSettings -> IO App 55 | makeFoundation appSettings = do 56 | let mode = if isDevelopment then "development" else "production" 57 | appStatic = eStatic 58 | putStrLn $ "Starting in " <> mode <> " mode" 59 | appHttpManager <- newManager 60 | appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger 61 | appSearchIndex <- newTVarIO emptySearchIndex 62 | let foundation = App{..} 63 | void (startRegenThread foundation) 64 | return foundation 65 | 66 | where 67 | every interval action = 68 | forkIO (forever (action >> threadDelay interval)) 69 | 70 | startRegenThread foundation = 71 | let hour = 60 * 60 * 1000 * 1000 -- microseconds 72 | in every hour $ do 73 | let emptySessionMap = mempty :: SessionMap 74 | pkgs <- Unsafe.runFakeHandler 75 | emptySessionMap 76 | appLogger 77 | foundation 78 | getAllPackages 79 | 80 | traverse ( atomically 81 | . writeTVar (appSearchIndex foundation) 82 | . withStrategy evalSearchIndex 83 | . createSearchIndex 84 | ) pkgs 85 | 86 | -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and 87 | -- applyng some additional middlewares. 88 | makeApplication :: App -> IO Application 89 | makeApplication foundation = do 90 | logWare <- mkRequestLogger def 91 | { outputFormat = 92 | if appDetailedRequestLogging $ appSettings foundation 93 | then Detailed True 94 | else Apache 95 | (if appIpFromHeader $ appSettings foundation 96 | then FromFallback 97 | else FromSocket) 98 | , destination = Logger $ loggerSet $ appLogger foundation 99 | } 100 | 101 | -- Create the WAI application and apply middlewares 102 | appPlain <- toWaiAppPlain foundation 103 | return $ logWare $ defaultMiddlewaresNoLogging appPlain 104 | 105 | -- | Warp settings for the given foundation value. 106 | warpSettings :: App -> Settings 107 | warpSettings foundation = 108 | setPort (appPort $ appSettings foundation) 109 | $ setHost (appHost $ appSettings foundation) 110 | $ setOnException (\_req e -> 111 | when (defaultShouldDisplayException e) $ messageLoggerSource 112 | foundation 113 | (appLogger foundation) 114 | $(qLocation >>= liftLoc) 115 | "yesod" 116 | LevelError 117 | (toLogStr $ "Exception from Warp: " ++ show e)) 118 | defaultSettings 119 | 120 | -- | For yesod devel, return the Warp settings and WAI Application. 121 | getApplicationDev :: IO (Settings, Application) 122 | getApplicationDev = do 123 | settings <- getAppSettings 124 | foundation <- makeFoundation settings 125 | wsettings <- getDevSettings $ warpSettings foundation 126 | app <- makeApplication foundation 127 | return (wsettings, app) 128 | 129 | -- | main function for use by yesod devel 130 | develMain :: IO () 131 | develMain = develMainHelper getApplicationDev 132 | 133 | -- | The @main@ function for an executable running this site. 134 | appMain :: IO () 135 | appMain = do 136 | -- Get settings from environment 137 | settings <- getAppSettings 138 | 139 | -- Generate the foundation from the settings 140 | foundation <- makeFoundation settings 141 | 142 | -- Generate a WAI Application from the foundation 143 | app <- makeApplication foundation 144 | 145 | -- Run the application with Warp 146 | runSettings (warpSettings foundation) app 147 | 148 | 149 | -------------------------------------------------------------- 150 | -- Functions for DevelMain.hs (a way to run the app from GHCi) 151 | -------------------------------------------------------------- 152 | getApplicationRepl :: IO (Int, App, Application) 153 | getApplicationRepl = do 154 | settings <- getAppSettings 155 | foundation <- makeFoundation settings 156 | wsettings <- getDevSettings $ warpSettings foundation 157 | app1 <- makeApplication foundation 158 | return (getPort wsettings, foundation, app1) 159 | 160 | shutdownApp :: App -> IO () 161 | shutdownApp _ = return () 162 | 163 | 164 | --------------------------------------------- 165 | -- Functions for use in development with GHCi 166 | --------------------------------------------- 167 | 168 | -- | Run a handler 169 | handler :: Handler a -> IO a 170 | handler h = getAppSettings >>= makeFoundation >>= flip unsafeHandler h 171 | -------------------------------------------------------------------------------- /src/Cheapskate/SmartQuotes.hs: -------------------------------------------------------------------------------- 1 | module Cheapskate.SmartQuotes 2 | ( QuoteStyle(..) 3 | , defaultQuoteStyle 4 | , smartQuotes 5 | ) where 6 | 7 | import Prelude 8 | import Data.Text (Text) 9 | import Data.Sequence (Seq, (<|), (|>)) 10 | import qualified Data.Sequence as Seq 11 | import Cheapskate (Doc(..), Inline(..), Block(Para), walk) 12 | 13 | data QuoteStyle = QuoteStyle 14 | { quoteSingle :: (Text, Text) 15 | , quoteDouble :: (Text, Text) 16 | } 17 | deriving (Show, Eq, Ord) 18 | 19 | defaultQuoteStyle :: QuoteStyle 20 | defaultQuoteStyle = QuoteStyle 21 | { quoteSingle = ("‘", "’") -- U+2018, U+2019 22 | , quoteDouble = ("“", "”") -- U+201C, U+201D 23 | } 24 | 25 | -- | Convert straight quotes to smart quotes, according to the given quote 26 | -- style, in the given 'Doc'. 27 | smartQuotes :: QuoteStyle -> Doc -> Doc 28 | smartQuotes style = walk smartly 29 | -- A paragraph in Cheapskate is represented by a list of Inline elements, one 30 | -- of which is the 'Str' constructor, which takes a single 'Text' argument. 31 | -- It is important to note that any character which is not ascii and 32 | -- alphanumeric is placed in a 'Str' constructor on its own. For example, 33 | -- the input 'hello' comes through with three 'Str' constructors: one for the 34 | -- first single quote, one for the string "hello", and a third for the ending 35 | -- single quote. 36 | where 37 | smartly (Para inlines) = Para (processWindows go inlines) 38 | smartly other = other 39 | 40 | go :: Window Inline -> Inline 41 | go w = 42 | case curr w of 43 | Str "\"" -> 44 | Str (quoteDirection w (quoteDouble style)) 45 | Str "'" -> 46 | Str (quoteDirection w (quoteSingle style)) 47 | other -> 48 | other 49 | 50 | -- | True if the given inline element counts as space for the purposes of 51 | -- determining quote direction. 52 | countsAsSpace :: Inline -> Bool 53 | countsAsSpace = \case 54 | Space -> True 55 | SoftBreak -> True 56 | LineBreak -> True 57 | _ -> False 58 | 59 | -- | Determines whether we should use the left or right quote mark. This 60 | -- function returns 'fst' where we should use the left quote, and 'snd' where 61 | -- we should use the right quote. 62 | quoteDirection :: Window Inline -> ((a,a) -> a) 63 | quoteDirection window = 64 | let 65 | space = maybe True countsAsSpace 66 | in 67 | case (space (prev window), space (next window)) of 68 | (True, True) -> 69 | -- on its own; the choice of what to do here seems kind of arbitrary. 70 | snd 71 | (True, False) -> 72 | -- probably at the start of a quotation 73 | fst 74 | (False, True) -> 75 | -- probably at the end of a quotation 76 | snd 77 | (False, False) -> 78 | -- probably internal to a word, e.g. "don't". Use a right quote 79 | -- (apparently that's what we are supposed to use for apostrophes). 80 | snd 81 | 82 | data Window a = Window 83 | { prev :: Maybe a 84 | , curr :: a 85 | , next :: Maybe a 86 | } 87 | deriving (Show, Eq, Ord) 88 | 89 | windows :: Seq a -> Seq (Window a) 90 | windows xs = 91 | Seq.zipWith3 Window 92 | (Nothing <| fmap Just xs) 93 | xs 94 | (fmap Just (Seq.drop 1 xs) |> Nothing) 95 | 96 | processWindows :: (Window a -> a) -> Seq a -> Seq a 97 | processWindows f = fmap f . windows 98 | -------------------------------------------------------------------------------- /src/EmbeddedDocs.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- This module takes care of rendering the Markdown help docs to HTML, and 3 | -- embedding them into the `pursuit` binary at compile-time. 4 | -- 5 | module EmbeddedDocs 6 | ( helpIndex 7 | , helpAuthors 8 | , helpUsers 9 | ) where 10 | 11 | import Import.NoFoundation 12 | import Data.FileEmbed (embedFile) 13 | import qualified Cheapskate 14 | import Cheapskate.SmartQuotes (smartQuotes, defaultQuoteStyle) 15 | 16 | renderMarkdown :: ByteString -> Html 17 | renderMarkdown = 18 | toHtml 19 | . smartQuotes defaultQuoteStyle 20 | . Cheapskate.markdown def 21 | . decodeUtf8 22 | 23 | helpIndex :: Html 24 | helpIndex = renderMarkdown $(embedFile "static/help-docs/index.md") 25 | 26 | helpAuthors :: Html 27 | helpAuthors = renderMarkdown $(embedFile "static/help-docs/authors.md") 28 | 29 | helpUsers :: Html 30 | helpUsers = renderMarkdown $(embedFile "static/help-docs/users.md") 31 | -------------------------------------------------------------------------------- /src/Foundation.hs: -------------------------------------------------------------------------------- 1 | -- To work around a bug in GHC 8.0.1: 2 | -- See https://groups.google.com/forum/#!topic/yesodweb/DlyXqFM7ZnY 3 | {-# LANGUAGE NoDisambiguateRecordFields #-} 4 | {-# OPTIONS_GHC -fno-warn-orphans #-} 5 | module Foundation where 6 | 7 | import Import.NoFoundation 8 | import Language.PureScript.CoreFn.FromJSON (parseVersion') 9 | import Text.Read (readsPrec) 10 | import qualified Data.Text as T 11 | import qualified Data.Text.Lazy as LT 12 | import qualified Text.Blaze.Html.Renderer.Text as Blaze 13 | import Text.Hamlet (hamletFile) 14 | import Text.Jasmine (minifym) 15 | import Text.Julius (rawJS) 16 | import Yesod.Core.Types 17 | ( Logger, HandlerData, rheSite, handlerEnv ) 18 | import Yesod.EmbeddedStatic (EmbeddedStatic, embedStaticContent) 19 | import qualified Yesod.Core.Unsafe as Unsafe 20 | 21 | import Web.Bower.PackageMeta (PackageName, parsePackageName, runPackageName) 22 | import Data.Version 23 | import qualified Language.PureScript.Docs as D 24 | import qualified Paths_pursuit as Paths 25 | 26 | import SearchIndex (SearchIndex) 27 | 28 | newtype PathPackageName = 29 | PathPackageName { runPathPackageName :: PackageName } 30 | deriving (Show, Eq, Ord) 31 | 32 | instance Read PathPackageName where 33 | readsPrec _ str = 34 | case parsePackageName (pack str) of 35 | Right n -> [(PathPackageName n, "")] 36 | Left _ -> [] 37 | 38 | instance PathPiece PathPackageName where 39 | toPathPiece = runPackageName . runPathPackageName 40 | fromPathPiece = fmap PathPackageName . hush . parsePackageName 41 | 42 | newtype PathVersion = 43 | PathVersion { runPathVersion :: Version } 44 | deriving (Show, Eq, Ord, Read) 45 | 46 | instance PathPiece PathVersion where 47 | toPathPiece = toPathPiece . showVersion . runPathVersion 48 | fromPathPiece = fmap PathVersion . parseVersion' . T.unpack 49 | 50 | -- | A base64 encoded string. 51 | newtype VerificationKey = 52 | VerificationKey { runVerificationKey :: ByteString } 53 | deriving (Show, Eq, Ord, Read) 54 | 55 | instance PathPiece VerificationKey where 56 | toPathPiece = decodeUtf8 . runVerificationKey 57 | fromPathPiece = Just . VerificationKey . encodeUtf8 58 | 59 | 60 | -- | The foundation datatype for your application. This can be a good place to 61 | -- keep settings and values requiring initialization before your application 62 | -- starts running, such as database connections. Every handler will have 63 | -- access to the data present here. 64 | data App = App 65 | { appSettings :: AppSettings 66 | , appStatic :: EmbeddedStatic 67 | -- ^ Settings for static file serving. 68 | , appHttpManager :: Manager 69 | , appLogger :: Logger 70 | , appSearchIndex :: TVar SearchIndex 71 | } 72 | 73 | instance HasHttpManager App where 74 | getHttpManager = appHttpManager 75 | 76 | -- This is an orphan instance; previously it seems to have been provided by 77 | -- Yesod, but it appears to no longer exist as of Yesod 1.6. Therefore, we 78 | -- provide it here instead. 79 | instance HasHttpManager site => HasHttpManager (HandlerData child site) where 80 | getHttpManager = getHttpManager . rheSite . handlerEnv 81 | 82 | -- This is where we define all of the routes in our application. For a full 83 | -- explanation of the syntax, please see: 84 | -- http://www.yesodweb.com/book/routing-and-handlers 85 | -- 86 | -- Note that this is really half the story; in Application.hs, mkYesodDispatch 87 | -- generates the rest of the code. Please see the linked documentation for an 88 | -- explanation for this split. 89 | mkYesodData "App" $(parseRoutesFile "config/routes") 90 | 91 | -- | A convenient synonym for creating forms. 92 | type Form x = Html -> MForm (HandlerFor App) (FormResult x, Widget) 93 | 94 | -- Please see the documentation for the Yesod typeclass. There are a number 95 | -- of settings which can be configured by overriding methods here. 96 | instance Yesod App where 97 | -- Controls the base of generated URLs. For more information on modifying, 98 | -- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot 99 | approot = ApprootMaster $ appRoot . appSettings 100 | 101 | -- Store session data on the client in encrypted cookies, 102 | -- default session idle timeout is 120 minutes 103 | makeSessionBackend _ = Just <$> envClientSessionBackend 104 | 120 -- timeout in minutes 105 | "PURSUIT_CLIENT_SESSION_KEY" 106 | 107 | defaultLayout widget = do 108 | -- We break up the default layout into two components: 109 | -- default-layout is the contents of the body tag, and 110 | -- default-layout-wrapper is the entire page. Since the final 111 | -- value passed to hamletToRepHtml cannot be a widget, this allows 112 | -- you to use normal widget features in default-layout. 113 | 114 | manalytics <- appAnalytics . appSettings <$> getYesod 115 | isSearch <- testCurrentRoute (== SearchR) 116 | searchText <- map (fromMaybe "") (lookupGetParam "q") 117 | let pursuitVersion = showVersion Paths.version 118 | pc <- widgetToPageContent $ do 119 | $(widgetFile "default-layout") 120 | case manalytics of 121 | Just analytics -> $(widgetFile "analytics") 122 | _ -> return () 123 | 124 | let pageTitle' = 125 | let renderedTitle = Blaze.renderHtml (pageTitle pc) 126 | in toHtml (if LT.null renderedTitle 127 | then "Pursuit" 128 | else renderedTitle <> " - Pursuit") 129 | 130 | withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet") 131 | 132 | -- Routes not requiring authentication. 133 | isAuthorized RobotsR _ = return Authorized 134 | -- Default to Authorized for now. 135 | isAuthorized _ _ = return Authorized 136 | 137 | addStaticContent = embedStaticContent appStatic StaticR minifym 138 | 139 | makeLogger = return . appLogger 140 | 141 | -- This instance is required to use forms. You can modify renderMessage to 142 | -- achieve customized and internationalized form validation messages. 143 | instance RenderMessage App FormMessage where 144 | renderMessage _ _ = defaultFormMessage 145 | 146 | unsafeHandler :: App -> Handler a -> IO a 147 | unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger 148 | 149 | packageNameRoute :: PackageName -> Route App 150 | packageNameRoute pkgName = 151 | PackageR (PathPackageName pkgName) 152 | 153 | packageRoute :: D.VerifiedPackage -> Route App 154 | packageRoute pkg = 155 | PackageVersionR (PathPackageName (D.packageName pkg)) 156 | (PathVersion (D.pkgVersion pkg)) 157 | 158 | packageDocsRoute :: D.VerifiedPackage -> Route App 159 | packageDocsRoute pkg = 160 | PackageVersionDocsR (PathPackageName (D.packageName pkg)) 161 | (PathVersion (D.pkgVersion pkg)) 162 | 163 | moduleDocsRoute :: D.VerifiedPackage -> Text -> Route App 164 | moduleDocsRoute pkg moduleName = 165 | PackageVersionModuleDocsR (PathPackageName (D.packageName pkg)) 166 | (PathVersion (D.pkgVersion pkg)) 167 | moduleName 168 | 169 | substituteVersion :: Route App -> Version -> Route App 170 | substituteVersion route version' = 171 | let version = PathVersion version' 172 | in case route of 173 | PackageVersionR pkgName _ -> 174 | PackageVersionR pkgName version 175 | PackageVersionDocsR pkgName _ -> 176 | PackageVersionDocsR pkgName version 177 | PackageVersionModuleDocsR pkgName _ modName -> 178 | PackageVersionModuleDocsR pkgName version modName 179 | other -> 180 | other 181 | 182 | -- | Check whether the current route satisfies a predicate 183 | testCurrentRoute :: (Route App -> Bool) -> Handler Bool 184 | testCurrentRoute p = map (maybe False p) getCurrentRoute 185 | -------------------------------------------------------------------------------- /src/GithubAPI.hs: -------------------------------------------------------------------------------- 1 | 2 | module GithubAPI 3 | ( getReadme 4 | , getUser 5 | , ReadmeMissing(..) 6 | ) where 7 | 8 | import Import 9 | import Text.Blaze.Html (preEscapedToHtml) 10 | import qualified Data.ByteString.Lazy as BL 11 | import qualified Data.Aeson as A 12 | import qualified Data.Aeson.KeyMap as KM 13 | import qualified Data.CaseInsensitive as CI 14 | import Text.HTML.SanitizeXSS (sanitize) 15 | import Data.CaseInsensitive (CI) 16 | import qualified Language.PureScript.Docs as D 17 | import qualified Network.HTTP.Types as HTTP 18 | 19 | import qualified XMLArrows 20 | 21 | data ReadmeMissing 22 | = APIRateLimited 23 | | ReadmeNotFound 24 | | OtherReason HttpException 25 | 26 | -- | Try to determine why a readme was not available 27 | diagnoseReadmeProblem :: HttpException -> ReadmeMissing 28 | diagnoseReadmeProblem = \case 29 | HttpExceptionRequest _ (StatusCodeException resp _) 30 | | lookup (CI.mk "X-RateLimit-Remaining") (responseHeaders resp) == Just "0" 31 | && (responseStatus resp) == forbidden403 -> 32 | APIRateLimited 33 | | responseStatus resp == notFound404 -> 34 | ReadmeNotFound 35 | r -> 36 | OtherReason r 37 | 38 | -- | Get a repository readme, rendered as HTML. 39 | getReadme :: 40 | (MonadUnliftIO m, MonadThrow m, MonadIO m, HasHttpManager env, MonadReader env m) => 41 | Maybe GithubAuthToken -> 42 | D.GithubUser -> 43 | D.GithubRepo -> 44 | Text -> -- ref: commit, branch, etc. 45 | m (Either ReadmeMissing Html) 46 | getReadme mauth user repo ref = do 47 | readme <- getReadme' mauth user repo ref 48 | pure $ bimap diagnoseReadmeProblem treatHtml readme 49 | where 50 | treatHtml = 51 | decodeUtf8 52 | >>> unpack 53 | >>> XMLArrows.runString arrow 54 | >>> pack 55 | >>> sanitize 56 | >>> preEscapedToHtml 57 | 58 | arrow = 59 | XMLArrows.stripH1 60 | >>> XMLArrows.makeRelativeLinksAbsolute 61 | "a" "href" (unpack (buildGithubURL user repo ref)) 62 | >>> XMLArrows.makeRelativeLinksAbsolute 63 | "img" "src" (unpack (buildRawGithubURL user repo ref)) 64 | 65 | buildGithubURL :: D.GithubUser -> D.GithubRepo -> Text -> Text 66 | buildGithubURL (D.GithubUser user) (D.GithubRepo repo) ref = 67 | concat ["https://github.com/", user, "/", repo, "/blob/", ref, "/"] 68 | 69 | buildRawGithubURL :: D.GithubUser -> D.GithubRepo -> Text -> Text 70 | buildRawGithubURL (D.GithubUser user) (D.GithubRepo repo) ref = 71 | concat ["https://raw.githubusercontent.com/", user, "/", repo, "/", ref, "/"] 72 | 73 | getReadme' :: 74 | (MonadUnliftIO m, MonadThrow m, MonadIO m, HasHttpManager env, MonadReader env m) => 75 | Maybe GithubAuthToken -> 76 | D.GithubUser -> 77 | D.GithubRepo -> 78 | Text -> -- ref: commit, branch, etc. 79 | m (Either HttpException BL.ByteString) 80 | getReadme' mauth (D.GithubUser user) (D.GithubRepo repo) ref = 81 | let query = "ref=" ++ ref 82 | headers = ("Accept", mediaTypeHtml) : authHeader mauth 83 | in githubAPI ["repos", user, repo, "readme"] query headers 84 | 85 | -- | Get the currently logged in user. 86 | getUser :: 87 | (MonadUnliftIO m, MonadThrow m, MonadIO m, HasHttpManager env, MonadReader env m) => 88 | GithubAuthToken -> m (Either HttpException (Maybe D.GithubUser)) 89 | getUser token = 90 | (map . map) extractUser (getUser' token) >>= catch401 91 | where 92 | extractUser = map D.GithubUser . (loginFromJSON <=< A.decode) 93 | loginFromJSON val = 94 | case val of 95 | A.Object obj -> 96 | case KM.lookup "login" obj of 97 | Just (A.String t) -> Just t 98 | _ -> Nothing 99 | _ -> Nothing 100 | 101 | catch401 (Left (HttpExceptionRequest _ (StatusCodeException resp _))) 102 | | responseStatus resp == HTTP.unauthorized401 = return $ Right Nothing 103 | catch401 other = return other 104 | 105 | getUser' :: 106 | (MonadUnliftIO m, MonadThrow m, MonadIO m, HasHttpManager env, MonadReader env m) => 107 | GithubAuthToken -> m (Either HttpException BL.ByteString) 108 | getUser' auth = 109 | githubAPI ["user"] "" headers 110 | where 111 | headers = ("Accept", "application/json") : authHeader (Just auth) 112 | 113 | githubAPI :: 114 | (MonadUnliftIO m, MonadThrow m, MonadIO m, HasHttpManager env, MonadReader env m) => 115 | [Text] -> -- Path parts 116 | Text -> -- Query string 117 | [(CI ByteString, ByteString)] -> -- Extra headers 118 | m (Either HttpException BL.ByteString) 119 | githubAPI path query extraHeaders = do 120 | tryHttp $ do 121 | initReq <- parseGithubUrlWithQuery path query 122 | let headers = [("User-Agent", "Pursuit")] ++ extraHeaders 123 | let req = initReq { requestHeaders = headers } 124 | liftM responseBody $ httpLbs req 125 | 126 | authHeader :: Maybe GithubAuthToken -> [(CI ByteString, ByteString)] 127 | authHeader mauth = 128 | maybe [] 129 | (\t -> [("Authorization", "bearer " <> runGithubAuthToken t)]) 130 | mauth 131 | 132 | mediaTypeHtml :: ByteString 133 | mediaTypeHtml = "application/vnd.github.v3.html" 134 | 135 | parseGithubUrlWithQuery :: MonadThrow m => [Text] -> Text -> m Request 136 | parseGithubUrlWithQuery parts query = 137 | parseUrlThrow $ unpack $ concat 138 | [ "https://api.github.com/" 139 | , intercalate "/" parts 140 | , "?" 141 | , query 142 | ] 143 | 144 | tryHttp :: (MonadUnliftIO m, MonadThrow m) => m a -> m (Either HttpException a) 145 | tryHttp = try 146 | -------------------------------------------------------------------------------- /src/Handler/Caching.hs: -------------------------------------------------------------------------------- 1 | 2 | module Handler.Caching 3 | ( OkToCache(..) 4 | , cache 5 | , cacheConditional 6 | , cacheHtml 7 | , cacheHtmlConditional 8 | , cacheSvg 9 | , cacheJSON 10 | , cacheText 11 | , clearCache 12 | ) where 13 | 14 | import Import 15 | import Data.Version (Version, showVersion) 16 | import qualified Data.Text.Lazy as LT 17 | import Text.Blaze.Html.Renderer.Utf8 (renderHtml) 18 | import Text.Blaze.Svg11 (Svg) 19 | import Text.Blaze.Svg.Renderer.Utf8 (renderSvg) 20 | import System.Directory (removeDirectoryRecursive, removeFile, getDirectoryContents) 21 | import Web.Bower.PackageMeta (PackageName, runPackageName) 22 | import Data.Aeson (encode) 23 | 24 | import Handler.Utils 25 | 26 | data OkToCache 27 | = OkToCache 28 | | NotOkToCache 29 | deriving (Show, Eq, Ord) 30 | 31 | -- | This function allows an upstream server (such as nginx) to cache a 32 | -- response, by writing the response body to a file before sending it to the 33 | -- client. Afterwards, the upstream server can respond to requests for the same 34 | -- path without having to proxy to the Yesod application, and any caching 35 | -- mechanisms that the upstream server supports can additionally be used. 36 | -- 37 | -- We use Yesod's short-circuiting behaviour here to ensure that this code is 38 | -- never reached if the inner handler generates an internal server error, or a 39 | -- client error such as a 404 (in which case the response should not be 40 | -- cached). 41 | cacheConditional :: (a -> ByteString) -> String -> Handler (OkToCache, a) -> Handler a 42 | cacheConditional toLbs basename action = do 43 | (status, body) <- action 44 | case status of 45 | OkToCache -> write body 46 | NotOkToCache -> $logDebug "response is not cacheable, writing skipped" 47 | return body 48 | where 49 | write body = do 50 | mroute <- getCurrentRoute 51 | case mroute of 52 | Nothing -> return () 53 | Just route -> do 54 | dir <- getRouteCacheDir route 55 | let path = dir ++ basename 56 | $logDebug ("writing response to disk for caching: " ++ pack path) 57 | writeFileWithParents path (toLbs body) 58 | 59 | -- | A variant of cache' to be used when the response is always cacheable 60 | -- (assuming the inner handler completes and returns a value). 61 | cache :: (a -> ByteString) -> String -> Handler a -> Handler a 62 | cache toLbs basename action = 63 | cacheConditional toLbs basename ((OkToCache,) <$> action) 64 | 65 | cacheHtml :: Handler Html -> Handler Html 66 | cacheHtml = cache (toStrict . renderHtml) "index.html" 67 | 68 | cacheHtmlConditional :: Handler (OkToCache, Html) -> Handler Html 69 | cacheHtmlConditional = cacheConditional (toStrict . renderHtml) "index.html" 70 | 71 | cacheSvg :: Handler Svg -> Handler Svg 72 | cacheSvg = cache (toStrict . renderSvg) "index.svg" 73 | 74 | cacheJSON :: Handler Value -> Handler Value 75 | cacheJSON = cache (toStrict . encode) "index.json" 76 | 77 | cacheText :: Handler LT.Text -> Handler LT.Text 78 | cacheText = cache (toStrict . encodeUtf8) "index.txt" 79 | 80 | -- | Clear the whole cache for a particular package at a particular version. 81 | -- Called whenever a new version of a package is uploaded. 82 | -- 83 | -- Note that this function is also responsible for clearing cached 84 | -- resources that are not associated with any particular version, but which 85 | -- need to be regenerated after a new version is uploaded. This includes the 86 | -- available-versions JSON object, or the SVG badge. 87 | clearCache :: PackageName -> Version -> Handler () 88 | clearCache pkgName version = do 89 | $logDebug ("clearing cache for: " <> runPackageName pkgName <> 90 | ", at version: " <> pack (showVersion version)) 91 | 92 | -- TODO: hack, this should be improved. Not quite sure how, though. 93 | removeSpecific 94 | removeShared 95 | 96 | where 97 | -- Remove files specific to that package. 98 | removeSpecific = 99 | let 100 | pkgName' = PathPackageName pkgName 101 | in 102 | eachRouteDir 103 | [ PackageVersionR pkgName' (PathVersion version) 104 | , PackageAvailableVersionsR pkgName' 105 | , PackageBadgeR pkgName' 106 | ] 107 | removeDirectoryRecursive 108 | 109 | -- Remove files that need to be regenerated every time a new package is 110 | -- uploaded, eg lists of all packages. 111 | removeShared = 112 | eachRouteDir 113 | [ PackageIndexR 114 | , HomeR 115 | ] 116 | removeIndexFiles 117 | 118 | eachRouteDir routes f = do 119 | dirs <- getRouteCacheDirs routes 120 | forM_ dirs (liftIO . void . catchDoesNotExist . f) 121 | 122 | -- Remove all files that start "index." in a directory. 123 | removeIndexFiles :: FilePath -> IO () 124 | removeIndexFiles path = do 125 | files <- filter ("index." `isPrefixOf`) <$> getDirectoryContents path 126 | putStrLn ("Removing index files at: " <> tshow path <> ", files:" <> tshow files) 127 | mapM_ (void . catchDoesNotExist . removeFile . (path ++)) files 128 | 129 | 130 | getCacheDir :: Handler String 131 | getCacheDir = (++ "/cache/") <$> getDataDir 132 | 133 | getRouteCacheDir :: Route App -> Handler String 134 | getRouteCacheDir route = 135 | getCacheDir <#> flip cachePathFor route 136 | where 137 | (<#>) = flip (<$>) 138 | 139 | getRouteCacheDirs :: [Route App] -> Handler [String] 140 | getRouteCacheDirs routes = 141 | getCacheDir <#> (\dir -> map (cachePathFor dir) routes) 142 | where 143 | (<#>) = flip (<$>) 144 | 145 | cachePathFor :: String -> Route App -> String 146 | cachePathFor cacheDir = 147 | renderRoute 148 | >>> fst 149 | >>> intercalate "/" 150 | >>> unpack 151 | >>> (cacheDir ++) 152 | >>> (++ "/") 153 | -------------------------------------------------------------------------------- /src/Handler/Common.hs: -------------------------------------------------------------------------------- 1 | -- | Common handler functions. 2 | module Handler.Common where 3 | 4 | import Data.FileEmbed (embedFile) 5 | import Import 6 | 7 | -- These handlers embed files in the executable at compile time to avoid a 8 | -- runtime dependency, and for efficiency. 9 | 10 | getRobotsR :: Handler TypedContent 11 | getRobotsR = return $ TypedContent typePlain 12 | $ toContent $(embedFile "config/robots.txt") 13 | -------------------------------------------------------------------------------- /src/Handler/Database.hs: -------------------------------------------------------------------------------- 1 | -- | This module provides functions for working with the database (i.e. the set 2 | -- of JSON files representing the packages which have been uploaded to 3 | -- Pursuit). 4 | module Handler.Database 5 | ( getAllPackageNames 6 | , getAllPackages 7 | , getLatestPackages 8 | , lookupPackage 9 | , availableVersionsFor 10 | , getLatestVersionFor 11 | , insertPackage 12 | , SomethingMissing(..) 13 | ) where 14 | 15 | import Import 16 | import Language.PureScript.CoreFn.FromJSON (parseVersion') 17 | import qualified Data.Aeson as A 18 | import qualified Data.NonNull as NN 19 | import qualified Data.Text as T 20 | import Data.Version (Version, showVersion) 21 | import System.Directory 22 | (getDirectoryContents, getModificationTime, doesDirectoryExist) 23 | 24 | import Web.Bower.PackageMeta (PackageName, mkPackageName, runPackageName) 25 | import qualified Language.PureScript.Docs as D 26 | 27 | import Handler.Utils 28 | import Handler.Caching (clearCache) 29 | 30 | getAllPackageNames :: Handler [PackageName] 31 | getAllPackageNames = do 32 | dir <- getDataDir 33 | contents <- liftIO $ getDirectoryContents (dir ++ "/verified/") 34 | return . sort . rights $ map (mkPackageName . pack) contents 35 | 36 | getLatestPackages :: Handler [(PackageName, Version)] 37 | getLatestPackages = do 38 | pkgNames <- getAllPackageNames 39 | pkgNamesAndTimestamps <- traverse withTimestamp pkgNames 40 | let latest = (map fst . take 10 . sortBy (comparing (Down . snd))) pkgNamesAndTimestamps 41 | catMaybes <$> traverse withVersion latest 42 | where 43 | withTimestamp :: PackageName -> Handler (PackageName, UTCTime) 44 | withTimestamp name = map (name,) (getPackageModificationTime name) 45 | 46 | withVersion :: PackageName -> Handler (Maybe (PackageName, Version)) 47 | withVersion name = (map . map) (name,) (getLatestVersionFor name) 48 | 49 | -- | This is horribly inefficient, but it will do for now. Note that this 50 | -- only gets the latest version of each package in the database. 51 | getAllPackages :: Handler [D.VerifiedPackage] 52 | getAllPackages = do 53 | pkgNames <- getAllPackageNames 54 | pkgNamesAndVersions <- catMaybes <$> traverse withVersion pkgNames 55 | catMaybes <$> traverse lookupPackageMay pkgNamesAndVersions 56 | where 57 | withVersion name = (map . map) (name,) (getLatestVersionFor name) 58 | lookupPackageMay = map hush . uncurry lookupPackage 59 | 60 | data SomethingMissing 61 | = NoSuchPackage 62 | | NoSuchPackageVersion 63 | deriving (Show, Eq, Ord) 64 | 65 | lookupPackage :: PackageName -> Version -> Handler (Either SomethingMissing D.VerifiedPackage) 66 | lookupPackage pkgName version = do 67 | file <- packageVersionFileFor pkgName version 68 | mcontents <- liftIO (readFileMay file) 69 | case mcontents of 70 | Just contents -> 71 | Right <$> decodeVerifiedPackageFile file contents 72 | Nothing -> do 73 | -- Work out whether there's no such package or just no such version 74 | dir <- packageDirFor pkgName 75 | dirExists <- liftIO $ doesDirectoryExist dir 76 | return $ Left $ if dirExists then NoSuchPackageVersion else NoSuchPackage 77 | 78 | availableVersionsFor :: PackageName -> Handler [Version] 79 | availableVersionsFor pkgName = do 80 | dir <- packageDirFor pkgName 81 | mresult <- liftIO $ catchDoesNotExist $ do 82 | files <- getDirectoryContents dir 83 | return $ mapMaybe (stripSuffix ".json" >=> parseVersion') files 84 | return $ fromMaybe [] mresult 85 | 86 | getPackageModificationTime :: PackageName -> Handler UTCTime 87 | getPackageModificationTime pkgName = do 88 | dir <- packageDirFor pkgName 89 | liftIO $ getModificationTime dir 90 | 91 | getLatestVersionFor :: PackageName -> Handler (Maybe Version) 92 | getLatestVersionFor pkgName = do 93 | vs <- availableVersionsFor pkgName 94 | return $ map NN.maximum (NN.fromNullable vs) 95 | 96 | -- | Insert a package at a specific version into the database. 97 | insertPackage :: D.VerifiedPackage -> Handler () 98 | insertPackage pkg@D.Package{..} = do 99 | let pkgName = D.packageName pkg 100 | file <- packageVersionFileFor pkgName pkgVersion 101 | clearCache pkgName pkgVersion 102 | writeFileWithParents file (toStrict (A.encode pkg)) 103 | 104 | packageDirFor :: PackageName -> Handler String 105 | packageDirFor pkgName = do 106 | dir <- getDataDir 107 | return (dir ++ "/verified/" ++ unpack (runPackageName pkgName)) 108 | 109 | packageVersionFileFor :: PackageName -> Version -> Handler String 110 | packageVersionFileFor pkgName version = do 111 | dir <- packageDirFor pkgName 112 | return (dir ++ "/" ++ showVersion version ++ ".json") 113 | 114 | decodeVerifiedPackageFile :: String -> ByteString -> Handler D.VerifiedPackage 115 | decodeVerifiedPackageFile filepath contents = 116 | decodePackageFile filepath contents 117 | 118 | -- | Prefer decodeVerifiedPackageFile to this function, where possible. 119 | decodePackageFile :: (A.FromJSON a) => String -> ByteString -> Handler (D.Package a) 120 | decodePackageFile filepath contents = do 121 | case A.eitherDecodeStrict contents of 122 | Left err -> do 123 | $logError (T.pack ("Invalid JSON in: " ++ show filepath ++ 124 | ", error: " ++ show err)) 125 | sendResponseStatus internalServerError500 ("" :: String) 126 | Right pkg -> 127 | return pkg 128 | -------------------------------------------------------------------------------- /src/Handler/Help.hs: -------------------------------------------------------------------------------- 1 | 2 | module Handler.Help where 3 | 4 | import Import 5 | import Handler.Caching 6 | import EmbeddedDocs 7 | 8 | getHelpR :: Handler Html 9 | getHelpR = 10 | cacheHtml $ 11 | defaultLayout [whamlet|^{helpLayout Nothing helpIndex}|] 12 | 13 | getHelpAuthorsR :: Handler Html 14 | getHelpAuthorsR = 15 | cacheHtml $ 16 | defaultLayout [whamlet|^{helpLayout (Just "Package authors") helpAuthors}|] 17 | 18 | getHelpUsersR :: Handler Html 19 | getHelpUsersR = 20 | cacheHtml $ 21 | defaultLayout [whamlet|^{helpLayout (Just "Pursuit users") helpUsers}|] 22 | 23 | -- TODO: Generate TOC in sidebar automatically 24 | 25 | helpLayout :: Maybe Text -> Html -> Html 26 | helpLayout forWhom inner = 27 | [shamlet| 28 |
29 | $maybe whom <- forWhom 30 |
Help for 31 |

#{whom} 32 | $nothing 33 |

Help! 34 |
35 | ^{inner} 36 |
37 |
38 |
39 | Overview 40 |
41 | Help index 42 |
43 |
44 | Pursuit users 45 |
46 | 47 | Searching 48 |
49 |
50 | Package authors 51 |
52 | 53 | How to submit packages 54 |
55 | 56 | Submitting packages from a script 57 |
58 | 59 | How to mark package as deprecated 60 |
61 | 62 | Package badges 63 | |] 64 | -------------------------------------------------------------------------------- /src/Handler/PackageBadges.hs: -------------------------------------------------------------------------------- 1 | 2 | module Handler.PackageBadges where 3 | 4 | import Import 5 | import Data.Version 6 | import qualified Text.Blaze as Blaze 7 | import qualified Text.Blaze.Svg11 as S 8 | import Text.Blaze.Svg.Renderer.Text (renderSvg) 9 | import qualified Graphics.Badge.Barrier as Badge 10 | 11 | import Handler.Database (getLatestVersionFor) 12 | import Handler.Caching (cacheSvg) 13 | 14 | newtype ContentSvg = ContentSvg { runContentSvg :: S.Svg } 15 | 16 | instance ToContent ContentSvg where 17 | toContent = toContent . renderSvg . runContentSvg 18 | 19 | instance ToTypedContent ContentSvg where 20 | toTypedContent = TypedContent typeSvg . toContent 21 | 22 | getPackageBadgeR :: PathPackageName -> Handler ContentSvg 23 | getPackageBadgeR (PathPackageName pkgName) = 24 | map ContentSvg $ cacheSvg $ do 25 | msvg <- (map . map) renderBadge (getLatestVersionFor pkgName) 26 | case msvg of 27 | Just svg -> return svg 28 | Nothing -> notFound 29 | 30 | renderBadge :: Version -> S.Svg 31 | renderBadge version = 32 | Blaze.unsafeLazyByteString (Badge.renderBadge badge left right) 33 | where 34 | badge = Badge.flat 35 | left = "pursuit" 36 | right = pack ('v' : showVersion version) 37 | -------------------------------------------------------------------------------- /src/Handler/Packages.hs: -------------------------------------------------------------------------------- 1 | module Handler.Packages where 2 | 3 | import Import 4 | import Text.Julius (rawJS) 5 | import Text.Blaze (ToMarkup, toMarkup) 6 | import qualified Data.Char as Char 7 | import Data.Version 8 | import qualified Data.Text as T 9 | import qualified Data.Text.Lazy as TL 10 | import Language.PureScript.CoreFn.FromJSON (parseVersion') 11 | import qualified Language.PureScript.Docs as D 12 | import Web.Bower.PackageMeta (PackageName, runPackageName, bowerDependencies, bowerLicense) 13 | import qualified Data.Aeson as Aeson 14 | import qualified Data.Aeson.KeyMap as KM 15 | import qualified Data.Aeson.BetterErrors as ABE 16 | import qualified Language.PureScript as P 17 | 18 | import SearchIndex (isDeprecated) 19 | import Handler.Database 20 | import Handler.Caching 21 | import Handler.Utils 22 | import TemplateHelpers 23 | import qualified GithubAPI 24 | 25 | newtype FirstLetter = FirstLetter { getFirstLetter :: Char } 26 | 27 | instance ToMarkup FirstLetter where 28 | toMarkup (FirstLetter a) 29 | | Char.isAlpha a = toMarkup (Char.toUpper a) 30 | | otherwise = toMarkup '#' -- Symbols, digits, etc. 31 | 32 | instance Eq FirstLetter where 33 | FirstLetter a == FirstLetter b 34 | | Char.isAlpha a && Char.isAlpha b = Char.toUpper a == Char.toUpper b 35 | | otherwise = True 36 | 37 | getHomeR :: Handler Html 38 | getHomeR = 39 | cacheHtml $ do 40 | pkgNames <- getAllPackageNames 41 | latest <- getLatestPackages 42 | let firstLetter :: PackageName -> Maybe FirstLetter 43 | firstLetter = fmap FirstLetter . headMay . stripIntro . runPackageName 44 | 45 | stripIntro :: Text -> Text 46 | stripIntro s = fromMaybe s (stripPrefix "purescript-" s) 47 | 48 | pkgNamesByLetter :: [[PackageName]] 49 | pkgNamesByLetter = groupBy ((==) `on` (firstLetter )) pkgNames 50 | defaultLayout $(widgetFile "homepage") 51 | 52 | latestVersionOr404 :: PackageName -> Handler Version 53 | latestVersionOr404 pkgName = do 54 | v <- getLatestVersionFor pkgName 55 | case v of 56 | Nothing -> packageNotFound pkgName 57 | Just v' -> pure v' 58 | 59 | getPackageR :: PathPackageName -> Handler Html 60 | getPackageR ppkgName@(PathPackageName pkgName) = do 61 | v <- latestVersionOr404 pkgName 62 | redirect (PackageVersionR ppkgName (PathVersion v)) 63 | 64 | getPackageModuleDocsR :: PathPackageName -> Text -> Handler Html 65 | getPackageModuleDocsR ppkgName@(PathPackageName pkgName) mnString = do 66 | v <- latestVersionOr404 pkgName 67 | redirect (PackageVersionModuleDocsR ppkgName (PathVersion v) mnString) 68 | 69 | getPackageAvailableVersionsR :: PathPackageName -> Handler Value 70 | getPackageAvailableVersionsR (PathPackageName pkgName) = 71 | cacheJSON $ do 72 | renderUrl <- getUrlRender 73 | vs <- availableVersionsFor pkgName 74 | let toPair v = [ toJSON $ showVersion v 75 | , toJSON $ renderUrl $ alternateVersionUrl v 76 | ] 77 | return $ toJSON $ map toPair $ sort vs 78 | where 79 | alternateVersionUrl v = PackageVersionR (PathPackageName pkgName) (PathVersion v) 80 | 81 | getPackageVersionR :: PathPackageName -> PathVersion -> Handler Html 82 | getPackageVersionR (PathPackageName pkgName) (PathVersion version) = 83 | cacheHtmlConditional $ 84 | findPackageWithLatest pkgName version $ \pkg@D.Package{..} latestPkg -> do 85 | moduleList <- renderModuleList pkg 86 | ereadme <- tryGetReadme pkg 87 | let cacheStatus = either (const NotOkToCache) (const OkToCache) ereadme 88 | content <- defaultLayout $ do 89 | setTitle (toHtml (runPackageName pkgName)) 90 | let dependencies = bowerDependencies pkgMeta 91 | let deprecated = isDeprecated latestPkg 92 | $(widgetFile "packageVersion") 93 | return (cacheStatus, content) 94 | 95 | isPurescriptPackage :: PackageName -> Bool 96 | isPurescriptPackage pkgName = 97 | "purescript-" `T.isPrefixOf` runPackageName pkgName 98 | 99 | getPackageIndexR :: Handler TypedContent 100 | getPackageIndexR = 101 | selectRep $ do 102 | provideRep (redirect HomeR :: Handler Html) 103 | provideRep . cacheText . map unlines $ pkgNames 104 | provideRep . cacheJSON . map toJSON $ pkgNames 105 | where 106 | pkgNames :: Handler [TL.Text] 107 | pkgNames = map (fromStrict . runPackageName) <$> getAllPackageNames 108 | 109 | postPackageIndexR :: Handler Value 110 | postPackageIndexR = do 111 | package <- getUploadedPackageFromBody 112 | mtoken <- lookupAuthTokenHeader 113 | case mtoken of 114 | Nothing -> notAuthenticated 115 | Just token -> do 116 | user <- getUserOrNotAuthenticated token 117 | let package' = D.verifyPackage user package 118 | insertPackage package' 119 | sendResponseCreated $ packageRoute package' 120 | 121 | where 122 | getUploadedPackageFromBody = do 123 | ejson <- parseJsonBodyPotentiallyGzipped 124 | case ejson of 125 | Left err -> 126 | badRequest (pack err) 127 | Right json -> do 128 | epackage <- parseUploadedPackage json 129 | case epackage of 130 | Left err -> 131 | let errorMessage = unlines $ displayJsonError json err 132 | in badRequest errorMessage 133 | Right package -> 134 | return package 135 | 136 | getUserOrNotAuthenticated token = do 137 | euser <- GithubAPI.getUser token 138 | case euser of 139 | Left err -> 140 | $logError (tshow err) >> internalServerError 141 | Right Nothing -> 142 | notAuthenticated 143 | Right (Just user) -> 144 | return user 145 | 146 | lookupAuthTokenHeader = do 147 | mheader <- lookupHeader "Authorization" 148 | return $ mheader >>= extractToken 149 | 150 | extractToken header = 151 | case words (decodeUtf8 header) of 152 | ["token", token] -> Just $ GithubAuthToken $ encodeUtf8 token 153 | _ -> Nothing 154 | 155 | getPackageVersionDocsR :: PathPackageName -> PathVersion -> Handler Html 156 | getPackageVersionDocsR (PathPackageName pkgName) (PathVersion version) = 157 | findPackage pkgName version $ \pkg -> 158 | redirect (packageRoute pkg) 159 | 160 | getPackageVersionModuleDocsR :: PathPackageName -> PathVersion -> Text -> Handler Html 161 | getPackageVersionModuleDocsR (PathPackageName pkgName) (PathVersion version) mnString = 162 | cacheHtml $ findPackageWithLatest pkgName version $ \pkg@D.Package{..} latestPkg -> do 163 | moduleList <- renderModuleList pkg 164 | mhtmlDocs <- renderHtmlDocs pkg mnString 165 | case mhtmlDocs of 166 | Nothing -> notFound 167 | Just htmlDocs -> 168 | defaultLayout $ do 169 | let mn = P.moduleNameFromString mnString 170 | let deprecated = isDeprecated latestPkg 171 | setTitle (toHtml (mnString <> " - " <> runPackageName pkgName)) 172 | $(widgetFile "packageVersionModuleDocs") 173 | 174 | getBuiltinDocsR :: Text -> Handler Html 175 | getBuiltinDocsR mnString = 176 | let 177 | mn = P.moduleNameFromString mnString 178 | in 179 | case primDocsFor mn of 180 | Just htmlDocs -> do 181 | moduleList <- builtinModuleList 182 | defaultLayout $ do 183 | setTitle (toHtml mnString) 184 | [whamlet| 185 |
186 |
Module 187 |

#{insertBreaks mn} 188 | 189 |
190 | #{htmlDocs} 191 | 192 |
193 | #{moduleList} 194 | |] 195 | Nothing -> 196 | defaultLayout404 $ [whamlet| 197 |

Module not found 198 |

No such builtin module: # 199 | #{mnString} 200 | |] 201 | 202 | findPackage :: 203 | PackageName -> 204 | Version -> 205 | (D.VerifiedPackage -> Handler r) -> 206 | Handler r 207 | findPackage pkgName version cont = do 208 | pkg' <- lookupPackage pkgName version 209 | case pkg' of 210 | Right pkg -> cont pkg 211 | Left NoSuchPackage -> packageNotFound pkgName 212 | Left NoSuchPackageVersion -> packageVersionNotFound pkgName version 213 | 214 | findPackageWithLatest :: 215 | PackageName -> 216 | Version -> 217 | (D.VerifiedPackage -> D.VerifiedPackage -> Handler r) -> 218 | Handler r 219 | findPackageWithLatest pkgName version cont = do 220 | findPackage pkgName version $ \pkg -> do 221 | latestVersion <- fromMaybe version <$> getLatestVersionFor pkgName 222 | latestPkg <- fromMaybe pkg . hush <$> lookupPackage pkgName latestVersion 223 | cont pkg latestPkg 224 | 225 | packageNotFound :: PackageName -> Handler a 226 | packageNotFound pkgName = do 227 | defaultLayout404 $(widgetFile "packageNotFound") 228 | 229 | packageVersionNotFound :: PackageName -> Version -> Handler a 230 | packageVersionNotFound pkgName version = do 231 | availableVersions <- map sort $ availableVersionsFor pkgName 232 | defaultLayout404 $(widgetFile "packageVersionNotFound") 233 | 234 | defaultLayout404 :: Widget -> Handler a 235 | defaultLayout404 widget = 236 | defaultLayout widget >>= sendResponseStatus notFound404 237 | 238 | versionSelector :: PackageName -> Version -> WidgetFor App () 239 | versionSelector pkgName version = do 240 | versionSelectorIdent <- newIdent 241 | let route = PackageAvailableVersionsR (PathPackageName pkgName) 242 | availableVersionsUrl <- getUrlRender <*> pure route 243 | $(widgetFile "versionSelector") 244 | 245 | -- | Try to parse a D.UploadedPackage from a JSON Value. 246 | parseUploadedPackage :: 247 | Value -> 248 | Handler (Either (ABE.ParseError D.PackageError) D.UploadedPackage) 249 | parseUploadedPackage value = do 250 | minVersion <- appMinimumCompilerVersion . appSettings <$> getYesod 251 | return $ ABE.parseValue (D.asUploadedPackage minVersion) value 252 | 253 | displayJsonError :: Value -> ABE.ParseError D.PackageError -> [Text] 254 | displayJsonError value e = case e of 255 | ABE.InvalidJSON _ -> 256 | ["The file you submitted was not valid JSON."] 257 | ABE.BadSchema _ _ -> 258 | ABE.displayError D.displayPackageError e ++ extraInfo 259 | 260 | where 261 | -- Attempt to extract the compiler version that a JSON upload was created 262 | -- with. 263 | extractVersion = 264 | toObject 265 | >=> KM.lookup "compilerVersion" 266 | >=> toString 267 | >=> (parseVersion' . unpack) 268 | 269 | toObject json = 270 | case json of 271 | Aeson.Object obj -> Just obj 272 | _ -> Nothing 273 | 274 | toString json = 275 | case json of 276 | Aeson.String str -> Just str 277 | _ -> Nothing 278 | 279 | -- Some extra information about what might have caused an error. 280 | extraInfo = 281 | case extractVersion value of 282 | Just v | v > P.version -> 283 | let pursuitVersion = pack (showVersion P.version) in 284 | [ "Usually, this occurs because the JSON data was generated with a newer " <> 285 | "version of the compiler than what Pursuit is currently using, and " <> 286 | "the JSON format changed between compiler releases." 287 | , "This data was generated with " <> pack (showVersion v) <> " of the compiler." 288 | , "Pursuit is currently using " <> pursuitVersion <> "." 289 | , "You might be able to fix this by temporarily downgrading to " <> 290 | pursuitVersion <> " to generate the JSON data." 291 | ] 292 | _ -> 293 | [] 294 | 295 | versionSeries :: Version -> String 296 | versionSeries (Version (0:x:_) _) = "0." ++ show x ++ ".x" 297 | versionSeries (Version (x:_) _) = show x ++ ".x" 298 | versionSeries _ = "*" 299 | -------------------------------------------------------------------------------- /src/Handler/Search.hs: -------------------------------------------------------------------------------- 1 | 2 | module Handler.Search 3 | ( getSearchR 4 | , optionsSearchR 5 | , SearchResult(..) 6 | , interleave 7 | ) where 8 | 9 | import Import 10 | import qualified Data.Text as T 11 | import Data.Version (showVersion) 12 | import qualified Web.Bower.PackageMeta as Bower 13 | 14 | import Language.PureScript.Docs.AsHtml (makeFragment, renderMarkdown) 15 | import TemplateHelpers (getFragmentRender) 16 | 17 | import qualified Text.Blaze.Html5 as Html5 18 | import qualified Text.Blaze.Renderer.Text as BlazeT 19 | 20 | import qualified Language.PureScript as P 21 | 22 | import qualified XMLArrows 23 | import SearchIndex 24 | (SearchResult(..), SearchResultSource(..), SearchResultInfo(..), SearchIndex, 25 | searchForName, searchForType) 26 | 27 | resultsPerPage :: Int 28 | resultsPerPage = 50 29 | 30 | maxPages :: Int 31 | maxPages = 5 32 | 33 | queryParam :: Text 34 | queryParam = "q" 35 | 36 | pagesParam :: Text 37 | pagesParam = "pages" 38 | 39 | partialParam :: Text 40 | partialParam = "partial" 41 | 42 | optionsSearchR :: Handler RepPlain 43 | optionsSearchR = do 44 | addHeader "Access-Control-Allow-Origin" "*" 45 | addHeader "Access-Control-Allow-Methods" "GET, OPTIONS" 46 | return $ RepPlain $ toContent ("" :: Text) 47 | 48 | getSearchR :: Handler TypedContent 49 | getSearchR = do 50 | query <- getQuery 51 | npages <- getPages 52 | let limit = npages * resultsPerPage 53 | 54 | (results, hasMore) <- do 55 | resultSets <- traverse ($ query) searchSources 56 | let interleavedResults = foldl' interleave [] resultSets 57 | return . take' limit . map fst $ interleavedResults 58 | 59 | let justThisPage = drop (resultsPerPage * (npages - 1)) results 60 | 61 | urls <- getRelatedUrls query npages hasMore 62 | addLinkHeader urls 63 | addHeader "Access-Control-Allow-Origin" "*" 64 | 65 | partial <- lookupGetParam partialParam 66 | if isJust partial 67 | then do 68 | -- XHR; return just the new results and nothing else in an HTML document 69 | fr <- getFragmentRender 70 | 71 | -- An XHR request includes a special header to let the client know 72 | -- whether to offer to render more results. If an X-Load-More header is 73 | -- present, then the value will be a URL which will return more results 74 | -- as a 'partial' (i.e. a minimal HTML document containing the results 75 | -- and nothing else). Otherwise, there will be an X-No-More header, whose 76 | -- value will either be "limited" (if there are further results but 77 | -- Pursuit has opted not to show them), or "exhausted" (if there are no 78 | -- further results). 79 | if hasMore 80 | then do 81 | case relatedUrlsPartial urls of 82 | Just moreUrl -> 83 | addHeader "X-Load-More" moreUrl 84 | Nothing -> 85 | addHeader "X-No-More" "limited" 86 | else 87 | addHeader "X-No-More" "exhausted" 88 | 89 | sendResponseStatus ok200 [shamlet| 90 |

91 | $forall r <- justThisPage 92 | ^{searchResultHtml fr r} 93 | |] 94 | else do 95 | selectRep $ do 96 | provideRep (htmlOutput query urls results) 97 | provideRep (jsonOutput justThisPage) 98 | 99 | where 100 | getQuery :: Handler Text 101 | getQuery = do 102 | mquery <- lookupGetParam "q" 103 | case mquery of 104 | Nothing -> 105 | redirect HomeR 106 | Just query -> 107 | return (T.strip query) 108 | 109 | getPages :: Handler Int 110 | getPages = fmap go (lookupGetParam "pages") 111 | where 112 | go param = 113 | case param >>= (readMay . unpack) of 114 | Just npages -> max 1 (min npages maxPages) 115 | Nothing -> 1 116 | 117 | htmlOutput :: Text -> RelatedUrls -> [SearchResult] -> Handler Html 118 | htmlOutput query urls results = do 119 | fr <- getFragmentRender 120 | content <- defaultLayout $(widgetFile "search") 121 | sendResponseStatus ok200 content 122 | 123 | jsonOutput = fmap toJSON . traverse searchResultToJSON 124 | 125 | -- Used for rendering URLs in Link headers and in the HTML. 126 | data RelatedUrls = RelatedUrls 127 | { relatedUrlsNext :: Maybe Text 128 | , relatedUrlsPrevious :: Maybe Text 129 | , relatedUrlsPartial :: Maybe Text 130 | } 131 | 132 | getRelatedUrls :: Text -> Int -> Bool -> Handler RelatedUrls 133 | getRelatedUrls query npages hasMore = do 134 | urlWithParams <- renderSearchUrlParams 135 | let baseParams = [(queryParam, query)] 136 | let nextParams = 137 | if hasMore && npages < maxPages 138 | then 139 | Just ((pagesParam, tshow (npages + 1)) : baseParams) 140 | else 141 | Nothing 142 | 143 | let nextUrl = 144 | fmap urlWithParams nextParams 145 | let partialUrl = 146 | fmap (\params -> urlWithParams ((partialParam, "true") : params)) 147 | nextParams 148 | 149 | let prevParams = 150 | if npages > 1 151 | then 152 | Just ((pagesParam, tshow (npages - 1)) : baseParams) 153 | else 154 | Nothing 155 | let prevUrl = fmap urlWithParams prevParams 156 | 157 | return RelatedUrls 158 | { relatedUrlsNext = nextUrl 159 | , relatedUrlsPrevious = prevUrl 160 | , relatedUrlsPartial = partialUrl 161 | } 162 | 163 | renderLinkHeader :: RelatedUrls -> Text 164 | renderLinkHeader urls = 165 | let 166 | nextLink = 167 | fmap (\url -> 168 | [ "<" <> url <> ">" 169 | , "rel=\"next\"" 170 | , "title=\"Next " <> tshow resultsPerPage <> " results\"" 171 | ]) (relatedUrlsNext urls) 172 | prevLink = 173 | fmap (\url -> 174 | [ "<" <> url <> ">" 175 | , "rel=\"previous\"" 176 | , "title=\"Previous " <> tshow resultsPerPage <> " results\"" 177 | ]) (relatedUrlsPrevious urls) 178 | in 179 | intercalate ", " (map (intercalate "; ") (catMaybes [nextLink, prevLink])) 180 | 181 | addLinkHeader :: RelatedUrls -> Handler () 182 | addLinkHeader urls = 183 | addHeader "Link" (renderLinkHeader urls) 184 | 185 | -- Render a link to the SearchR route with the given parameters. 186 | renderSearchUrlParams :: Handler ([(Text, Text)] -> Text) 187 | renderSearchUrlParams = do 188 | render <- getUrlRenderParams 189 | return (render SearchR) 190 | 191 | searchResultToJSON :: SearchResult -> Handler Value 192 | searchResultToJSON result@SearchResult{..} = do 193 | url <- getFragmentRender <*> pure (routeResult result) 194 | let html = renderMarkdown srComments 195 | return $ 196 | object [ "package" .= pkg 197 | , "version" .= showVersion version 198 | , "markup" .= BlazeT.renderMarkup html 199 | , "text" .= srComments 200 | , "info" .= toJSON srInfo 201 | , "url" .= url 202 | ] 203 | where 204 | (pkg, version) = 205 | case srSource of 206 | SourceBuiltin -> 207 | ("", P.version) 208 | SourcePackage pn v -> 209 | (Bower.runPackageName pn, v) 210 | 211 | routeResult :: SearchResult -> (Route App, Maybe Text) 212 | routeResult SearchResult{..} = 213 | case srInfo of 214 | PackageResult _ -> 215 | ( case srSource of 216 | SourcePackage pkgName _ -> 217 | PackageR (PathPackageName pkgName) 218 | SourceBuiltin -> 219 | -- this shouldn't happen 220 | HomeR 221 | , Nothing 222 | ) 223 | ModuleResult modName -> 224 | ( moduleRoute modName 225 | , Nothing 226 | ) 227 | DeclarationResult ns modName declTitle _ -> 228 | ( moduleRoute modName 229 | , Just $ drop 1 $ makeFragment ns declTitle 230 | ) 231 | where 232 | moduleRoute = 233 | case srSource of 234 | SourceBuiltin -> 235 | BuiltinDocsR 236 | SourcePackage pkgName version -> 237 | PackageVersionModuleDocsR 238 | (PathPackageName pkgName) 239 | (PathVersion version) 240 | 241 | -- | Like Prelude.take, except also returns a Bool indicating whether the 242 | -- original list has any additional elements after the returned prefix. 243 | take' :: Int -> [a] -> ([a], Bool) 244 | take' n xs = 245 | let (prefix, rest) = splitAt n xs 246 | in (prefix, not (null rest)) 247 | 248 | -- | Interleave two lists. If the arguments are in ascending order (according 249 | -- to their second elements) then the result is also in ascending order. 250 | interleave :: Ord score => [(a,score)] -> [(a,score)] -> [(a,score)] 251 | interleave [] ys = ys 252 | interleave xs [] = xs 253 | interleave (x@(_, scoreX):xs) (y@(_, scoreY):ys) = 254 | if scoreX > scoreY 255 | then 256 | y : interleave (x:xs) ys 257 | else 258 | x : interleave xs (y:ys) 259 | 260 | searchSources :: [Text -> Handler [(SearchResult, Int)]] 261 | searchSources = 262 | map conv 263 | [ searchForName 264 | , searchForType 265 | ] 266 | where 267 | conv :: (Text -> SearchIndex -> [(SearchResult, Int)]) -> 268 | Text -> 269 | Handler [(SearchResult, Int)] 270 | conv f query = do 271 | idx <- liftIO . readTVarIO . appSearchIndex =<< getYesod 272 | return $ f query idx 273 | 274 | renderMarkdownNoLinks :: Text -> Html 275 | renderMarkdownNoLinks = 276 | renderMarkdown 277 | -- Wrapping in a div is necessary because of how XML arrows work 278 | >>> Html5.div 279 | >>> XMLArrows.run XMLArrows.replaceLinks 280 | 281 | searchResultHtml :: ((Route App, Maybe Text) -> Text) -> SearchResult -> Html 282 | searchResultHtml fr r = 283 | [shamlet| 284 |
285 |

286 | $case srInfo r 287 | $of PackageResult deprecated 288 | P 289 | 290 | #{pkgName} 291 | $if deprecated 292 | 293 | DEPRECATED 294 | $of ModuleResult moduleName 295 | M 296 | 297 | #{moduleName} 298 | $of DeclarationResult _ _ name _ 299 | 300 | #{name} 301 | 302 |
303 | $case srInfo r 304 | $of PackageResult _ 305 | $of ModuleResult _ 306 | $of DeclarationResult _ _ name typ 307 | $maybe typeValue <- typ 308 | 
#{name} :: #{typeValue}
309 | 310 | #{renderMarkdownNoLinks $ srComments r} 311 | 312 |
313 | $case srInfo r 314 | $of PackageResult _ 315 | $of ModuleResult _ 316 | 317 | P 318 | #{pkgName} 319 | $of DeclarationResult _ moduleName _ _ 320 | 321 | P 322 | #{pkgName} 323 | 324 | M 325 | #{moduleName} 326 | |] 327 | where 328 | pkgName = 329 | case srSource r of 330 | SourceBuiltin -> 331 | "" 332 | SourcePackage pn _ -> 333 | Bower.runPackageName pn 334 | -------------------------------------------------------------------------------- /src/Handler/Utils.hs: -------------------------------------------------------------------------------- 1 | 2 | module Handler.Utils where 3 | 4 | import Import 5 | import TimeUtils 6 | import qualified Data.Aeson.Parser as AP 7 | import qualified Data.Conduit.Zlib as Zlib 8 | import Data.Streaming.Zlib (ZlibException(..)) 9 | import qualified Data.Conduit.Attoparsec as Attoparsec 10 | import Web.Cookie (setCookieName, setCookieValue, setCookieMaxAge) 11 | import System.Directory (createDirectoryIfMissing, removeFile, 12 | getDirectoryContents, getModificationTime) 13 | import System.FilePath (takeDirectory) 14 | 15 | badRequest :: Text -> Handler a 16 | badRequest = sendResponseStatus badRequest400 17 | 18 | internalServerError :: Handler a 19 | internalServerError = sendResponseStatus internalServerError500 ("" :: Text) 20 | 21 | getDataDir :: Handler String 22 | getDataDir = appDataDir . appSettings <$> getYesod 23 | 24 | -- | Read the file at the given path as a strict ByteString, or return Nothing 25 | -- if no such file exists. 26 | readFileMay :: FilePath -> IO (Maybe ByteString) 27 | readFileMay file = 28 | catchDoesNotExist (readFile file) 29 | 30 | catchDoesNotExist :: IO a -> IO (Maybe a) 31 | catchDoesNotExist act = 32 | catchJust selectDoesNotExist 33 | (Just <$> act) 34 | (const (return Nothing)) 35 | where 36 | selectDoesNotExist e 37 | | isDoesNotExistErrorType (ioeGetErrorType e) = Just () 38 | | otherwise = Nothing 39 | 40 | writeFileWithParents :: MonadIO m => FilePath -> ByteString -> m () 41 | writeFileWithParents file contents = liftIO $ do 42 | createDirectoryIfMissing True (takeDirectory file) 43 | writeFile file contents 44 | 45 | deleteFilesOlderThan :: forall m. 46 | (MonadIO m, MonadUnliftIO m, MonadLogger m) => 47 | NominalDiffTime -> FilePath -> m () 48 | deleteFilesOlderThan maxAge dir = do 49 | files <- getDirectoryContents' dir 50 | filesWithTimes <- liftIO $ traverse (\f -> (f,) <$> getAge f) files 51 | otraverse_ (\(f, age) -> when (age > maxAge) (tryRemoveFile f)) filesWithTimes 52 | where 53 | getAge f = getModificationTime f >>= getElapsedTimeSince 54 | 55 | tryRemoveFile = flip catch logIOException . liftIO . removeFile 56 | 57 | logIOException :: IOException -> m () 58 | logIOException e = $logError (tshow e) 59 | 60 | -- | Like getDirectoryContents, except that: 61 | -- * It includes the directory that you supplied, so that you can safely pass 62 | -- the results to readFile etc 63 | -- * It removes "." and ".." from the results 64 | -- * It works for any MonadIO 65 | getDirectoryContents' :: forall m. MonadIO m => FilePath -> m [FilePath] 66 | getDirectoryContents' dir = 67 | liftIO $ 68 | map (dir ++) . filter (`onotElem` [".", ".."]) <$> getDirectoryContents dir 69 | 70 | -- | Sets a message which is displayed just once, at the next time the user's 71 | -- browser renders a page. 72 | setCookieMessage :: ByteString -> Handler () 73 | setCookieMessage msg = 74 | setCookie def { setCookieName = "message" 75 | , setCookieValue = msg 76 | , setCookieMaxAge = Just $ secondsToDiffTime 3600 77 | } 78 | 79 | -- | Like Yesod's parseJsonBody, but this version first checks for a 80 | -- Content-Encoding: gzip header and unzips the body if that is found. 81 | parseJsonBodyPotentiallyGzipped :: Handler (Either String Value) 82 | parseJsonBodyPotentiallyGzipped = do 83 | unzipping <- shouldUnzip <$> lookupHeader hContentEncoding 84 | let unzipIfNecessary = if unzipping then Zlib.ungzip else mapC id 85 | 86 | bodyChunks <- sourceToList rawRequestBody 87 | liftIO $ 88 | let 89 | jsonBodyC = 90 | yieldMany bodyChunks .| 91 | unzipIfNecessary .| 92 | Attoparsec.sinkParser AP.value' 93 | in 94 | catch (map Right (runConduit jsonBodyC)) 95 | (pure . Left . display) 96 | 97 | where 98 | shouldUnzip = maybe False (== "gzip") 99 | 100 | display e = 101 | case fromException e of 102 | Just (ZlibException (-3)) -> 103 | "Invalid gzip data in request body" 104 | _ -> 105 | case fromException e of 106 | Just err -> 107 | Attoparsec.errorMessage err 108 | _ -> 109 | show e 110 | -------------------------------------------------------------------------------- /src/Import.hs: -------------------------------------------------------------------------------- 1 | module Import 2 | ( module Import 3 | ) where 4 | 5 | import Foundation as Import 6 | import Import.NoFoundation as Import 7 | -------------------------------------------------------------------------------- /src/Import/NoFoundation.hs: -------------------------------------------------------------------------------- 1 | module Import.NoFoundation 2 | ( module Import 3 | , hush 4 | ) where 5 | 6 | import ClassyPrelude.Yesod as Import 7 | import Settings as Import 8 | import Yesod.Core.Types as Import (loggerSet) 9 | import Yesod.Default.Config2 as Import 10 | import Control.Category as Import ((>>>), (<<<)) 11 | 12 | hush :: Either a b -> Maybe b 13 | hush = either (const Nothing) Just 14 | -------------------------------------------------------------------------------- /src/SearchIndex.hs: -------------------------------------------------------------------------------- 1 | module SearchIndex 2 | ( SearchResult(..) 3 | , SearchResultSource(..) 4 | , SearchResultInfo(..) 5 | , searchResultTitle 6 | , SearchIndex 7 | , emptySearchIndex 8 | , createSearchIndex 9 | , evalSearchIndex 10 | , searchForName 11 | , searchForType 12 | , compareTypes 13 | , typeComplexity 14 | , parseType 15 | , isSymbol 16 | , isDeprecated 17 | ) where 18 | 19 | import Import.NoFoundation 20 | import Control.Parallel.Strategies (Strategy, evalTraversable, rdeepseq) 21 | import Control.Monad.Trans.Writer (WriterT(..), tell) 22 | import Data.Trie (Trie) 23 | import Data.Version (Version) 24 | import qualified Data.Map as Map 25 | import qualified Data.Set as Set 26 | import qualified Data.Text as T 27 | import qualified Data.Trie as Trie 28 | import qualified Language.PureScript as P 29 | import qualified Language.PureScript.Docs as D 30 | import qualified Language.PureScript.CST as CST 31 | import qualified Language.PureScript.CST.Monad as CSTM 32 | import Web.Bower.PackageMeta 33 | (PackageName, bowerName, bowerDescription, bowerKeywords, runPackageName) 34 | 35 | -- | A single search result. 36 | data SearchResult = SearchResult 37 | { srSource :: SearchResultSource 38 | , srComments :: Text 39 | , srInfo :: SearchResultInfo 40 | } 41 | deriving (Show, Eq, Generic) 42 | 43 | instance NFData SearchResult 44 | 45 | -- | Tells you where a search result came from. 46 | data SearchResultSource 47 | = SourceBuiltin 48 | | SourcePackage PackageName Version 49 | deriving (Show, Eq, Generic) 50 | 51 | instance NFData SearchResultSource 52 | 53 | data SearchResultInfo 54 | = PackageResult Bool 55 | -- ^ Package deprecation status 56 | | ModuleResult Text 57 | -- ^ Module name 58 | | DeclarationResult D.Namespace Text Text (Maybe Text) 59 | -- ^ Module name & declaration title & type if value 60 | deriving (Show, Eq, Generic) 61 | 62 | instance NFData SearchResultInfo 63 | 64 | instance ToJSON SearchResultInfo where 65 | toJSON i = object $ case i of 66 | PackageResult deprecated -> 67 | [ "type" .= ("package" :: Text) 68 | , "deprecated" .= deprecated 69 | ] 70 | ModuleResult moduleName -> 71 | [ "type" .= ("module" :: Text) 72 | , "module" .= moduleName 73 | ] 74 | DeclarationResult typeOrValue moduleName declTitle typeText -> 75 | [ "type" .= ("declaration" :: Text) 76 | , "typeOrValue" .= show typeOrValue 77 | , "module" .= moduleName 78 | , "title" .= declTitle 79 | , "typeText" .= typeText 80 | ] 81 | 82 | searchResultTitle :: SearchResult -> Text 83 | searchResultTitle r = 84 | case srInfo r of 85 | PackageResult _ -> 86 | case srSource r of 87 | SourceBuiltin -> 88 | "" 89 | SourcePackage pkgName _ -> 90 | runPackageName pkgName 91 | ModuleResult modName -> 92 | modName 93 | DeclarationResult _ title _ _ -> 94 | title 95 | 96 | newtype SearchIndex 97 | = SearchIndex { unSearchIndex :: Trie [IndexEntry] } 98 | 99 | data IndexEntry = IndexEntry 100 | { entryResult :: !SearchResult 101 | , entryType :: !(Maybe D.Type') 102 | -- | The number of reverse dependencies of the containing package. Used for 103 | -- sorting otherwise equivalently-ranked results. We use 'Maybe (Down Int)' 104 | -- so that builtin modules (e.g. Prim) can use 'Nothing' and have it compare 105 | -- less than everything else, and otherwise, packages with more reverse 106 | -- dependencies compare less than packages with more; note that lower is 107 | -- better when searching. 108 | , entryRevDeps :: !(Maybe (Down Int)) 109 | } 110 | deriving (Show, Eq, Generic) 111 | 112 | instance NFData IndexEntry 113 | 114 | emptySearchIndex :: SearchIndex 115 | emptySearchIndex = SearchIndex Trie.empty 116 | 117 | -- | Given a list of packages, create a search index for them. 118 | createSearchIndex :: [D.Package a] -> SearchIndex 119 | createSearchIndex = 120 | countReverseDependencies 121 | >>> sortOn (Down . snd) 122 | >>> concatMap (uncurry entriesForPackage) 123 | >>> (primEntries ++) 124 | >>> fromListWithDuplicates 125 | >>> SearchIndex 126 | 127 | -- | A strategy for evaluating a SearchIndex in parallel. 128 | evalSearchIndex :: Strategy SearchIndex 129 | evalSearchIndex = fmap SearchIndex . evalTraversable rdeepseq . unSearchIndex 130 | 131 | -- | 132 | -- Given a list of packages (which should not include duplicates, or more than 133 | -- one version of any given package), return a list of packages together with 134 | -- the number of reverse dependencies each one has, in no particular order. 135 | -- 136 | countReverseDependencies :: [D.Package a] -> [(D.Package a, Int)] 137 | countReverseDependencies packages = 138 | Map.elems $ foldl' go initialMap packages 139 | where 140 | initialMap = 141 | Map.fromList $ map (\pkg -> (D.packageName pkg, (pkg, 0))) packages 142 | 143 | go m pkg = 144 | foldl' (flip increment) m 145 | (map fst (D.pkgResolvedDependencies pkg)) 146 | 147 | increment = 148 | Map.adjust (second (+1)) 149 | 150 | primEntries :: [(ByteString, IndexEntry)] 151 | primEntries = 152 | let 153 | mkEntry comments info mtype = 154 | IndexEntry 155 | { entryResult = SearchResult SourceBuiltin comments info 156 | , entryType = mtype 157 | , entryRevDeps = Nothing 158 | } 159 | in 160 | concatMap (entriesForModule mkEntry) D.primModules 161 | 162 | entriesForPackage :: D.Package a -> Int -> [(ByteString, IndexEntry)] 163 | entriesForPackage pkg@D.Package{..} revDeps = 164 | let 165 | src = 166 | SourcePackage (bowerName pkgMeta) pkgVersion 167 | mkEntry comments info mtype = 168 | IndexEntry 169 | { entryResult = SearchResult src comments info 170 | , entryType = mtype 171 | , entryRevDeps = Just (Down revDeps) 172 | } 173 | entryKey = 174 | encodeUtf8 175 | (tryStripPrefix "purescript-" 176 | (T.toLower 177 | (runPackageName (bowerName pkgMeta)))) 178 | deprecated = isDeprecated pkg 179 | packageEntry = 180 | ( entryKey 181 | , mkEntry (fromMaybe "" (bowerDescription pkgMeta)) 182 | (PackageResult deprecated) 183 | Nothing 184 | ) 185 | in 186 | packageEntry : if deprecated 187 | then [] 188 | else concatMap (entriesForModule mkEntry) pkgModules 189 | 190 | entriesForModule :: 191 | (Text -> SearchResultInfo -> Maybe D.Type' -> IndexEntry) -> 192 | D.Module -> 193 | [(ByteString, IndexEntry)] 194 | entriesForModule mkEntry D.Module{..} = 195 | let 196 | moduleEntry = 197 | ( encodeUtf8 (T.toLower (P.runModuleName modName)) 198 | , mkEntry (fromMaybe "" modComments) 199 | (ModuleResult (P.runModuleName modName)) 200 | Nothing 201 | ) 202 | in 203 | moduleEntry : 204 | concatMap (entriesForDeclaration mkEntry modName) modDeclarations 205 | 206 | entriesForDeclaration :: 207 | (Text -> SearchResultInfo -> Maybe D.Type' -> IndexEntry) -> 208 | P.ModuleName -> 209 | D.Declaration -> 210 | [(ByteString, IndexEntry)] 211 | entriesForDeclaration mkEntry modName D.Declaration{..} = 212 | let 213 | ty = 214 | case declInfo of 215 | D.ValueDeclaration t -> Just t 216 | _ -> Nothing 217 | ns = 218 | D.declInfoNamespace declInfo 219 | declEntry = 220 | ( encodeUtf8 (T.toLower (handleTypeOp declTitle)) 221 | , mkEntry (fromMaybe "" declComments) 222 | (DeclarationResult 223 | ns 224 | (P.runModuleName modName) 225 | declTitle 226 | (fmap typeToText ty)) 227 | ty 228 | ) 229 | in 230 | declEntry : do 231 | D.ChildDeclaration{..} <- declChildren 232 | let ty' = extractChildDeclarationType declTitle declInfo cdeclInfo 233 | return ( encodeUtf8 (T.toLower cdeclTitle) 234 | , mkEntry (fromMaybe "" cdeclComments) 235 | (DeclarationResult 236 | D.ValueLevel 237 | (P.runModuleName modName) 238 | cdeclTitle 239 | (fmap typeToText ty')) 240 | ty' 241 | ) 242 | where 243 | -- The declaration title of a type operator is e.g. "type (/\)". Here we 244 | -- remove this prefix but leave other kinds of declarations unchanged. 245 | handleTypeOp = tryStripPrefix "type " 246 | 247 | typeToText :: D.Type' -> Text 248 | typeToText = D.outputWith renderText . D.renderType 249 | 250 | 251 | renderText :: D.RenderedCodeElement -> Text 252 | renderText codeElem = case codeElem of 253 | D.Syntax s -> s 254 | D.Keyword s -> s 255 | D.Space -> " " 256 | D.Symbol _ s _ -> s 257 | D.Role s -> s 258 | 259 | fromListWithDuplicates :: [(ByteString, a)] -> Trie [a] 260 | fromListWithDuplicates = foldr go Trie.empty 261 | where 262 | go (k, a) = Trie.alterBy (\_ xs -> Just . maybe xs (xs <>)) k [a] 263 | 264 | -- Extract the type of a child declaration when considering it as a standalone 265 | -- declaration. For instance, type class members need to have the appropriate 266 | -- constraint added, and data constructors need to have their arguments plus 267 | -- the parent data type put together to form the constructor's type. 268 | -- 269 | -- TODO: Move this into the purescript library? 270 | extractChildDeclarationType :: Text -> D.DeclarationInfo -> D.ChildDeclarationInfo -> Maybe D.Type' 271 | extractChildDeclarationType declTitle declInfo cdeclInfo = 272 | case (declInfo, cdeclInfo) of 273 | (D.TypeClassDeclaration args _ _ , D.ChildTypeClassMember ty) -> 274 | let 275 | constraint = 276 | P.Constraint 277 | { P.constraintClass = parentName 278 | , P.constraintArgs = map (P.TypeVar () . fst) args 279 | , P.constraintData = Nothing 280 | , P.constraintAnn = () 281 | , P.constraintKindArgs = [] 282 | } 283 | in 284 | Just (addConstraint constraint ty) 285 | (D.DataDeclaration _ tyArgs _, D.ChildDataConstructor args) -> 286 | let 287 | dataTy = 288 | foldl' 289 | (P.TypeApp ()) 290 | (P.TypeConstructor () parentName) 291 | (map (P.TypeVar () . fst) tyArgs) 292 | in 293 | Just . P.quantify . foldr (P.TypeApp ()) dataTy $ 294 | fmap (P.TypeApp () (P.tyFunction $> ())) args 295 | _ -> 296 | Nothing 297 | 298 | where 299 | parentName :: P.Qualified (P.ProperName a) 300 | parentName = P.Qualified P.ByNullSourcePos (P.ProperName declTitle) 301 | 302 | addConstraint constraint = 303 | P.quantify . P.moveQuantifiersToFront . P.ConstrainedType () constraint 304 | 305 | -- | Return the entire list of entries which match the given query, together 306 | -- with a nonnegative score (lower is better). 307 | searchForName :: Text -> SearchIndex -> [(SearchResult, Int)] 308 | searchForName query = 309 | let 310 | query' = 311 | toLower $ 312 | if isSymbol query 313 | then "(" <> query 314 | else tryStripPrefix "purescript-" query 315 | 316 | convert (key, entries) = 317 | -- note that, because we are using a trie here, all the results are at 318 | -- least as long as the query; we use the difference in length as the 319 | -- score. 320 | map (\entry -> 321 | ( entry 322 | , T.length (decodeUtf8 key) - T.length query' 323 | )) entries 324 | 325 | in 326 | unSearchIndex 327 | >>> Trie.submap (encodeUtf8 query') 328 | >>> Trie.toList 329 | >>> map convert 330 | >>> concat 331 | >>> sortEntries 332 | 333 | -- | Search the index by type. If the query does not parse as a type, or is a 334 | -- "simple type", i.e. just a single type constructor or type variable, return 335 | -- an empty list. Returns a list of (result, score) where the score is 336 | -- nonnegative and lower is better. 337 | -- 338 | -- We exclude simple types because they will be picked up by name-based search. 339 | searchForType :: Text -> SearchIndex -> [(SearchResult, Int)] 340 | searchForType query = 341 | case parseType query of 342 | Just ty | not (isSimpleType ty) -> 343 | searchForType' ty 344 | _ -> 345 | const [] 346 | where 347 | isSimpleType :: D.Type' -> Bool 348 | isSimpleType P.TypeVar{} = True 349 | isSimpleType P.TypeConstructor{} = True 350 | isSimpleType _ = False 351 | 352 | searchForType' :: D.Type' -> SearchIndex -> [(SearchResult, Int)] 353 | searchForType' ty = 354 | unSearchIndex 355 | >>> Trie.elems 356 | >>> concat 357 | >>> mapMaybe (matches ty) 358 | >>> sortEntries 359 | where 360 | matches :: D.Type' -> IndexEntry -> Maybe (IndexEntry, Int) 361 | matches ty1 entry@(IndexEntry { entryType = Just ty2 }) = do 362 | score <- compareTypes ty1 ty2 363 | return (entry, score) 364 | matches _ _ = Nothing 365 | 366 | -- | Given a list of index entries and associated scores, sort them based on 367 | -- the score followed by number of reverse dependencies, and then discard extra 368 | -- unnecessary information, leaving only the SearchResult 369 | sortEntries :: [(IndexEntry, Int)] -> [(SearchResult, Int)] 370 | sortEntries = 371 | sortOn (\(entry, score) -> (score, entryRevDeps entry)) 372 | >>> map (first entryResult) 373 | 374 | tryStripPrefix :: Text -> Text -> Text 375 | tryStripPrefix pre s = fromMaybe s (T.stripPrefix pre s) 376 | 377 | -- | This is an approximation to type subsumption / unification. This function 378 | -- returns Just a score if there is a possible match, or Nothing otherwise. 379 | -- Lower scores are better. 380 | -- 381 | -- The first argument is the query, and the second is the candidate result. 382 | -- This function is not symmetric; for example: 383 | -- 384 | -- let compare s1 s2 = compareTypes <$> parseType s2 <*> parseType s2 385 | -- 386 | -- >>> compare "a" "Int" 387 | -- Just Nothing 388 | -- >>> compare "Int" "a" 389 | -- Just (Just 1) 390 | -- 391 | -- (The idea here being it's ok to show a more general version of the query, 392 | -- but usually not helpful to show a more concrete version of it.) 393 | -- 394 | compareTypes :: D.Type' -> D.Type' -> Maybe Int 395 | compareTypes type1 type2 = 396 | map calculate . runWriterT $ go type1 type2 397 | where 398 | calculate :: (Int, [(Text, Text)]) -> Int 399 | calculate (score, vars) = (10 * score) + typeVarPenalty vars 400 | 401 | go :: D.Type' -> D.Type' -> WriterT [(Text, Text)] Maybe Int 402 | go (P.TypeVar _ v1) (P.TypeVar _ v2) = tell [(v1, v2)] *> pure 0 403 | go t (P.TypeVar _ _) = pure (1 + typeComplexity t) 404 | go (P.TypeLevelString _ s1) (P.TypeLevelString _ s2) | s1 == s2 = pure 0 405 | go (P.TypeWildcard _ _) t = pure (typeComplexity t) 406 | go (P.TypeConstructor _ q1) (P.TypeConstructor _ q2) | compareQual q1 q2 = pure 0 407 | -- There is a special case for functions, since if the user _asked_ for a 408 | -- function, they probably don't want to see something more general of type 'f 409 | -- a' or 'f a b'. 410 | go (P.TypeApp _ a b) (P.TypeApp _ c d) 411 | | not (isFunction a) || isFunction c = (+) <$> go a c <*> go b d 412 | go (P.ForAll _ _ _ _ t1 _) t2 = go t1 t2 413 | go t1 (P.ForAll _ _ _ _ t2 _) = go t1 t2 414 | go (P.ConstrainedType _ _ t1) t2 = go t1 t2 415 | go t1 (P.ConstrainedType _ _ t2) = go t1 t2 416 | go (P.REmpty _) (P.REmpty _) = pure 0 417 | go t1@P.RCons{} t2 = goRows t1 t2 418 | go t1 t2@P.RCons{} = goRows t1 t2 419 | go (P.KindedType _ t1 _) t2 = go t1 t2 420 | go t1 (P.KindedType _ t2 _) = go t1 t2 421 | -- Really, we should desugar any type operators here. 422 | -- Since type operators are not supported in search right now, this is fine, 423 | -- since we only care about functions, which are already in the correct 424 | -- order as they come out of the parser. 425 | go (P.ParensInType _ t1) t2 = go t1 t2 426 | go t1 (P.ParensInType _ t2) = go t1 t2 427 | go _ _ = lift Nothing 428 | 429 | goRows :: D.Type' -> D.Type' -> WriterT [(Text, Text)] Maybe Int 430 | goRows r1 r2 = sum <$> 431 | sequence [ go t1 t2 432 | | P.RowListItem _ name t1 <- fst (P.rowToList r1) 433 | , P.RowListItem _ name' t2 <- fst (P.rowToList r2) 434 | , name == name' 435 | ] 436 | 437 | -- Calculate a penalty based on the extent to which the type variables match. 438 | -- Where differences occur, those which make the result more general than the 439 | -- query are not penalised as harshly as those which make the result less 440 | -- general than the query. 441 | typeVarPenalty :: [(Text, Text)] -> Int 442 | typeVarPenalty list = 443 | penalty list + (3 * penalty (map swap list)) 444 | where 445 | penalty = 446 | map (second Set.singleton) 447 | >>> Map.fromListWith Set.union 448 | >>> Map.elems 449 | -- If one element of the fsts is paired with more than one element of the 450 | -- snds, penalise based on how many more elements of the snds there are. 451 | >>> map (\s -> Set.size s - 1) 452 | >>> sum 453 | 454 | isFunction :: D.Type' -> Bool 455 | isFunction (P.TypeConstructor _ (P.Qualified _ (P.ProperName "Function"))) = True 456 | isFunction _ = False 457 | 458 | 459 | typeComplexity :: D.Type' -> Int 460 | typeComplexity (P.TypeApp _ a b) = 1 + typeComplexity a + typeComplexity b 461 | typeComplexity (P.ForAll _ _ _ _ t _) = 1 + typeComplexity t 462 | typeComplexity (P.ConstrainedType _ _ t) = typeComplexity t + 1 463 | typeComplexity (P.REmpty _) = 0 464 | typeComplexity (P.RCons _ _ t r) = 1 + typeComplexity t + typeComplexity r 465 | typeComplexity (P.KindedType _ t _) = typeComplexity t 466 | typeComplexity (P.ParensInType _ t) = typeComplexity t 467 | typeComplexity _ = 0 468 | 469 | compareQual :: Eq a => P.Qualified a -> P.Qualified a -> Bool 470 | compareQual (P.Qualified (P.ByModuleName mn1) a1) (P.Qualified (P.ByModuleName mn2) a2) = mn1 == mn2 && a1 == a2 471 | compareQual (P.Qualified _ a1) (P.Qualified _ a2) = a1 == a2 472 | 473 | runParser :: CST.Parser a -> Text -> Maybe a 474 | runParser p = 475 | fmap snd 476 | . hush 477 | . CST.runTokenParser (p <* CSTM.token CST.TokEof) 478 | . CST.lexTopLevel 479 | 480 | parseOne :: CST.Parser a -> CST.Parser a 481 | parseOne p = CSTM.token CST.TokLayoutStart *> p <* CSTM.token CST.TokLayoutEnd 482 | 483 | parseType :: Text -> Maybe D.Type' 484 | parseType = fmap (fmap (const ()) . CST.convertType "") . runParser (parseOne CST.parseTypeP) 485 | 486 | isSymbol :: Text -> Bool 487 | isSymbol = 488 | either (const False) id 489 | . fmap (symbol . map CST.tokValue) 490 | . sequence 491 | . CST.lex 492 | where 493 | symbol (CST.TokSymbolName _ _ : _) = True 494 | symbol (CST.TokOperator _ _ : _) = True 495 | symbol _ = False 496 | 497 | isDeprecated :: D.Package a -> Bool 498 | isDeprecated D.Package{..} = 499 | "pursuit-deprecated" `elem` bowerKeywords pkgMeta 500 | -------------------------------------------------------------------------------- /src/Settings.hs: -------------------------------------------------------------------------------- 1 | -- | Settings are centralized, as much as possible, into this file. This 2 | -- includes database connection settings, static file locations, etc. 3 | -- In addition, you can configure a number of different aspects of Yesod 4 | -- by overriding methods in the Yesod typeclass. That instance is 5 | -- declared in the Foundation.hs file. 6 | module Settings where 7 | 8 | import ClassyPrelude.Yesod 9 | import System.Environment (lookupEnv) 10 | import Data.Version 11 | import Language.PureScript.CoreFn.FromJSON (parseVersion') 12 | import Language.Haskell.TH.Syntax (Exp, Name, Q) 13 | import Network.Wai.Handler.Warp (HostPreference) 14 | import Yesod.Default.Util (WidgetFileSettings, widgetFileNoReload, 15 | widgetFileReload) 16 | import System.Exit (exitFailure) 17 | import Yesod.EmbeddedStatic (mkEmbeddedStatic, embedDir) 18 | 19 | import Settings.EmbedPursuitCss (pursuitCssEntry) 20 | 21 | newtype GithubAuthToken = 22 | GithubAuthToken { runGithubAuthToken :: ByteString } 23 | deriving (Show, Eq, Ord) 24 | 25 | -- | Runtime settings to configure this application. These settings can be 26 | -- loaded from various sources: defaults, environment variables, config files, 27 | -- theoretically even a database. 28 | data AppSettings = AppSettings 29 | { appRoot :: Text 30 | -- ^ Base for all generated URLs. 31 | , appHost :: HostPreference 32 | -- ^ Host/interface the server should bind to. 33 | , appPort :: Int 34 | -- ^ Port to listen on 35 | , appIpFromHeader :: Bool 36 | -- ^ Get the IP address from the header when logging. Useful when sitting 37 | -- behind a reverse proxy. 38 | 39 | , appDetailedRequestLogging :: Bool 40 | -- ^ Use detailed request logging system 41 | , appShouldLogAll :: Bool 42 | -- ^ Should all log messages be displayed? 43 | , appReloadTemplates :: Bool 44 | -- ^ Use the reload version of templates 45 | , appMutableStatic :: Bool 46 | -- ^ Assume that files in the static dir may change after compilation 47 | , appSkipCombining :: Bool 48 | -- ^ Perform no stylesheet/script combining 49 | 50 | , appAnalytics :: Maybe Text 51 | -- ^ Google Analytics code 52 | , appGithubAuthToken :: Maybe GithubAuthToken 53 | -- ^ Github OAuth token (for fetching READMEs). 54 | , appDataDir :: String 55 | -- ^ Directory where package data is kept. 56 | , appMinimumCompilerVersion :: Version 57 | -- ^ The minimum version of the compiler that may be used to generate data 58 | -- to be uploaded. 59 | } 60 | 61 | #if DEVELOPMENT 62 | #define DEV_BOOL True 63 | #else 64 | #define DEV_BOOL False 65 | #endif 66 | mkEmbeddedStatic DEV_BOOL "eStatic" [embedDir "static", pure [pursuitCssEntry]] 67 | 68 | isDevelopment :: Bool 69 | isDevelopment = DEV_BOOL 70 | 71 | getAppSettings :: IO AppSettings 72 | getAppSettings = do 73 | let appDetailedRequestLogging = isDevelopment 74 | let appShouldLogAll = isDevelopment 75 | let appReloadTemplates = isDevelopment 76 | let appMutableStatic = isDevelopment 77 | let appSkipCombining = isDevelopment 78 | 79 | appRoot <- env "APPROOT" .!= "http://localhost:3000" 80 | appHost <- fromString <$> env "HOST" .!= "*4" 81 | appPort <- env "PORT" .!= 3000 82 | appIpFromHeader <- env "IP_FROM_HEADER" .!= False 83 | 84 | appAnalytics <- env "GOOGLE_ANALYTICS_CODE" 85 | appDataDir <- env "DATA_DIR" .!= "./data" 86 | 87 | appGithubAuthToken <- map (GithubAuthToken . fromString) <$> env "GITHUB_AUTH_TOKEN" 88 | when (isNothing appGithubAuthToken) $ 89 | let message = "No GitHub auth token configured (environment variable is: PURSUIT_GITHUB_AUTH_TOKEN)" 90 | in if isDevelopment 91 | then do 92 | sayErr ("[Warn] " <> message) 93 | sayErr "[Warn] Requests to the GitHub API will be performed with no authentication." 94 | sayErr "[Warn] This will probably result in rate limiting." 95 | else do 96 | sayErr ("[Error] " <> message) 97 | sayErr "[Error] Refusing to run in production mode." 98 | exitFailure 99 | 100 | appMinimumCompilerVersion <- envP parseVersion' "MINIMUM_COMPILER_VERSION" .!= Version [0,0,0,0] [] 101 | 102 | return AppSettings {..} 103 | 104 | where 105 | envP p = lookupEnvironment p . ("PURSUIT_" ++) 106 | env = envP hackyRead 107 | 108 | -- sorry about this 109 | hackyRead str = readMay str <|> readMay ("\"" ++ str ++ "\"") 110 | 111 | (.!=) :: (Functor f) => f (Maybe a) -> a -> f a 112 | x .!= def' = fromMaybe def' <$> x 113 | 114 | lookupEnvironment :: (String -> Maybe a) -> String -> IO (Maybe a) 115 | lookupEnvironment parse var = do 116 | mstr <- lookupEnv var 117 | case mstr of 118 | Nothing -> return Nothing 119 | Just str -> case parse str of 120 | Just val -> return (Just val) 121 | Nothing -> error $ "Failed to parse environment variable" ++ 122 | " \"" ++ var ++ "\": \"" ++ str ++ "\"" 123 | 124 | getEnvironment :: (String -> Maybe a) -> String -> IO a 125 | getEnvironment parse var = do 126 | r <- lookupEnvironment parse var 127 | case r of 128 | Just r' -> return r' 129 | Nothing -> error $ "Required environment variable \"" ++ var ++ "\" " ++ 130 | "is not set" 131 | 132 | -- | Settings for 'widgetFile', such as which template languages to support and 133 | -- default Hamlet settings. 134 | -- 135 | -- For more information on modifying behavior, see: 136 | -- 137 | -- https://github.com/yesodweb/yesod/wiki/Overriding-widgetFile 138 | widgetFileSettings :: WidgetFileSettings 139 | widgetFileSettings = def 140 | 141 | -- | How static files should be combined. 142 | combineSettings :: CombineSettings 143 | combineSettings = def 144 | 145 | -- The rest of this file contains settings which rarely need changing by a 146 | -- user. 147 | 148 | widgetFile :: String -> Q Exp 149 | widgetFile = (if isDevelopment 150 | then widgetFileReload 151 | else widgetFileNoReload) 152 | widgetFileSettings 153 | 154 | -- The following two functions can be used to combine multiple CSS or JS files 155 | -- at compile time to decrease the number of http requests. 156 | -- Sample usage (inside a Widget): 157 | -- 158 | -- > $(combineStylesheets 'StaticR [style1_css, style2_css]) 159 | 160 | combineStylesheets :: Name -> [Route Static] -> Q Exp 161 | combineStylesheets = combineStylesheets' 162 | isDevelopment 163 | combineSettings 164 | 165 | combineScripts :: Name -> [Route Static] -> Q Exp 166 | combineScripts = combineScripts' 167 | isDevelopment 168 | combineSettings 169 | -------------------------------------------------------------------------------- /src/Settings/EmbedPursuitCss.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- This module exists in order to include the pursuit CSS (which comes from the 3 | -- purescript library) within the embedded static files known to Yesod. 4 | -- 5 | -- Template Haskell stage restrictions necessitate putting this code into a 6 | -- module separate from the Settings module. 7 | -- 8 | module Settings.EmbedPursuitCss (pursuitCssEntry) where 9 | 10 | import ClassyPrelude.Yesod 11 | import Language.Haskell.TH (mkName) 12 | import Language.PureScript.Docs (pursuitCss) 13 | import Yesod.EmbeddedStatic.Types (Entry(..)) 14 | 15 | pursuitCssEntry :: Entry 16 | pursuitCssEntry = 17 | def { ebHaskellName = Just (mkName "css_pursuit_css") 18 | , ebLocation = "css/pursuit.css" 19 | , ebMimeType = "text/css" 20 | , ebProductionContent = pure (fromStrict pursuitCss :: LByteString) 21 | , ebDevelReload = [|pure (fromStrict pursuitCss :: LByteString)|] 22 | } 23 | -------------------------------------------------------------------------------- /src/TemplateHelpers.hs: -------------------------------------------------------------------------------- 1 | module TemplateHelpers where 2 | 3 | import Import hiding (span, link) 4 | import qualified Data.List.Split as List 5 | import qualified Data.Map as Map 6 | import Data.Version (Version) 7 | import Data.List (nub) 8 | import Data.Text (splitOn) 9 | import Text.Blaze.Html5 as H hiding (map, link) 10 | import Text.Blaze.Html5.Attributes as A hiding (span, name, start, for) 11 | import qualified Web.Bower.PackageMeta as Bower 12 | import qualified Language.PureScript as P 13 | import qualified Language.PureScript.Docs as D 14 | import Language.PureScript.Docs.AsHtml 15 | import Handler.Database (lookupPackage) 16 | 17 | import GithubAPI (ReadmeMissing(..)) 18 | import qualified GithubAPI 19 | import qualified Data.Time.Format.ISO8601 as ISO8601 20 | 21 | linkToGithubUser :: D.GithubUser -> Html 22 | linkToGithubUser user = 23 | a ! href (toValue ("https://github.com/" <> D.runGithubUser user)) $ do 24 | toHtml (D.runGithubUser user) 25 | 26 | linkToGithub :: (D.GithubUser, D.GithubRepo) -> Html 27 | linkToGithub (user, repo) = 28 | let linkContent = D.runGithubUser user <> "/" <> D.runGithubRepo repo 29 | in linkToGithub' linkContent (user, repo) 30 | 31 | linkToGithub' :: Text -> (D.GithubUser, D.GithubRepo) -> Html 32 | linkToGithub' linkContent (user, repo) = 33 | let path = D.runGithubUser user <> "/" <> D.runGithubRepo repo 34 | in a ! href (toValue ("https://github.com/" <> path)) $ do 35 | toHtml linkContent 36 | 37 | joinLicenses :: [Text] -> Maybe Html 38 | joinLicenses ls 39 | | null ls = Nothing 40 | | otherwise = Just (toHtml (intercalate "/" ls)) 41 | 42 | renderVersionRange :: Bower.VersionRange -> Html 43 | renderVersionRange = toHtml . Bower.runVersionRange 44 | 45 | linkToModule :: D.VerifiedPackage -> D.InPackage P.ModuleName -> Handler Html 46 | linkToModule pkg mn' = do 47 | let mtargetPkg = findTargetPackage pkg mn' 48 | let mn = D.ignorePackage mn' 49 | let linkText = insertBreaks mn 50 | case mtargetPkg of 51 | Just (pkgName, pkgVersion) -> 52 | let route = PackageVersionModuleDocsR 53 | (PathPackageName pkgName) 54 | (PathVersion pkgVersion) 55 | (P.runModuleName mn) 56 | in 57 | withUrlRenderer [hamlet|#{linkText}|] 58 | Nothing -> 59 | withUrlRenderer [hamlet|#{linkText}|] 60 | 61 | -- | Given a package name and a verified package, attempt to find details of 62 | -- package which defines that module. This may be the package given in the 63 | -- argument or one of its dependencies. 64 | findTargetPackage :: D.VerifiedPackage -> D.InPackage P.ModuleName -> Maybe (Bower.PackageName, Version) 65 | findTargetPackage pkg mn' = 66 | case mn' of 67 | D.Local _ -> 68 | Just (D.packageName pkg, D.pkgVersion pkg) 69 | D.FromDep pkgName _ -> 70 | (pkgName,) <$> lookup pkgName (D.pkgResolvedDependencies pkg) 71 | 72 | renderModuleList :: D.VerifiedPackage -> Handler Html 73 | renderModuleList pkg = do 74 | htmlRenderContext <- getHtmlRenderContext 75 | let docsOutput = packageAsHtml (Just . htmlRenderContext pkg . D.ignorePackage) pkg 76 | moduleNames = sort . map fst $ htmlModules docsOutput 77 | moduleLinks <- traverse (linkToModule pkg . D.Local) moduleNames 78 | 79 | moduleListFromLinks moduleLinks 80 | 81 | builtinModuleList :: Handler Html 82 | builtinModuleList = 83 | traverse builtinModuleLink D.primModules >>= moduleListFromLinks 84 | where 85 | builtinModuleLink m = 86 | let 87 | mn = D.modName m 88 | route = BuiltinDocsR (P.runModuleName mn) 89 | linkText = insertBreaks mn 90 | in 91 | withUrlRenderer [hamlet|#{linkText}|] 92 | 93 | moduleListFromLinks :: [Html] -> Handler Html 94 | moduleListFromLinks moduleLinks = 95 | withUrlRenderer [hamlet| 96 |
97 |
Modules 98 | $forall link <- moduleLinks 99 |
#{link} 100 | |] 101 | 102 | -- | Insert elements in between elements of a module name, in order to 103 | -- prevent awkward line breaks or overflowing (and generating horizontal 104 | -- scrollbars). 105 | insertBreaks :: P.ModuleName -> Html 106 | insertBreaks = 107 | P.runModuleName 108 | >>> splitOn "." 109 | >>> map toHtml 110 | >>> intercalate (toHtml ("." :: Text) *> wbr) 111 | 112 | tryGetReadme :: D.VerifiedPackage -> Handler (Either (ReadmeMissing, D.VerifiedPackage) Html) 113 | tryGetReadme pkg@D.Package{..} = do 114 | mtoken <- appGithubAuthToken . appSettings <$> getYesod 115 | let (ghUser, ghRepo) = pkgGithub 116 | let ghTag = pkgVersionTag 117 | res <- GithubAPI.getReadme mtoken ghUser ghRepo ghTag 118 | case res of 119 | Left (OtherReason r) -> do 120 | $logError (tshow r) 121 | _ -> 122 | return () 123 | return $ first (, pkg) res 124 | 125 | renderReadme :: Either (ReadmeMissing, D.VerifiedPackage) Html -> Html 126 | renderReadme = \case 127 | Right html' -> 128 | html' 129 | Left (APIRateLimited, D.Package{..}) -> 130 | let githubLink = linkToGithub' "Github" pkgGithub 131 | in [shamlet| 132 |
133 | No readme available (due to rate limiting). Please try again later 134 | or view this package's readme on ^{githubLink}. 135 | |] 136 | Left (ReadmeNotFound, _) -> 137 | [shamlet| 138 |
139 | No readme found in the repository at this tag. If you are the maintainer, 140 | perhaps consider adding one in the next release. 141 | |] 142 | Left (OtherReason _, _) -> 143 | [shamlet| 144 |
145 | No readme available, for some unexpected reason (which has been logged). 146 | Perhaps 147 | 148 | open an issue? 149 | |] 150 | 151 | 152 | renderHtmlDocs :: D.VerifiedPackage -> Text -> Handler (Maybe Html) 153 | renderHtmlDocs pkg mnString = do 154 | htmlRenderContext <- getHtmlRenderContext 155 | depHtmlRenderContext <- getDepHtmlRenderContexts pkg 156 | let docsOutput = flip packageAsHtml pkg $ \case 157 | D.Local mn -> Just $ htmlRenderContext pkg mn 158 | D.FromDep pkgName mn -> depHtmlRenderContext pkgName mn 159 | traverse render $ 160 | lookup (P.moduleNameFromString mnString) 161 | (htmlModules docsOutput) 162 | 163 | where 164 | render :: HtmlOutputModule Html -> Handler Html 165 | render HtmlOutputModule{..} = do 166 | reexports <- traverse renderReExports htmlOutputModuleReExports 167 | return (htmlOutputModuleLocals *> mconcat reexports) 168 | 169 | renderReExports :: (D.InPackage P.ModuleName, Html) -> Handler Html 170 | renderReExports (mn, decls) = do 171 | moduleLink <- linkToModule pkg mn 172 | pure $ do 173 | h2 ! class_ "re-exports" $ do 174 | text "Re-exports from " 175 | strong moduleLink 176 | decls 177 | 178 | primDocsFor :: P.ModuleName -> Maybe Html 179 | primDocsFor mn = 180 | fmap intoHtml $ find ((== mn) . D.modName) D.primModules 181 | where 182 | intoHtml m = 183 | htmlOutputModuleLocals $ 184 | snd $ 185 | moduleAsHtml 186 | (const (Just nullRenderContext)) 187 | m 188 | 189 | -- | Produce a Route for a given DocLink. 190 | docLinkRoute :: D.LinksContext -> D.DocLink -> Route App 191 | docLinkRoute D.LinksContext{..} link = case D.linkLocation link of 192 | D.LocalModule modName -> 193 | mkRoute ctxPackageName ctxVersion modName 194 | D.DepsModule pkgName version modName -> 195 | mkRoute pkgName version modName 196 | D.BuiltinModule modName -> 197 | BuiltinDocsR (P.runModuleName modName) 198 | where 199 | mkRoute pkgName version modName = 200 | PackageVersionModuleDocsR 201 | (PathPackageName pkgName) 202 | (PathVersion version) 203 | (P.runModuleName modName) 204 | 205 | getDepHtmlRenderContexts 206 | :: D.Package a 207 | -> Handler (Bower.PackageName -> P.ModuleName -> Maybe HtmlRenderContext) 208 | getDepHtmlRenderContexts D.Package {..} = do 209 | htmlRenderContext <- getHtmlRenderContext 210 | let reExportedPackages = 211 | nub $ concat [ 212 | catMaybes [ 213 | case inPkg of 214 | D.Local _ -> Nothing 215 | D.FromDep pN _ -> find ((== pN) . fst) pkgResolvedDependencies 216 | | (inPkg, _) <- modReExports 217 | ] 218 | | D.Module {..} <- pkgModules ] 219 | 220 | m <- Map.fromList . catMaybes <$> do 221 | for reExportedPackages $ \(pkgName, version) -> do 222 | fmap (pkgName, ) . hush . fmap htmlRenderContext <$> do 223 | lookupPackage pkgName version 224 | 225 | return $ \pkgName mN -> fmap ($ mN) $ Map.lookup pkgName m 226 | 227 | getHtmlRenderContext :: Handler (D.Package a -> P.ModuleName -> HtmlRenderContext) 228 | getHtmlRenderContext = do 229 | renderUrl <- getUrlRender 230 | return $ \pkg currentMn -> 231 | let 232 | linksContext = D.getLinksContext pkg 233 | in 234 | HtmlRenderContext 235 | { buildDocLink = D.getLink linksContext currentMn 236 | , renderDocLink = renderUrl . docLinkRoute linksContext 237 | , renderSourceLink = Just . renderSourceLink' linksContext 238 | } 239 | 240 | renderSourceLink' :: D.LinksContext -> P.SourceSpan -> Text 241 | renderSourceLink' D.LinksContext{..} (P.SourceSpan name start end) = 242 | concat 243 | [ githubBaseUrl 244 | , "/blob/" 245 | , ctxVersionTag 246 | , "/" 247 | , pack (relativeToBase (unpack name)) 248 | , "#", fragment 249 | ] 250 | where 251 | (P.SourcePos startLine _) = start 252 | (P.SourcePos endLine _) = end 253 | (D.GithubUser user, D.GithubRepo repo) = ctxGithub 254 | 255 | relativeToBase = intercalate "/" . dropWhile (/= "src") . splitOnPathSep 256 | githubBaseUrl = concat ["https://github.com/", user, "/", repo] 257 | fragment = "L" <> tshow startLine <> "-L" <> tshow endLine 258 | 259 | -- | Split a string on either unix-style "/" or Windows-style "\\" path 260 | -- | separators. 261 | splitOnPathSep :: String -> [String] 262 | splitOnPathSep str 263 | | '/' `elem` str = List.splitOn "/" str 264 | | '\\' `elem` str = List.splitOn "\\" str 265 | | otherwise = [str] 266 | 267 | -- | Render a URL together with a fragment (possibly). 268 | getFragmentRender :: Handler ((Route App, Maybe Text) -> Text) 269 | getFragmentRender = do 270 | render <- getUrlRender 271 | return $ \(route, fragment) -> render route ++ maybe "" ("#" ++) fragment 272 | 273 | formatDate :: UTCTime -> String 274 | formatDate = ISO8601.iso8601Show 275 | -------------------------------------------------------------------------------- /src/TimeUtils.hs: -------------------------------------------------------------------------------- 1 | 2 | module TimeUtils 3 | ( module Data.Time.Clock 4 | , module TimeUtils 5 | ) where 6 | 7 | import Prelude 8 | import Data.Time.Clock 9 | 10 | oneDay :: NominalDiffTime 11 | oneDay = oneHour * 24 12 | 13 | oneHour :: NominalDiffTime 14 | oneHour = 60 * 60 15 | 16 | subUTCTime :: UTCTime -> NominalDiffTime -> UTCTime 17 | subUTCTime x y = addUTCTime (negate y) x 18 | 19 | getElapsedTimeSince :: UTCTime -> IO NominalDiffTime 20 | getElapsedTimeSince time = fmap (flip diffUTCTime time) getCurrentTime 21 | -------------------------------------------------------------------------------- /src/XMLArrows.hs: -------------------------------------------------------------------------------- 1 | module XMLArrows where 2 | 3 | import Import 4 | import Text.XML.HXT.Core as HXT 5 | import Text.Blaze.Html (preEscapedToHtml) 6 | import Text.Blaze.Renderer.String as BlazeS 7 | 8 | run :: LA XmlTree XmlTree -> Html -> Html 9 | run a = preEscapedToHtml . runString a . BlazeS.renderMarkup 10 | 11 | runString :: LA XmlTree XmlTree -> String -> String 12 | runString a = 13 | unsafeHead . runLA (hread >>> a >>> writeDocumentToString []) 14 | 15 | -- | Remove all h1 elements. 16 | stripH1 :: LA XmlTree XmlTree 17 | stripH1 = 18 | processTopDown (neg (hasName "h1") `guards` this) 19 | 20 | -- | Make all relative links into absolute links by providing a base URL. 21 | makeRelativeLinksAbsolute :: 22 | String -- ^ Tag name to modify 23 | -> String -- ^ Attribute name to modify 24 | -> String -- ^ Base URL to use for relative links 25 | -> LA XmlTree XmlTree 26 | makeRelativeLinksAbsolute tagName attrName base = 27 | processTopDown $ 28 | processAttrl (changeAttrValue (mkAbs base) `HXT.when` hasName attrName) 29 | `HXT.when` (isElem >>> hasName tagName) 30 | 31 | where 32 | mkAbs base' url = fromMaybe url $ expandURIString url $ base' 33 | 34 | -- | Replace all elements with . We use this for rendering 35 | -- documentation in search results, since each result is already wrapped in an 36 | -- element and browsers do not deal well with nested elements (in fact, 37 | -- they are invalid according to HTML5). 38 | replaceLinks :: LA XmlTree XmlTree 39 | replaceLinks = 40 | processTopDown $ 41 | setElemName (mkName "span") `HXT.when` (isElem >>> hasName "a") 42 | 43 | -- | Replace all elements with relative URLs for href attributes with 44 | -- elements. 45 | replaceRelativeLinks :: LA XmlTree XmlTree 46 | replaceRelativeLinks = 47 | processTopDown $ 48 | setElemName (mkName "span") `HXT.when` isRelative 49 | 50 | where 51 | isRelative :: LA XmlTree XmlTree 52 | isRelative = 53 | isElem 54 | >>> hasName "a" 55 | >>> filterA (getAttrValue "href" >>> isA isRelativeURI) 56 | 57 | -- | 58 | -- See Section 4.2 of RFC 3986: 59 | -- https://tools.ietf.org/html/rfc3986#section-4.2 60 | -- 61 | -- >>> isRelativeURI "http://example.com/" == False 62 | -- >>> isRelativeURI "mailto:me@example.com" == False 63 | -- >>> isRelativeURI "foo/bar" == True 64 | -- >>> isRelativeURI "/bar" == True 65 | -- >>> isRelativeURI "./bar" == True 66 | -- 67 | isRelativeURI :: String -> Bool 68 | isRelativeURI = 69 | takeWhile (/= '/') 70 | >>> (\segment -> ':' `notElem` segment) 71 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-20.9 2 | # Resolves hjsmin requiring language-javascript ==0.6, while the purescript 3 | # compiler requires language-javascript ==0.7. 4 | allow-newer: true 5 | 6 | packages: 7 | - "." 8 | 9 | extra-deps: 10 | - git: https://github.com/PureFunctor/barrier.git 11 | commit: db5e27c8ff8f98b2ea18036ce20f853a92aec595 12 | - bytestring-trie-0.2.7@sha256:f78e9d1dba699ce56080824693787918e9e8904db99d04d3470941420b1dd3ed,9010 13 | - classy-prelude-yesod-1.5.0 14 | - language-javascript-0.7.0.0 15 | - purescript-0.15.10 16 | - monoidal-containers-0.6.2.0 17 | - protolude-0.3.1 18 | - process-1.6.13.1 19 | - Cabal-3.6.3.0 20 | 21 | flags: 22 | pursuit: 23 | dev: true 24 | aeson-pretty: 25 | lib-only: true 26 | these: 27 | assoc: false 28 | -------------------------------------------------------------------------------- /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 | commit: db5e27c8ff8f98b2ea18036ce20f853a92aec595 9 | git: https://github.com/PureFunctor/barrier.git 10 | name: barrier 11 | pantry-tree: 12 | sha256: b7d15fa12674068618745c2cbdaa6d0fa256206d0904d4e8964606ee7fd57676 13 | size: 1892 14 | version: 0.1.1 15 | original: 16 | commit: db5e27c8ff8f98b2ea18036ce20f853a92aec595 17 | git: https://github.com/PureFunctor/barrier.git 18 | - completed: 19 | hackage: bytestring-trie-0.2.7@sha256:f78e9d1dba699ce56080824693787918e9e8904db99d04d3470941420b1dd3ed,9010 20 | pantry-tree: 21 | sha256: b1f438713b95d8e1e95af11c5d747d1fa9b647c2f55be817ff91e4bd4d69ca00 22 | size: 1221 23 | original: 24 | hackage: bytestring-trie-0.2.7@sha256:f78e9d1dba699ce56080824693787918e9e8904db99d04d3470941420b1dd3ed,9010 25 | - completed: 26 | hackage: classy-prelude-yesod-1.5.0@sha256:8f7e183bdfd6d2ea9674284c4f285294ab086aff60d9be4e5d7d2f3c1a2b05b7,1330 27 | pantry-tree: 28 | sha256: ae84d4cc0e1daf985db6cdcf2ac92319531b8e60f547183cc46480d00aafbe20 29 | size: 330 30 | original: 31 | hackage: classy-prelude-yesod-1.5.0 32 | - completed: 33 | hackage: language-javascript-0.7.0.0@sha256:3eab0262b8ac5621936a4beab6a0f97d0e00a63455a8b0e3ac1547b4088dae7d,3898 34 | pantry-tree: 35 | sha256: b0f28d836cb3fbde203fd7318a896c3a20acd8653a905e1950ae2d9a64bccebf 36 | size: 2244 37 | original: 38 | hackage: language-javascript-0.7.0.0 39 | - completed: 40 | hackage: purescript-0.15.10@sha256:6c618dcf9d3bbea21b01df1203be16dd9fb0f2fa2ab8f5d2e70a409e3f082bdf,21378 41 | pantry-tree: 42 | sha256: c1d3679420eddf6702b1c0c2f60be4bd79c11e5d1f18f9e0d8d3dc537816740c 43 | size: 157366 44 | original: 45 | hackage: purescript-0.15.10 46 | - completed: 47 | hackage: monoidal-containers-0.6.2.0@sha256:97289baf716f22fdae04b4fcbee066453d2f4c630ef3f631aeeab61ee713841e,2309 48 | pantry-tree: 49 | sha256: 55c0b7f60f8350546d437c9c0ad52c1dba35cac727972e7dc0f12201870df62f 50 | size: 569 51 | original: 52 | hackage: monoidal-containers-0.6.2.0 53 | - completed: 54 | hackage: protolude-0.3.1@sha256:1cc9e5a5c26c33a43c52b554443dd9779fef13974eaa0beec7ca6d2551b400da,2647 55 | pantry-tree: 56 | sha256: 6452a6ca8d395f7d810139779bb0fd16fc1dbb00f1862630bc08ef5a100430f9 57 | size: 1645 58 | original: 59 | hackage: protolude-0.3.1 60 | - completed: 61 | hackage: process-1.6.13.1@sha256:c8bb8b7c993ff72d771381b3b56852dd154bce51880a24789c11f57b0688d353,2963 62 | pantry-tree: 63 | sha256: 58117b15fa330c79b3bca6b29c65f815e45840f79cc0915d3434f25e54ac8fa5 64 | size: 1543 65 | original: 66 | hackage: process-1.6.13.1 67 | - completed: 68 | hackage: Cabal-3.6.3.0@sha256:ff97c442b0c679c1c9876acd15f73ac4f602b973c45bde42b43ec28265ee48f4,12459 69 | pantry-tree: 70 | sha256: b250a53bdb56844f047a2927833bb565b936a289abfa85dfc2a63148d776368a 71 | size: 19757 72 | original: 73 | hackage: Cabal-3.6.3.0 74 | snapshots: 75 | - completed: 76 | sha256: c11fcbeb1aa12761044755b1109d16952ede2cb6147ebde777dd5cb38f784501 77 | size: 649333 78 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/9.yaml 79 | original: lts-20.9 80 | -------------------------------------------------------------------------------- /static/css/extra.css: -------------------------------------------------------------------------------- 1 | /* Additional Pursuit CSS 2 | * Note that most of the Pursuit-related CSS lives in the compiler, so that it 3 | * can be used for `purs docs`. 4 | */ 5 | 6 | /* This is mainly for the help pages */ 7 | .col--main > h2:first-child { 8 | margin-top: 0; 9 | } 10 | 11 | .badge--deprecated { 12 | color: #fff; 13 | background-color: #c4953a; 14 | padding: 0.1em 0.4em 0.1em 0.4em; 15 | border-radius: 0.3em; 16 | font-size: 77%; 17 | font-weight: bold; 18 | position: relative; 19 | top: -0.1em; 20 | margin-left: 0.4em; 21 | } 22 | -------------------------------------------------------------------------------- /static/css/normalize.css: -------------------------------------------------------------------------------- 1 | /*! normalize.css v3.0.2 | MIT License | git.io/normalize */ 2 | 3 | /** 4 | * 1. Set default font family to sans-serif. 5 | * 2. Prevent iOS text size adjust after orientation change, without disabling 6 | * user zoom. 7 | */ 8 | 9 | html { 10 | font-family: sans-serif; /* 1 */ 11 | -ms-text-size-adjust: 100%; /* 2 */ 12 | -webkit-text-size-adjust: 100%; /* 2 */ 13 | } 14 | 15 | /** 16 | * Remove default margin. 17 | */ 18 | 19 | body { 20 | margin: 0; 21 | } 22 | 23 | /* HTML5 display definitions 24 | ========================================================================== */ 25 | 26 | /** 27 | * Correct `block` display not defined for any HTML5 element in IE 8/9. 28 | * Correct `block` display not defined for `details` or `summary` in IE 10/11 29 | * and Firefox. 30 | * Correct `block` display not defined for `main` in IE 11. 31 | */ 32 | 33 | article, 34 | aside, 35 | details, 36 | figcaption, 37 | figure, 38 | footer, 39 | header, 40 | hgroup, 41 | main, 42 | menu, 43 | nav, 44 | section, 45 | summary { 46 | display: block; 47 | } 48 | 49 | /** 50 | * 1. Correct `inline-block` display not defined in IE 8/9. 51 | * 2. Normalize vertical alignment of `progress` in Chrome, Firefox, and Opera. 52 | */ 53 | 54 | audio, 55 | canvas, 56 | progress, 57 | video { 58 | display: inline-block; /* 1 */ 59 | vertical-align: baseline; /* 2 */ 60 | } 61 | 62 | /** 63 | * Prevent modern browsers from displaying `audio` without controls. 64 | * Remove excess height in iOS 5 devices. 65 | */ 66 | 67 | audio:not([controls]) { 68 | display: none; 69 | height: 0; 70 | } 71 | 72 | /** 73 | * Address `[hidden]` styling not present in IE 8/9/10. 74 | * Hide the `template` element in IE 8/9/11, Safari, and Firefox < 22. 75 | */ 76 | 77 | [hidden], 78 | template { 79 | display: none; 80 | } 81 | 82 | /* Links 83 | ========================================================================== */ 84 | 85 | /** 86 | * Remove the gray background color from active links in IE 10. 87 | */ 88 | 89 | a { 90 | background-color: transparent; 91 | } 92 | 93 | /** 94 | * Improve readability when focused and also mouse hovered in all browsers. 95 | */ 96 | 97 | a:active, 98 | a:hover { 99 | outline: 0; 100 | } 101 | 102 | /* Text-level semantics 103 | ========================================================================== */ 104 | 105 | /** 106 | * Address styling not present in IE 8/9/10/11, Safari, and Chrome. 107 | */ 108 | 109 | abbr[title] { 110 | border-bottom: 1px dotted; 111 | } 112 | 113 | /** 114 | * Address style set to `bolder` in Firefox 4+, Safari, and Chrome. 115 | */ 116 | 117 | b, 118 | strong { 119 | font-weight: bold; 120 | } 121 | 122 | /** 123 | * Address styling not present in Safari and Chrome. 124 | */ 125 | 126 | dfn { 127 | font-style: italic; 128 | } 129 | 130 | /** 131 | * Address variable `h1` font-size and margin within `section` and `article` 132 | * contexts in Firefox 4+, Safari, and Chrome. 133 | */ 134 | 135 | h1 { 136 | font-size: 2em; 137 | margin: 0.67em 0; 138 | } 139 | 140 | /** 141 | * Address styling not present in IE 8/9. 142 | */ 143 | 144 | mark { 145 | background: #ff0; 146 | color: #000; 147 | } 148 | 149 | /** 150 | * Address inconsistent and variable font size in all browsers. 151 | */ 152 | 153 | small { 154 | font-size: 80%; 155 | } 156 | 157 | /** 158 | * Prevent `sub` and `sup` affecting `line-height` in all browsers. 159 | */ 160 | 161 | sub, 162 | sup { 163 | font-size: 75%; 164 | line-height: 0; 165 | position: relative; 166 | vertical-align: baseline; 167 | } 168 | 169 | sup { 170 | top: -0.5em; 171 | } 172 | 173 | sub { 174 | bottom: -0.25em; 175 | } 176 | 177 | /* Embedded content 178 | ========================================================================== */ 179 | 180 | /** 181 | * Remove border when inside `a` element in IE 8/9/10. 182 | */ 183 | 184 | img { 185 | border: 0; 186 | } 187 | 188 | /** 189 | * Correct overflow not hidden in IE 9/10/11. 190 | */ 191 | 192 | svg:not(:root) { 193 | overflow: hidden; 194 | } 195 | 196 | /* Grouping content 197 | ========================================================================== */ 198 | 199 | /** 200 | * Address margin not present in IE 8/9 and Safari. 201 | */ 202 | 203 | figure { 204 | margin: 1em 40px; 205 | } 206 | 207 | /** 208 | * Address differences between Firefox and other browsers. 209 | */ 210 | 211 | hr { 212 | -moz-box-sizing: content-box; 213 | box-sizing: content-box; 214 | height: 0; 215 | } 216 | 217 | /** 218 | * Contain overflow in all browsers. 219 | */ 220 | 221 | pre { 222 | overflow: auto; 223 | } 224 | 225 | /** 226 | * Address odd `em`-unit font size rendering in all browsers. 227 | */ 228 | 229 | code, 230 | kbd, 231 | pre, 232 | samp { 233 | font-family: monospace, monospace; 234 | font-size: 1em; 235 | } 236 | 237 | /* Forms 238 | ========================================================================== */ 239 | 240 | /** 241 | * Known limitation: by default, Chrome and Safari on OS X allow very limited 242 | * styling of `select`, unless a `border` property is set. 243 | */ 244 | 245 | /** 246 | * 1. Correct color not being inherited. 247 | * Known issue: affects color of disabled elements. 248 | * 2. Correct font properties not being inherited. 249 | * 3. Address margins set differently in Firefox 4+, Safari, and Chrome. 250 | */ 251 | 252 | button, 253 | input, 254 | optgroup, 255 | select, 256 | textarea { 257 | color: inherit; /* 1 */ 258 | font: inherit; /* 2 */ 259 | margin: 0; /* 3 */ 260 | } 261 | 262 | /** 263 | * Address `overflow` set to `hidden` in IE 8/9/10/11. 264 | */ 265 | 266 | button { 267 | overflow: visible; 268 | } 269 | 270 | /** 271 | * Address inconsistent `text-transform` inheritance for `button` and `select`. 272 | * All other form control elements do not inherit `text-transform` values. 273 | * Correct `button` style inheritance in Firefox, IE 8/9/10/11, and Opera. 274 | * Correct `select` style inheritance in Firefox. 275 | */ 276 | 277 | button, 278 | select { 279 | text-transform: none; 280 | } 281 | 282 | /** 283 | * 1. Avoid the WebKit bug in Android 4.0.* where (2) destroys native `audio` 284 | * and `video` controls. 285 | * 2. Correct inability to style clickable `input` types in iOS. 286 | * 3. Improve usability and consistency of cursor style between image-type 287 | * `input` and others. 288 | */ 289 | 290 | button, 291 | html input[type="button"], /* 1 */ 292 | input[type="reset"], 293 | input[type="submit"] { 294 | -webkit-appearance: button; /* 2 */ 295 | cursor: pointer; /* 3 */ 296 | } 297 | 298 | /** 299 | * Re-set default cursor for disabled elements. 300 | */ 301 | 302 | button[disabled], 303 | html input[disabled] { 304 | cursor: default; 305 | } 306 | 307 | /** 308 | * Remove inner padding and border in Firefox 4+. 309 | */ 310 | 311 | button::-moz-focus-inner, 312 | input::-moz-focus-inner { 313 | border: 0; 314 | padding: 0; 315 | } 316 | 317 | /** 318 | * Address Firefox 4+ setting `line-height` on `input` using `!important` in 319 | * the UA stylesheet. 320 | */ 321 | 322 | input { 323 | line-height: normal; 324 | } 325 | 326 | /** 327 | * It's recommended that you don't attempt to style these elements. 328 | * Firefox's implementation doesn't respect box-sizing, padding, or width. 329 | * 330 | * 1. Address box sizing set to `content-box` in IE 8/9/10. 331 | * 2. Remove excess padding in IE 8/9/10. 332 | */ 333 | 334 | input[type="checkbox"], 335 | input[type="radio"] { 336 | box-sizing: border-box; /* 1 */ 337 | padding: 0; /* 2 */ 338 | } 339 | 340 | /** 341 | * Fix the cursor style for Chrome's increment/decrement buttons. For certain 342 | * `font-size` values of the `input`, it causes the cursor style of the 343 | * decrement button to change from `default` to `text`. 344 | */ 345 | 346 | input[type="number"]::-webkit-inner-spin-button, 347 | input[type="number"]::-webkit-outer-spin-button { 348 | height: auto; 349 | } 350 | 351 | /** 352 | * 1. Address `appearance` set to `searchfield` in Safari and Chrome. 353 | * 2. Address `box-sizing` set to `border-box` in Safari and Chrome 354 | * (include `-moz` to future-proof). 355 | */ 356 | 357 | input[type="search"] { 358 | -webkit-appearance: textfield; /* 1 */ 359 | -moz-box-sizing: content-box; 360 | -webkit-box-sizing: content-box; /* 2 */ 361 | box-sizing: content-box; 362 | } 363 | 364 | /** 365 | * Remove inner padding and search cancel button in Safari and Chrome on OS X. 366 | * Safari (but not Chrome) clips the cancel button when the search input has 367 | * padding (and `textfield` appearance). 368 | */ 369 | 370 | input[type="search"]::-webkit-search-cancel-button, 371 | input[type="search"]::-webkit-search-decoration { 372 | -webkit-appearance: none; 373 | } 374 | 375 | /** 376 | * Define consistent border, margin, and padding. 377 | */ 378 | 379 | fieldset { 380 | border: 1px solid #c0c0c0; 381 | margin: 0 2px; 382 | padding: 0.35em 0.625em 0.75em; 383 | } 384 | 385 | /** 386 | * 1. Correct `color` not being inherited in IE 8/9/10/11. 387 | * 2. Remove padding so people aren't caught out if they zero out fieldsets. 388 | */ 389 | 390 | legend { 391 | border: 0; /* 1 */ 392 | padding: 0; /* 2 */ 393 | } 394 | 395 | /** 396 | * Remove default vertical scrollbar in IE 8/9/10/11. 397 | */ 398 | 399 | textarea { 400 | overflow: auto; 401 | } 402 | 403 | /** 404 | * Don't inherit the `font-weight` (applied by a rule above). 405 | * NOTE: the default cannot safely be changed in Chrome and Safari on OS X. 406 | */ 407 | 408 | optgroup { 409 | font-weight: bold; 410 | } 411 | 412 | /* Tables 413 | ========================================================================== */ 414 | 415 | /** 416 | * Remove most spacing between table cells. 417 | */ 418 | 419 | table { 420 | border-collapse: collapse; 421 | border-spacing: 0; 422 | } 423 | 424 | td, 425 | th { 426 | padding: 0; 427 | } 428 | -------------------------------------------------------------------------------- /static/favicon/android-chrome-192x192.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/purescript/pursuit/fca936dcd8e573237eabe408d2bcf225931a3be8/static/favicon/android-chrome-192x192.png -------------------------------------------------------------------------------- /static/favicon/android-chrome-512x512.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/purescript/pursuit/fca936dcd8e573237eabe408d2bcf225931a3be8/static/favicon/android-chrome-512x512.png -------------------------------------------------------------------------------- /static/favicon/apple-touch-icon.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/purescript/pursuit/fca936dcd8e573237eabe408d2bcf225931a3be8/static/favicon/apple-touch-icon.png -------------------------------------------------------------------------------- /static/favicon/browserconfig.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | #000000 10 | 11 | 12 | 13 | 14 | -------------------------------------------------------------------------------- /static/favicon/favicon-16x16.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/purescript/pursuit/fca936dcd8e573237eabe408d2bcf225931a3be8/static/favicon/favicon-16x16.png -------------------------------------------------------------------------------- /static/favicon/favicon-32x32.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/purescript/pursuit/fca936dcd8e573237eabe408d2bcf225931a3be8/static/favicon/favicon-32x32.png -------------------------------------------------------------------------------- /static/favicon/favicon-48x48.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/purescript/pursuit/fca936dcd8e573237eabe408d2bcf225931a3be8/static/favicon/favicon-48x48.png -------------------------------------------------------------------------------- /static/favicon/favicon.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/purescript/pursuit/fca936dcd8e573237eabe408d2bcf225931a3be8/static/favicon/favicon.ico -------------------------------------------------------------------------------- /static/favicon/manifest.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "Pursuit", 3 | "icons": [ 4 | { 5 | "src": "/static/res/favicon/android-chrome-192x192.png", 6 | "sizes": "192x192", 7 | "type": "image/png" 8 | }, 9 | { 10 | "src": "/static/res/favicon/android-chrome-512x512.png", 11 | "sizes": "512x512", 12 | "type": "image/png" 13 | } 14 | ], 15 | "theme_color": "#000000", 16 | "display": "standalone" 17 | } 18 | -------------------------------------------------------------------------------- /static/favicon/mstile-150x150.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/purescript/pursuit/fca936dcd8e573237eabe408d2bcf225931a3be8/static/favicon/mstile-150x150.png -------------------------------------------------------------------------------- /static/favicon/mstile-310x150.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/purescript/pursuit/fca936dcd8e573237eabe408d2bcf225931a3be8/static/favicon/mstile-310x150.png -------------------------------------------------------------------------------- /static/favicon/mstile-310x310.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/purescript/pursuit/fca936dcd8e573237eabe408d2bcf225931a3be8/static/favicon/mstile-310x310.png -------------------------------------------------------------------------------- /static/favicon/mstile-70x70.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/purescript/pursuit/fca936dcd8e573237eabe408d2bcf225931a3be8/static/favicon/mstile-70x70.png -------------------------------------------------------------------------------- /static/favicon/safari-pinned-tab.svg: -------------------------------------------------------------------------------- 1 | 2 | 4 | 7 | 8 | Created by potrace 1.11, written by Peter Selinger 2001-2013 9 | 10 | 12 | 15 | 18 | 21 | 24 | 27 | 28 | 29 | -------------------------------------------------------------------------------- /static/fonts/glyphicons-halflings-regular.eot: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/purescript/pursuit/fca936dcd8e573237eabe408d2bcf225931a3be8/static/fonts/glyphicons-halflings-regular.eot -------------------------------------------------------------------------------- /static/fonts/glyphicons-halflings-regular.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/purescript/pursuit/fca936dcd8e573237eabe408d2bcf225931a3be8/static/fonts/glyphicons-halflings-regular.ttf -------------------------------------------------------------------------------- /static/fonts/glyphicons-halflings-regular.woff: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/purescript/pursuit/fca936dcd8e573237eabe408d2bcf225931a3be8/static/fonts/glyphicons-halflings-regular.woff -------------------------------------------------------------------------------- /static/help-docs/authors.md: -------------------------------------------------------------------------------- 1 | ## How to submit packages 2 | 3 | Previously, users would need to use `bower` to upload packages' documentation. Uploading documentation is now handled by the PureScript Registry (still in alpha at the time of this writing). See the [PureScript Registry repo](https://github.com/purescript/registry) for how to register and publish packages and their documentation. For more context, read the Discourse announcement, [Registry Alpha Launched](https://discourse.purescript.org/t/registry-alpha-launched/3146). 4 | 5 | ## How to mark package as deprecated 6 | 7 | Package deprecation is a mechanism to tell the end users that your package is no longer supported. When package is marked as deprecated, its contents will not show up in search results on Pursuit (with the only exception of the package name itself). A package can be marked as deprecated by adding a special keyword `pursuit-deprecated` to keywords section of `bower.json` and publishing a new version of the package. 8 | 9 | ## Package badges 10 | 11 | Pursuit can generate SVG badges for your packages, which you can put on your project's homepage, or perhaps its GitHub readme. 12 | 13 | The suggested markup for a badge is: 14 | 15 | ``` 16 | 17 | $PACKAGE_NAME on Pursuit 19 | 20 | 21 | ``` 22 | -------------------------------------------------------------------------------- /static/help-docs/index.md: -------------------------------------------------------------------------------- 1 | These pages contains various information for Pursuit users and package authors. If anything is missing or confusing, please [let us know](https://github.com/purescript/pursuit/issues/new). 2 | 3 | - Help for [Pursuit users](/help/users) 4 | - Help for [package authors](/help/authors) 5 | -------------------------------------------------------------------------------- /static/help-docs/users.md: -------------------------------------------------------------------------------- 1 | ## Searching 2 | 3 | When you use Pursuit's search feature, there are three types of results which 4 | may come up: declarations, modules, and packages. 5 | 6 | ### Declarations 7 | 8 | A *declaration* is anything exported from a module which exists in a package 9 | which has been uploaded to Pursuit. This is the most common type of search 10 | result. It includes types, values (note: functions are values), data 11 | constructors, type synonyms, type classes, kinds, and so on. For example: 12 | 13 | * the query "const" will return the [`const`][] function in the results, 14 | * the query "Unit" will return the [`Unit`][] type in the results, and 15 | * the query "applicative" will return the [`Applicative`][] type class in the 16 | results. 17 | 18 | Searching using prefixes of the desired result's name also works; for example, 19 | the query "sequen" returns the [`sequence`][] function. 20 | 21 | You can also search for declarations based on their type. For example, the type 22 | of [`const`][] is `forall a b. a -> b -> a`; if you search for "a -> b -> a", 23 | then `const` will appear in the search results. 24 | 25 | When searching by type, Pursuit knows that the names you give to the type 26 | variables do not matter. For example, the query "x -> y -> x" also returns 27 | `const` in the results. 28 | 29 | ### Modules 30 | 31 | A *module* is the basic unit of packaging PureScript code up for reuse. For more 32 | information on modules, see the [Modules page in the documentation 33 | repository][]. 34 | 35 | To search for a module, enter either the whole module name or a prefix of it. 36 | For example: 37 | 38 | - the query "Control.Plus" returns the module `Control.Plus`, 39 | - the query "Data.String" returns the module `Data.String`, as well as 40 | `Data.String.Base64`, `Data.String.CaseInsensitive`, and so on, and 41 | - the query "DOM" returns the module `DOM`, as well as all of the other modules 42 | which begin with `DOM`. 43 | 44 | ### Packages 45 | 46 | A *package* contains a number of modules, which are usually related and 47 | intended to be used together. Packages also have metadata attached to them such 48 | as their author, version, publish date, and so on. 49 | 50 | To search for a package, simply enter its name or a prefix of it. It is not 51 | necessary to include the "purescript-" prefix. For example: 52 | 53 | * the query "lazy" returns the package `purescript-lazy`, 54 | * the query "strings" returns the packages `purescript-strings` and 55 | `purescript-strings-extra`, and 56 | * the query "argonaut" returns the packages `purescript-argonaut`, 57 | `purescript-argonaut-codecs`, `purescript-argonaut-core`, and so on. 58 | 59 | ### Types of searches 60 | 61 | There are two types of searches that can be performed: searching by name or by 62 | type. Pursuit will infer which type of search is intended based on the query. 63 | Only declarations can have types (modules and packages cannot), so when you 64 | search by type, you will only get declaration results. 65 | 66 | When searching by name, an entry in Pursuit's database is considered to be a 67 | match if the query is a prefix of its name. For example, "con" matches "const" 68 | but "cosnt" does not. (This may change in the future.) 69 | 70 | Currently, searching for **visible type applications** (e.g. `forall @a. a -> a`) 71 | is not currently supported. 72 | 73 | Currently, documentation comments are not included in the search index. This 74 | means that, for example, if you search for "Kleisli", there are no results, 75 | even though the documentation for [`Star`][] mentions that this type is also 76 | called "Kleisli" in some contexts. This may also change in the future; see 77 | [Pursuit issue #318](https://github.com/purescript/pursuit/issues/318). 78 | 79 | [`const`]: https://pursuit.purescript.org/packages/purescript-prelude/docs/Prelude#v:const 80 | [`Applicative`]: https://pursuit.purescript.org/packages/purescript-prelude/docs/Prelude#t:Applicative 81 | [`Unit`]: https://pursuit.purescript.org/packages/purescript-prelude/docs/Prelude#t:Unit 82 | [`sequence`]: https://pursuit.purescript.org/packages/purescript-foldable-traversable/docs/Data.Traversable#t:Traversable 83 | [Modules page in the documentation repository]: https://github.com/purescript/documentation/blob/master/language/Modules.md 84 | [`Star`]: https://pursuit.purescript.org/packages/purescript-profunctor/docs/Data.Profunctor.Star#t:Star 85 | 86 | ## Kind Signatures 87 | 88 | ### Explicit and Inferred 89 | 90 | Data, newtype, type synonym, and type class declarations all have kind 91 | signatures. These signatures are either explicit (i.e. developer-defined) 92 | or implicit (i.e. compiler-inferred). For example 93 | 94 | ```purescript 95 | -- Explicit kind signature 96 | data ExplicitFoo :: forall k. k -> Type 97 | data ExplicitFoo a = ExplicitFoo 98 | 99 | {- Kind signature inferred by the compiler for the below type: 100 | data ImplicitFoo :: forall k. k -> (Type -> Type) -> Type -} 101 | data ImplicitFoo a f = ImplicitFoo (f Int) 102 | ``` 103 | 104 | ### Merging Documentation Comments 105 | 106 | Since both the kind signature declaration and the data/newtype/type/class 107 | declaration can have documentation comments, both will be merged together 108 | with a newline separating them. For example, the below code's doc comments... 109 | ```purescript 110 | -- | Kind signature declaration documentation comment 111 | data ExplicitFoo :: forall k. k -> Type 112 | -- | Data declaration documentation comment 113 | data ExplicitFoo a = ExplicitFoo 114 | ``` 115 | ... will be rendered as 116 | ``` 117 | Kind signature declaration documentation comment 118 | Data declaration documentation comment 119 | ``` 120 | 121 | ### Interesting kinds are displayed; Uninteresting kinds are not 122 | 123 | The following design choice should make it easier for new learners 124 | to learn the language by limiting their exposure to these more 125 | advanced language features. 126 | 127 | By default, all kind signatures, whether explicitly-declared by the developer 128 | or inferred by the compiler, will only be displayed if the kind signatures 129 | are considered "interesting." Put differently, "uninteresting" kind signatures will not be displayed. 130 | 131 | An "uninteresting" kind signature is one that follows this form: 132 | - `Type` 133 | - `Constraint` 134 | - `Type -> K` where `K` refers to an "uninteresting" kind signature 135 | 136 | Here's another way to think about it: kind signatures are considered 137 | "uninteresting" if all of their type parameters' kinds have kind `Type`. 138 | 139 | #### Examples of "uninteresting" kind signatures 140 | 141 | ```purescript 142 | data TypeOnly :: Type 143 | data TypeOnly 144 | 145 | class IntentionallyEmpty :: Constraint 146 | class IntentionallyEmpty 147 | 148 | class Bar :: Type -> Type -> Constraint 149 | class Bar a b where 150 | convert :: a -> b 151 | ``` 152 | 153 | #### Examples of "interesting" kind signatures 154 | 155 | Each kind signature below is "interesting" because it has at least one 156 | type parameter whose kind is something other than kind `Type`: 157 | ```purescript 158 | -- the "k" part makes this kind signature "interesting" 159 | data PolyProxy :: forall k. k -> Type 160 | data PolyProxy a = PolyProxy 161 | 162 | -- the `(Type -> Type)` part makes this kind signature "interesting" 163 | data FunctorLike :: (Type -> Type) -> Type -> Type 164 | data FunctorLike f a = FunctorLike (f Int) a 165 | 166 | -- every type parameter makes this kind signature "interesting" 167 | class TypeLevelProgrammingFunction :: Symbol -> Row Type -> Row Type -> Constraint 168 | class TypeLevelProgrammingFunction sym row1 row2 | sym row1 -> row2 169 | ``` 170 | -------------------------------------------------------------------------------- /static/js/Pursuit.js: -------------------------------------------------------------------------------- 1 | (function() { 2 | /* Expects arguments as an Object with the following properties: 3 | * - currentVersion (String): 4 | * the version of docs that is being shown on this page. 5 | * - elementId (String): 6 | * the HTML id of the version selector element. 7 | * - availableVersionsUrl (String): 8 | * The URL to fetch the available versions for this package from. 9 | */ 10 | function initializeVersionSelector(args) { 11 | function getJSON(url, callback) { 12 | var req = new XMLHttpRequest() 13 | req.open('GET', url, true) 14 | req.onload = function() { 15 | callback(JSON.parse(this.responseText)) 16 | } 17 | req.send(null) 18 | } 19 | 20 | // Create a single