From 4843fa20874f6f8d85f9199345423319516190ae Mon Sep 17 00:00:00 2001 From: Simen Kirkvik Date: Wed, 13 Dec 2023 17:58:56 +0100 Subject: [PATCH] wip: start manually decoding only wanted fish health fields Also do some refactoring, and start on moving barentswatch api behind auth. The manual fish health data decoding needs some work, and needs a mapping of what is interesting. The selection is also kinda wonky right now. The selection and deselection might not be what we want. --- ...idir-locality-borders-example-payload.json | 79 +++++++ src/Client/Atlas.fs | 1 + src/Client/BarentsWatch.fs | 198 ++++++++++++++++++ src/Client/Client.fsproj | 4 +- src/Client/Fiskeridir.fs | 85 ++++++++ src/Client/Layers.fs | 27 ++- src/Client/MapTool.fs | 147 +++++++------ src/Client/Maps.fs | 46 ++-- src/Server/Api.fs | 86 +------- src/Server/BarentsWatch.fs | 81 +++++++ src/Server/Server.fs | 18 +- src/Server/Server.fsproj | 1 + src/Shared/Shared.fs | 34 ++- 13 files changed, 621 insertions(+), 186 deletions(-) create mode 100644 docs/fiskeridir-locality-borders-example-payload.json create mode 100644 src/Client/BarentsWatch.fs create mode 100644 src/Client/Fiskeridir.fs create mode 100644 src/Server/BarentsWatch.fs diff --git a/docs/fiskeridir-locality-borders-example-payload.json b/docs/fiskeridir-locality-borders-example-payload.json new file mode 100644 index 00000000..4f291a80 --- /dev/null +++ b/docs/fiskeridir-locality-borders-example-payload.json @@ -0,0 +1,79 @@ +{ + "id": 6551, + "siteVersionId": 2274, + "siteNr": 12298, + "name": "RØYSA", + "type": { + "value": "UNSPECIFIED" + }, + "points": [ + { + "id": 13885, + "index": 0, + "latitude": 62.549783, + "longitude": 6.1385 + }, + { + "id": 13886, + "index": 1, + "latitude": 62.55055, + "longitude": 6.141133 + }, + { + "id": 13887, + "index": 2, + "latitude": 62.547467, + "longitude": 6.145183 + }, + { + "id": 13888, + "index": 3, + "latitude": 62.546717, + "longitude": 6.142533 + }, + { + "id": 13889, + "index": 4, + "latitude": 62.549783, + "longitude": 6.1385 + }, + { + "id": 13890, + "index": 5, + "latitude": 62.54805, + "longitude": 6.1391 + }, + { + "id": 13891, + "index": 6, + "latitude": 62.5481, + "longitude": 6.139267 + }, + { + "id": 13892, + "index": 7, + "latitude": 62.5479, + "longitude": 6.139533 + }, + { + "id": 13893, + "index": 8, + "latitude": 62.54785, + "longitude": 6.139333 + }, + { + "id": 13894, + "index": 9, + "latitude": 62.54805, + "longitude": 6.1391 + }, + { + "id": 13895, + "index": 10, + "latitude": 62.549783, + "longitude": 6.1385 + } + ], + "areaM2": 64435.13037109375 +} + diff --git a/src/Client/Atlas.fs b/src/Client/Atlas.fs index 880c5d98..2cc69011 100644 --- a/src/Client/Atlas.fs +++ b/src/Client/Atlas.fs @@ -12,6 +12,7 @@ open Remoting open Archmeister.Types open Atlantis.Types +open Atlantis.Shared open Maps importSideEffects "./public/style.scss" diff --git a/src/Client/BarentsWatch.fs b/src/Client/BarentsWatch.fs new file mode 100644 index 00000000..41f5b14b --- /dev/null +++ b/src/Client/BarentsWatch.fs @@ -0,0 +1,198 @@ +module BarentsWatch + +open System + +open Browser +open Fable.Core +open Thoth.Json +open Thoth.Fetch + +open Atlantis.Shared + + +type Escape = { + Date : DateTime + Comment: string + Species: string + Count: int + CountType: string + CountCategory: string + Size: int + LocalityNo: int + LocalityName: string + Year: int + Week: int + ObjectId: int + ParentId: int + LocalityCapacity: int + WaterEnvironmentCode: string + WaterEnvironment: string + Status: string + StatusLocality: string + CreatedDate: DateTime + LastEditedDate: DateTime + GlobalId: string + CleanerFish: bool + RecaptureStarted: bool + RecaptureDescription: string + RecapturesCompleted: int + CountEstimated: string + MunicipalityNumber: int + CountyCode: int + County: string + Description: string + SizeEstimated: int +} + +type IlaPd = { + Id : int + LocalityNo : int + Disease : string + Ruling : string + FromDate : DateTime + ToDate : DateTime option +} +with + static member decoder = + Decode.oneOf [ + Decode.Auto.generateDecoder( + caseStrategy = CaseStrategy.CamelCase + ) + Decode.nil [||] + ] + +type LiceCountPreviousWeek = { + Year: int + Week: int + HasReportedLice: bool + AvgAdultFemaleLice: float option + AvgMobileLice: float option + AvgStationaryLice: float option +} +with + static member decoder = + Decode.object (fun get -> { + Year = get.Required.Field "year" Decode.int + Week = get.Required.Field "week" Decode.int + HasReportedLice = get.Required.Field "hasReportedLice" Decode.bool + AvgAdultFemaleLice = get.Optional.Field "avgAdultFemaleLice" (Decode.oneOf [ Decode.float; Decode.nil 0.0 ]) + AvgMobileLice = get.Optional.Field "avgMobileLice" (Decode.oneOf [ Decode.float; Decode.nil 0.0 ]) + AvgStationaryLice = get.Optional.Field "avgStationaryLice" (Decode.oneOf [ Decode.float; Decode.nil 0.0 ]) + }) + +// See docs/barentswatch-fishhealth-example-payload.json +type BarentsWatchFishHealth = { + LocalityName : string + LocalityIsInAquaCultureRegister : bool + LocalityWeek : obj + AquaCultureRegister : obj + ProductionArea : obj + LiceCountPreviousWeek : obj + ExportRestrictionAreas : obj array + // PdZoneId : string + Escapes : Escape array + // PdSurveillanceZones : obj array + // PdProtectionZones : obj array + // IlaSurveillanceZones : obj array + // IlaProtectionZones : obj array + // IlaFreeAreas : obj array + IlaPd : IlaPd array + // IlaPdCase : obj array +} +with + // TODO: Finish the manual decoder + // static member decoder = + // Decode.object (fun get -> + // { + // LocalityName = get.Required.Field "localityName" (Decode.oneOf [ Decode.string; Decode.nil "" ]) + // LocalityIsInAquaCultureRegister = get.Required.Field "localityIsInAquaCultureRegister" Decode.bool + // // LocalityWeek = get.Optional.Field "localityWeek" () + // // AquaCultureRegister = get.Optional.Field "aquaCultureRegister" Decode.object + // // ProductionArea : obj + // LiceCountPreviousWeek = get.Required.Field "liceCountPreviousWeek" LiceCountPreviousWeek.decoder + // // ExportRestrictionAreas : obj array + // // PdZoneId : string + // Escapes = get.Required.Field "escapes" (Decode.Auto.generateDecoder()) + // // PdSurveillanceZones : obj array + // // PdProtectionZones : obj array + // // IlaSurveillanceZones : obj array + // // IlaProtectionZones : obj array + // // IlaFreeAreas : obj array + // IlaPd = get.Required.Field "ilaPd" (IlaPd.decoder) + // // IlaPdCase : obj array + // } + // ) + static member autoDecoder = + Decode.Auto.generateDecoder( + caseStrategy = CaseStrategy.CamelCase + ) + +let fetchFishHealth year week localityId callback = + Fetch.tryGet( + url = $"https://www.barentswatch.no/bwapi/v1/geodata/fishhealth/locality/%i{localityId}/%i{year}/%i{week}", + headers = [ + // TODO: Try to fetch token again if its empty. You might have been on the site for more than 1 hour. + Fetch.Types.HttpRequestHeaders.Authorization $"""Bearer {sessionStorage["barentswatch_token"]}""" + ], + // TODO: Switch to manual decoder + decoder = BarentsWatchFishHealth.autoDecoder + ) + |> Promise.iter ( + Result.mapError (fun err -> + match err with + | PreparingRequestFailed exn -> + console.error("BarentsWatch get preparing request failed:", exn.Message) + | DecodingFailed s -> + console.error("BarentsWatch get decoding error:", s) + | FetchFailed response -> + response.json () + |> Promise.iter (fun errorJson -> + console.error("BarentsWatch get fetch failed:", errorJson)) + | NetworkError exn -> + console.error("BarentsWatch get network error:", exn.Message) + + // TODO: Create errMsg based on error + "Could not fetch fish health data from BarentsWatch" + ) + >> callback + ) + +let fetchToken () : BarentsWatch.Token option JS.Promise = + Fetch.tryGet( + url = "/barentswatch-token", + decoder = BarentsWatch.tokenDecoder + ) + |> Promise.map (fun res -> + match res with + | Error err -> + console.error("Could not fetch BarentsWatch token", err) + None + | Ok token -> + Some token + ) + +let refreshLoop () : unit JS.Promise = + let rec loop () = + promise { + let! tokenOpt = fetchToken() + + tokenOpt + |> Option.iter (fun token -> + console.info("Got new BarentsWatch token") + sessionStorage["barentswatch_token"] <- token.AccessToken + ) + + let sleepTimeMs = + tokenOpt + |> Option.map (fun token -> + let ts = TimeSpan.FromSeconds token.ExpiresIn + ts.Milliseconds) + |> Option.defaultValue ( + let ts = TimeSpan.FromHours 1 + ts.Milliseconds + ) + do! Promise.sleep sleepTimeMs + return! loop () + } + + loop () \ No newline at end of file diff --git a/src/Client/Client.fsproj b/src/Client/Client.fsproj index fc8bb0d1..c5ff0a06 100644 --- a/src/Client/Client.fsproj +++ b/src/Client/Client.fsproj @@ -28,12 +28,14 @@ - + + + diff --git a/src/Client/Fiskeridir.fs b/src/Client/Fiskeridir.fs new file mode 100644 index 00000000..05d9de59 --- /dev/null +++ b/src/Client/Fiskeridir.fs @@ -0,0 +1,85 @@ +module Fiskeridir + +open Browser +open Fable.OpenLayers +open Thoth.Fetch +open Thoth.Json + +open Atlantis.Types +open Utils + + +/// See docs/fiskeridir-locality-borders-example-payload.json +type FiskeridirLocalityBorder = { + Id : int + SiteVersionId : int + SiteNr : int + Name : string + Type : obj + Points : Point array + AreaM2 : float +} +and Point = { + Id : int + Index : int + Latitude : float + Longitude : float +} + +let fetchLocalityBorders (map: Map.Map) (localityId: int) = + Fetch.tryGet( + url = $"https://api.fiskeridir.no/pub-aqua/api/v1/sites/{localityId}/borders", + headers = [ + Fetch.Types.HttpRequestHeaders.Accept "application/json" + Fetch.Types.HttpRequestHeaders.AcceptCharset "UTF-8" + ], + decoder = + Decode.Auto.generateDecoder( + caseStrategy = CaseStrategy.CamelCase + ) + ) + |> Promise.map (fun res -> + match res with + | Error err -> console.error("Could not fetch locality borders from api.fiskeridir.no:", err) + | Ok borders -> + let points = + borders + |> Array.collect (fun border -> + border.Points) + + if points.Length < 1 then + console.info("This site does not have borders") + () + else + let feature = + let coords : Coordinate array = + let coords = + points + |> Array.map (fun point -> + posToCoord (point.Longitude, point.Latitude) + |> coordToEpsg3857) + let first = Array.head coords + let last = coords[coords.Length - 1] + + if first |> Coord.equals last then + coords + else + let first = coords |> Array.head |> Array.singleton + let linearRing = first |> Array.append coords + linearRing + + let polygon = + Geometry.polygon [ + geometry.coordinates [| coords |] + geometry.layout GeometryLayout.XY + ] + Feature.feature [ + feature.geometryOrProperties polygon + ] + + feature.setId localityId + feature.set("type", "polygon") + + Layers.addFeatures map MapLayer.Aquaculture [| feature |] + + ()) diff --git a/src/Client/Layers.fs b/src/Client/Layers.fs index 125bb0bc..372f0b79 100644 --- a/src/Client/Layers.fs +++ b/src/Client/Layers.fs @@ -104,7 +104,7 @@ let addFeatures map layerId (features: Feature array) = let layer = baseLayer :?> VectorLayer let source = layer.getSource() :?> VectorSource - console.debug("Adding features to layer", layerId, ":", features) + console.debug("Adding features to layer", layerId.Id, ":", features) source.addFeatures features ) @@ -139,6 +139,28 @@ let toggleVisibleFeatures map layerId = do layer.setVisible (not visible) ) +let updateVectorFeature map layerId (findFeatureFunc: VectorSource -> unit) = + map + |> updateBaseLayer layerId (fun baseLayer -> + let layer = baseLayer :?> VectorLayer + let source = layer.getSource() :?> VectorSource + + findFeatureFunc source + ) + +let hideVectorFeature map layerId (findFeatureFunc: VectorSource -> Feature option) = + map + |> updateBaseLayer layerId (fun baseLayer -> + let layer = baseLayer :?> VectorLayer + let source = layer.getSource() :?> VectorSource + + findFeatureFunc source + |> Option.iter (fun feature -> + console.debug("hideVectorFeature found feature:", feature) + feature.setStyle(Style.style []) + ) + ) + let private categorizeFeatures (fs: Feature []) (p: Particles) = fs |> Array.iteri (fun n f -> @@ -760,5 +782,4 @@ let activeLayerSelector (dispatch: Msg -> unit) (model: Model) = {layers} - """ - + """ \ No newline at end of file diff --git a/src/Client/MapTool.fs b/src/Client/MapTool.fs index 54ffd4bc..21d2525d 100644 --- a/src/Client/MapTool.fs +++ b/src/Client/MapTool.fs @@ -22,7 +22,6 @@ open Model open Notifier open Remoting open Sorcerer.Types -open Thoth.Fetch open Thoth.Json open Utils @@ -282,19 +281,33 @@ let addAquacultureHoverInteraction map dispatch : unit = let elem = popup.getElement() let desc : Types.HTMLDivElement = elem.querySelector("div") :?> Types.HTMLDivElement + // TODO: Show the same hover on polygon hover? Then we must save some information if ev.selected.Length = 0 then popup.setPosition(None) else let feature = ev.selected[0] - let geom = feature.getGeometry() - let coord = geom.getExtent() |> Extent.extent.getCenter - let species = - feature.get("arter") :?> string - |> fun s -> if s.Length > 80 then $"{s.Substring(0, 80)}..." else s - elem?heading <- feature.get("lokalitet") - elem?subheading <- species - desc.innerText <- feature.get("innehaver") :?> string - popup.setPosition(Some coord) + if feature.get("type") = "polygon" then + () + else + let geom = feature.getGeometry() + let coord = geom.getExtent() |> Extent.extent.getCenter + let species = + html $""" + + {feature.get("arter") :?> string} + """ + elem?heading <- feature.get("lokalitet") + elem?subheading <- species + desc.innerText <- feature.get("innehaver") :?> string + popup.setPosition(Some coord) ) map.addInteraction select @@ -305,10 +318,12 @@ let addAquacultureClickInteraction map dispatch : unit = aquacultureLayerOpt |> Option.iter (fun (idx, aquacultureLayer)-> + // TODO: This should maybe be a map click event with forEveryFeatureAt thingy instead of an actual select interaction let select = Interaction.select [ select.layers [ aquacultureLayer :?> VectorLayer ] select.condition Fable.OpenLayers.Event.condition.click + select.style (Style.style []) ] select.on ( @@ -317,11 +332,31 @@ let addAquacultureClickInteraction map dispatch : unit = console.debug("Clicked on aquaculture", ev.selected) if ev.selected.Length = 1 then let feature = ev.selected[0] - let localityNumber = feature.get("loknr") |> unbox int |> Some + if feature.get("type") = "polygon" then + feature.getId () + |> Some + |> SetAquaculture + |> dispatch + else + let localityNumber = feature.get("loknr") |> unbox + // NOTE(simkir): This is used in the layer style to hide all features that are selected. But it + // might not be needed as the select interaction style is already set to hide the feature + feature.set("selected", "true") + if 10000 < localityNumber && localityNumber < 99999 then + Fiskeridir.fetchLocalityBorders map localityNumber |> Promise.start - localityNumber - |> SetAquaculture - |> dispatch + // When you deselect a feature (should in theory only be 1), set selected to false and delete the + // location polygon + ev.deselected + |> Array.iter (fun feature -> + let localityNumberOpt = feature.get("loknr") |> unbox + console.debug("Deselecting", feature.get("loknr")) + + feature.set("selected", "false") + + updateVectorFeature map MapLayer.Aquaculture (fun source -> + localityNumberOpt + |> Option.iter (source.getFeatureById >> source.removeFeature))) ) map.addInteraction select @@ -898,23 +933,36 @@ let update cmd (model: Model) = manageFiskeri m k m, Cmd.none | SetAquaculture locationIdOpt -> - { model with selectedAquaculture = locationIdOpt }, Cmd.none + // NOTE: Fetch the borders + let fetchBorderCmd = + match locationIdOpt with + | Some id when 10000 < id && id < 99999 -> + Cmd.OfPromise.perform (Fiskeridir.fetchLocalityBorders model.map) id Noop + | _ -> + Cmd.none + + { model with selectedAquaculture = locationIdOpt }, + Cmd.batch [| + fetchBorderCmd + |] | InitArchive m -> refreshLayers model m - let fly () = + let fly (infoLayer) = // console.debug("Flying") let center = toEpsg3857 m.archive.focalPoint flyTo m.map center m.archive.defaultZoom + + infoLayer let refreshLayerWithDelay t = Promise.sleep t |> Promise.map (fun () -> refreshLayers model m) m, Cmd.batch [ - // Cmd.OfPromise.perform getWireframe m.archive.id SetDefaultWireframe - Cmd.ofMsg (SetWireframe m.grid) - Cmd.OfPromise.perform Drifters.fetchArchiveDrifters m SetDrifters - Cmd.OfFunc.perform fly () Noop - Cmd.OfPromise.perform refreshLayerWithDelay 50 Noop + // Cmd.OfPromise.perform getWireframe m.archive.id SetDefaultWireframe + Cmd.ofMsg (SetWireframe m.grid) + Cmd.OfPromise.perform Drifters.fetchArchiveDrifters m SetDrifters + Cmd.OfFunc.perform fly InfoLayer.Lokaliteter AddInfoLayer + Cmd.OfPromise.perform refreshLayerWithDelay 50 Noop ] | SetProp (pt, p) -> console.debug("[MapTool] SetProp on layer", pt.Id, "to type", p.PropType.ToLabel()) @@ -1180,60 +1228,6 @@ let aquaculturePopup = """ -// See docs/barentswatch-fishhealth-example-payload.json -type BarentsWatchFishHealth = { - LocalityName : string - LocalityIsInAquaCultureRegister : bool - LocalityWeek : obj - AquaCultureRegister : obj - ProductionArea : obj - LiceCountPreviousWeek : obj - ExportRestrictionAreas : obj array - PdZoneId : string - Escapes : obj array - PdSurveillanceZones : obj array - PdProtectionZones : obj array - IlaSurveillanceZones : obj array - IlaProtectionZones : obj array - IlaFreeAreas : obj array - IlaPd : obj array option - IlaPdCase : obj array -} -with - static member decoder = - Decode.Auto.generateDecoder( - caseStrategy = CaseStrategy.CamelCase - ) - -let fetchBarentsWatchFishHealth year week localityId callback = - Thoth.Fetch.Fetch.tryGet( - url = $"https://www.barentswatch.no/bwapi/v1/geodata/fishhealth/locality/%i{localityId}/%i{year}/%i{week}", - headers = [ - // TODO: Get token from Atlantis - Fetch.Types.HttpRequestHeaders.Authorization $"""Bearer {sessionStorage["barentswatch_token"]}""" - ], - decoder = BarentsWatchFishHealth.decoder - ) - |> Promise.iter ( - Result.mapError (fun err -> - match err with - | PreparingRequestFailed exn -> - console.error("BarentsWatch get preparing request failed:", exn.Message) - | DecodingFailed s -> - console.error("BarentsWatch get decoding error:", s) - | FetchFailed response -> - response.json () - |> Promise.iter (fun errorJson -> - console.error("BarentsWatch get fetch failed:", errorJson)) - | NetworkError exn -> - console.error("BarentsWatch get network error:", exn.Message) - - // TODO: Create errMsg based on error - "Could not fetch fish health data from BarentsWatch" - ) - >> callback - ) - [] let aquacultureModal (currentTime: DateTime) (aquacultureId: int option) onClose = let fishHealthJson, setFishHealth = Hook.useState "" @@ -1245,7 +1239,7 @@ let aquacultureModal (currentTime: DateTime) (aquacultureId: int option) onClose newIdOpt |> Option.iter (fun newId -> console.debug("Looking up location number", newId, "in week", week) - fetchBarentsWatchFishHealth currentTime.Year week newId (fun fishHealthRes -> + BarentsWatch.fetchFishHealth currentTime.Year week newId (fun fishHealthRes -> match fishHealthRes with | Error errMsg -> console.error("BarentsWatch error:", errMsg) @@ -1464,7 +1458,6 @@ let initModel () = Cmd.OfAsync.perform getIdentity () SetIdentity Cmd.OfAsync.perform archive () SetArchive Cmd.OfAsync.perform atmoApi.Wind.GetBarbSigns () SetArrows - Cmd.ofMsg (AddInfoLayer InfoLayer.Lokaliteter) ] let plotPage dispatch model = diff --git a/src/Client/Maps.fs b/src/Client/Maps.fs index 4236b643..81a3d3da 100644 --- a/src/Client/Maps.fs +++ b/src/Client/Maps.fs @@ -151,19 +151,23 @@ let urlFunc = // must return a lambda! // // // + // + // + // + // FiskeridirWFS:Akvakultur_-_Lokaliteter/FiskeridirWFS:status + // RETIRED + // + // + // FiskeridirWFS:Akvakultur_-_Lokaliteter/FiskeridirWFS:shape + // + // {extent} + // + // + // + // // NOTE: THE XML IS CASE SENSITIVE! let filter = - $""" - - - - FiskeridirWFS:Akvakultur_-_Lokaliteter/FiskeridirWFS:status - RETIRED - - FiskeridirWFS:Akvakultur_-_Lokaliteter/FiskeridirWFS:shape{extent} - - - """ + $"""FiskeridirWFS:Akvakultur_-_Lokaliteter/FiskeridirWFS:statusRETIREDFiskeridirWFS:Akvakultur_-_Lokaliteter/FiskeridirWFS:shape{extent}""" Lokaliteter.wfsUrl() + "?SERVICE=WFS" @@ -209,12 +213,30 @@ let fiskeri (topic: InfoLayer) : Ol.Layer.Layer = ] ) ] + let polygonStyle = + Style.style [ + style.stroke ( + Style.stroke [ + stroke.color "white" + stroke.width 1 + ] + ) + style.fill ( + Style.fill [ + fill.color "rgba(0.5, 0.5, 0.5, 0.1)" + ] + ) + ] // TODO: Try webglPoints again Layer.vectorLayer [ layer.className (string MapLayer.Aquaculture) layer.source vectorSource - layer.style defaultStyle + layer.style (fun feature -> + if feature.get("type") = "polygon" then + polygonStyle + else + defaultStyle) layer.zIndex 12 ] else diff --git a/src/Server/Api.fs b/src/Server/Api.fs index e14096ad..fd92747e 100644 --- a/src/Server/Api.fs +++ b/src/Server/Api.fs @@ -13,11 +13,10 @@ open Fable.Remoting.Server open Giraffe open Microsoft.AspNetCore.Authentication open Microsoft.AspNetCore.Http -open Saturn open Serilog open Server -open StackExchange.Redis open Thoth.Json.Net +open StackExchange.Redis open Archmeister.Actors open Atlantis.Shared @@ -29,33 +28,6 @@ open Petimeter.Interfaces.Actors open Settings -let fetchBarentsWatchToken clientId secret = - async { - let! tokenStr = - Http.AsyncRequestString( - // NOTE: Guessing this wont change much :) - url = "https://id.barentswatch.no/connect/token", - httpMethod = "POST", - headers = [ - "Content-Type", "application/x-www-form-urlencoded" - ], - body = - HttpRequestBody.TextRequest ( - "scope=api" - + "&grant_type=client_credentials" - + $"&client_id=%s{clientId}" - + $"&client_secret=%s{secret}" - ) - ) - let jsonRes = - Decode.Auto.fromString( - json = tokenStr, - caseStrategy = CaseStrategy.SnakeCase - ) - - return jsonRes - } - let anonymous = "unknown" let getUserName (ctx: HttpContext) = @@ -97,10 +69,6 @@ module Handlers = GetFileService = fun () -> appsettings.sorcerer |> async.Return } - let barentsWatchDecoder (str: string) : Result = - Decode.Auto.fromString(json = str, caseStrategy = CaseStrategy.SnakeCase) - let barentsWatchEncoder (token: BarentsWatchToken) : string = - Encode.Auto.toString(value = token, caseStrategy = CaseStrategy.SnakeCase) let refreshDecoder = Decode.fromString (Decode.Auto.generateDecoder ()) @@ -160,54 +128,8 @@ module Handlers = Log.Information $"token refresh failed: {e}" return None } - BarentsWatchToken = - fun () -> - let key = "barentswatch_token" - let redis = ConnectionMultiplexer.Connect(appsettings.sso.redis) - let db = redis.GetDatabase() - async { - let value = - try - db.StringGet(key) - with e -> - Log.Error("Exception while fetching value from redis: {Message}", e.Message) - RedisValue() - if value.HasValue then - let tokenStr = string value - Log.Debug("Value is {Value}", tokenStr) - let token = - tokenStr - |> barentsWatchDecoder - |> Result.toOption - Log.Debug("Token is {@Token}", token) - return token - else - let! tokenRes = - barentsWatchClientID - |> Option.bind (fun id -> - barentsWatchSecret - |> Option.map (fun secret -> - fetchBarentsWatchToken id secret)) - |> Option.defaultValue ( - Error "Barentswatch secret or client id missing" - |> async.Return - ) - - match tokenRes with - | Error err -> - Log.Error(err) - return None - | Ok token -> - let tokenStr = barentsWatchEncoder token - let expire = TimeSpan.FromSeconds token.ExpiresIn - if db.StringSet(key = key, value = tokenStr, expiry = expire) then - Log.Debug("Updated barentsWatch token") - else - Log.Error("Error pushing barentsWatch token to Redis") - - return Some token - } - + // TODO: Remove from here as its not behind authentication + BarentsWatchToken = BarentsWatch.getToken } let private jobStatsToString status = @@ -418,4 +340,4 @@ module Endpoints = Remoting.createApi () |> Remoting.fromContext Handlers.inboxApi |> Remoting.withRouteBuilder Api.routeBuilder - |> Remoting.buildHttpHandler + |> Remoting.buildHttpHandler \ No newline at end of file diff --git a/src/Server/BarentsWatch.fs b/src/Server/BarentsWatch.fs new file mode 100644 index 00000000..391797b9 --- /dev/null +++ b/src/Server/BarentsWatch.fs @@ -0,0 +1,81 @@ +module BarentsWatch + +open System + +open FSharp.Data +open Serilog +open StackExchange.Redis + +open Atlantis.Shared +open Settings + + +/// Gets a new token from BarentsWatch +let fetchNewToken clientId secret = + async { + let! tokenStr = + Http.AsyncRequestString( + // NOTE: Guessing this wont change much :) + url = "https://id.barentswatch.no/connect/token", + httpMethod = "POST", + headers = [ + "Content-Type", "application/x-www-form-urlencoded" + ], + body = + HttpRequestBody.TextRequest ( + "scope=api" + + "&grant_type=client_credentials" + + $"&client_id=%s{clientId}" + + $"&client_secret=%s{secret}" + ) + ) + + return BarentsWatch.tokenDecode tokenStr + } + +/// Tries to see if an existing token exists in Redis, and if not, fetch a new one from BarentsWatch +let getToken () = + let key = "barentswatch_token" + let redis = ConnectionMultiplexer.Connect(appsettings.sso.redis) + let db = redis.GetDatabase() + async { + let value = + try + db.StringGet(key) + with e -> + Log.Error("Exception while fetching value from redis: {Message}", e.Message) + RedisValue() + if value.HasValue then + let tokenStr = string value + Log.Debug("Value is {Value}", tokenStr) + let token = + BarentsWatch.tokenDecode tokenStr + |> Result.toOption + Log.Debug("Token is {@Token}", token) + return token + else + let! tokenRes = + barentsWatchClientID + |> Option.bind (fun id -> + barentsWatchSecret + |> Option.map (fun secret -> + fetchNewToken id secret)) + |> Option.defaultValue ( + Error "Barentswatch secret or client id missing" + |> async.Return + ) + + match tokenRes with + | Error err -> + Log.Error(err) + return None + | Ok token -> + let tokenStr = BarentsWatch.tokenEncode token + let expire = TimeSpan.FromSeconds token.ExpiresIn + if db.StringSet(key = key, value = tokenStr, expiry = expire) then + Log.Debug("Updated barentsWatch token") + else + Log.Error("Error pushing barentsWatch token to Redis") + + return Some token + } diff --git a/src/Server/Server.fs b/src/Server/Server.fs index 51506186..5203fc61 100644 --- a/src/Server/Server.fs +++ b/src/Server/Server.fs @@ -3,8 +3,10 @@ module Main open System open System.Text.Json open System.Text.Json.Serialization + open Argu open Dapr.Actors +open FSharp.Data open Fable.SignalR open Giraffe open Microsoft.AspNetCore.Authentication @@ -17,11 +19,11 @@ open Microsoft.Extensions.DependencyInjection open Microsoft.Extensions.Logging open Prometheus open Saturn +open Saturn.Dapr open Serilog open Serilog.Events open Server -open Saturn.Dapr open Atlantis.Shared open Auth open Settings @@ -112,6 +114,17 @@ let getAccessToken (next: HttpFunc) (ctx: HttpContext) = return! json t next ctx } +let getBarentsWatchToken (next: HttpFunc) (ctx: HttpContext) = + task { + let! tokenOpt = BarentsWatch.getToken () |> Async.StartAsTask + match tokenOpt with + | None -> + ctx.SetStatusCode 500 + return! text "Could not get BarentsWatch token" next ctx + | Some token -> + return! json token next ctx + } + let getClaims (next: HttpFunc) (ctx: HttpContext) = task { let c = @@ -148,6 +161,9 @@ let webApp = >=> choose [ route "/claims" >=> getClaims route "/token" >=> getAccessToken + // TODO: Start using this in front-end, and remove from authEndpoints + // TODO: Implement as Remoting? + route "/barentswatch-token" >=> getBarentsWatchToken Api.Endpoints.servicesEndpoints Api.Endpoints.driftersEndpoints Api.Endpoints.inboxEndpoints diff --git a/src/Server/Server.fsproj b/src/Server/Server.fsproj index 29f51cf4..45508383 100644 --- a/src/Server/Server.fsproj +++ b/src/Server/Server.fsproj @@ -12,6 +12,7 @@ + diff --git a/src/Shared/Shared.fs b/src/Shared/Shared.fs index cb97e06e..c5ed6960 100644 --- a/src/Shared/Shared.fs +++ b/src/Shared/Shared.fs @@ -5,6 +5,11 @@ open Drifters.ApiTypes open Hipster.Interfaces.Job open Hipster.Interfaces.Actors open Petimeter.Interfaces.Inbox +#if FABLE_COMPILER +open Thoth.Json +#else +open Thoth.Json.Net +#endif type UserCredentials = { username: string; password: string } @@ -18,13 +23,23 @@ type OidToken = scope: string } -type BarentsWatchToken = { - AccessToken: string - /// In seconds. Should be 3600s as per BarentsWatch docs - ExpiresIn: int - TokenType: string - Scope: string -} +module BarentsWatch = + type Token = { + AccessToken: string + /// In seconds. Should be 3600s as per BarentsWatch docs + ExpiresIn: int + TokenType: string + Scope: string + } + + let tokenDecode (str: string) : Result = + Decode.Auto.fromString(json = str, caseStrategy = CaseStrategy.SnakeCase) + + let tokenDecoder = + Decode.Auto.generateDecoder(caseStrategy = CaseStrategy.SnakeCase) + + let tokenEncode (token: Token) : string = + Encode.Auto.toString(value = token, caseStrategy = CaseStrategy.SnakeCase) [] module Api = @@ -47,7 +62,7 @@ module Api = IsAuthenticated: unit -> Async<(string * string) option> HasRoleOf: string -> Async RefreshAccessToken: string -> Async<(string * string) option> - BarentsWatchToken: unit -> Async + BarentsWatchToken: unit -> Async } type Services = @@ -136,5 +151,4 @@ module Hub = | Note of Notification.Note | InboxUnread of int | Success - | Failure of string - + | Failure of string \ No newline at end of file