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