|
| 1 | +-- | HTTP client for making requests to the registry server from the dashboard. |
| 2 | +-- | Provides typed helpers for fetching job data from the Registry API. |
| 3 | +module Dashboard.API |
| 4 | + ( ApiConfig |
| 5 | + , ApiError(..) |
| 6 | + , defaultConfig |
| 7 | + , fetchJobs |
| 8 | + , fetchJob |
| 9 | + , printApiError |
| 10 | + ) where |
| 11 | + |
| 12 | +import Prelude |
| 13 | + |
| 14 | +import Codec.JSON.DecodeError as CJ.DecodeError |
| 15 | +import Control.Alt ((<|>)) |
| 16 | +import Control.Parallel (parallel, sequential) |
| 17 | +import Data.Codec.JSON as CJ |
| 18 | +import Data.DateTime (DateTime) |
| 19 | +import Data.Either (Either(..)) |
| 20 | +import Data.Maybe (Maybe(..)) |
| 21 | +import Data.String as String |
| 22 | +import Effect.Aff (Aff, Milliseconds(..)) |
| 23 | +import Effect.Aff as Aff |
| 24 | +import Effect.Exception as Exception |
| 25 | +import Fetch (Method(..)) |
| 26 | +import Fetch as Fetch |
| 27 | +import JSON as JSON |
| 28 | +import Registry.API.V1 (Job, JobId, LogLevel, Route(..), SortOrder) |
| 29 | +import Registry.API.V1 as V1 |
| 30 | +import Routing.Duplex as Routing |
| 31 | + |
| 32 | +-- | Configuration for the API client. |
| 33 | +type ApiConfig = |
| 34 | + { baseUrl :: String |
| 35 | + } |
| 36 | + |
| 37 | +-- | Default API configuration pointing to the production registry server. |
| 38 | +defaultConfig :: ApiConfig |
| 39 | +defaultConfig = |
| 40 | + { baseUrl: "https://registry.purescript.org" |
| 41 | + } |
| 42 | + |
| 43 | +-- | Errors that can occur when making API requests. |
| 44 | +data ApiError |
| 45 | + = HttpError { status :: Int, body :: String } |
| 46 | + | ParseError { message :: String, raw :: String } |
| 47 | + |
| 48 | +-- | Render an ApiError as a human-readable string. |
| 49 | +printApiError :: ApiError -> String |
| 50 | +printApiError = case _ of |
| 51 | + HttpError { status, body } -> |
| 52 | + "HTTP " <> show status <> ": " <> body |
| 53 | + ParseError { message, raw } -> |
| 54 | + "Parse error: " <> message <> "\nResponse: " <> String.take 500 raw |
| 55 | + |
| 56 | +-- | Print a V1 Route to its URL path string. |
| 57 | +printRoute :: Route -> String |
| 58 | +printRoute = Routing.print V1.routes |
| 59 | + |
| 60 | +-- | Parse a JSON string using a codec, returning Either ApiError. |
| 61 | +parseJson :: forall a. CJ.Codec a -> String -> Either ApiError a |
| 62 | +parseJson codec str = case JSON.parse str of |
| 63 | + Left jsonErr -> |
| 64 | + Left $ ParseError { message: "JSON: " <> jsonErr, raw: str } |
| 65 | + Right json -> case CJ.decode codec json of |
| 66 | + Left decodeErr -> |
| 67 | + Left $ ParseError { message: CJ.DecodeError.print decodeErr, raw: str } |
| 68 | + Right a -> |
| 69 | + Right a |
| 70 | + |
| 71 | +-- | Request timeout in milliseconds. |
| 72 | +requestTimeout :: Milliseconds |
| 73 | +requestTimeout = Milliseconds 10000.0 |
| 74 | + |
| 75 | +-- | Run an Aff action with a timeout. Returns Nothing if the action does not |
| 76 | +-- | complete within the given duration, or Just the result if it does. |
| 77 | +timeout :: forall a. Milliseconds -> Aff a -> Aff (Maybe a) |
| 78 | +timeout ms action = sequential do |
| 79 | + parallel (Just <$> action) <|> parallel (Nothing <$ Aff.delay ms) |
| 80 | + |
| 81 | +-- | Make a GET request to the given URL path and decode the response body. |
| 82 | +get :: forall a. CJ.Codec a -> ApiConfig -> String -> Aff (Either ApiError a) |
| 83 | +get codec config path = do |
| 84 | + result <- Aff.try $ timeout requestTimeout do |
| 85 | + response <- Fetch.fetch (config.baseUrl <> path) { method: GET } |
| 86 | + body <- response.text |
| 87 | + pure { status: response.status, body } |
| 88 | + case result of |
| 89 | + Left err -> |
| 90 | + pure $ Left $ HttpError { status: 0, body: Exception.message err } |
| 91 | + Right Nothing -> |
| 92 | + pure $ Left $ HttpError { status: 0, body: "Request timed out" } |
| 93 | + Right (Just { status, body }) |
| 94 | + | status >= 200 && status < 300 -> |
| 95 | + pure $ parseJson codec body |
| 96 | + | otherwise -> |
| 97 | + pure $ Left $ HttpError { status, body } |
| 98 | + |
| 99 | +-- | Fetch the list of jobs from the registry server. |
| 100 | +-- | |
| 101 | +-- | Parameters: |
| 102 | +-- | - `since`: Only return jobs created after this time |
| 103 | +-- | - `until`: Only return jobs created before this time |
| 104 | +-- | - `order`: Sort order for results (ASC or DESC) |
| 105 | +-- | - `includeCompleted`: When true, include finished jobs in the results |
| 106 | +fetchJobs |
| 107 | + :: ApiConfig |
| 108 | + -> { since :: Maybe DateTime, until :: Maybe DateTime, order :: Maybe SortOrder, includeCompleted :: Maybe Boolean } |
| 109 | + -> Aff (Either ApiError (Array Job)) |
| 110 | +fetchJobs config params = do |
| 111 | + let route = Jobs { since: params.since, until: params.until, order: params.order, include_completed: params.includeCompleted } |
| 112 | + get (CJ.array V1.jobCodec) config (printRoute route) |
| 113 | + |
| 114 | +-- | Fetch a single job by its ID. |
| 115 | +-- | |
| 116 | +-- | Parameters: |
| 117 | +-- | - `level`: Minimum log level to include in the response |
| 118 | +-- | - `since`: Only return log lines after this time |
| 119 | +-- | - `until`: Only return log lines before this time |
| 120 | +-- | - `order`: Sort order for log lines (ASC or DESC) |
| 121 | +fetchJob |
| 122 | + :: ApiConfig |
| 123 | + -> JobId |
| 124 | + -> { level :: Maybe LogLevel, since :: Maybe DateTime, until :: Maybe DateTime, order :: Maybe SortOrder } |
| 125 | + -> Aff (Either ApiError Job) |
| 126 | +fetchJob config jobId params = do |
| 127 | + let route = Job jobId { level: params.level, since: params.since, until: params.until, order: params.order } |
| 128 | + get V1.jobCodec config (printRoute route) |
0 commit comments