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.
This commit is contained in:
Simen Kirkvik
2023-12-13 17:58:56 +01:00
parent 95b227adf3
commit 4843fa2087
13 changed files with 621 additions and 186 deletions

View File

@@ -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
}

View File

@@ -12,6 +12,7 @@ open Remoting
open Archmeister.Types
open Atlantis.Types
open Atlantis.Shared
open Maps
importSideEffects "./public/style.scss"

198
src/Client/BarentsWatch.fs Normal file
View File

@@ -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<Escape array>())
// // 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<BarentsWatchFishHealth>(
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 ()

View File

@@ -34,6 +34,8 @@
<Compile Include="PropertyPlots.fs"/>
<Compile Include="Fable.VisJS.fs"/>
<Compile Include="Timeline.fs"/>
<Compile Include="Fiskeridir.fs" />
<Compile Include="BarentsWatch.fs" />
<Compile Include="Drifters.fs"/>
<Compile Include="Probing.fs"/>
<Compile Include="Stats.fs"/>

85
src/Client/Fiskeridir.fs Normal file
View File

@@ -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<unit, FiskeridirLocalityBorder array>(
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<FiskeridirLocalityBorder array>(
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 |]
())

View File

@@ -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 ->
@@ -761,4 +783,3 @@ let activeLayerSelector (dispatch: Msg -> unit) (model: Model) =
</sp-radio-group>
</sp-accordion>
"""

View File

@@ -22,7 +22,6 @@ open Model
open Notifier
open Remoting
open Sorcerer.Types
open Thoth.Fetch
open Thoth.Json
open Utils
@@ -282,15 +281,29 @@ 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]
if feature.get("type") = "polygon" then
()
else
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
html $"""
<span
style="
display: inline-block;
overflow: hidden;
text-overflow: ellipsis;
white-space: nowrap;
max-width: 80ch;
"
>
{feature.get("arter") :?> string}
</span>"""
elem?heading <- feature.get("lokalitet")
elem?subheading <- species
desc.innerText <- feature.get("innehaver") :?> string
@@ -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
localityNumber
if feature.get("type") = "polygon" then
feature.getId ()
|> Some
|> SetAquaculture
|> dispatch
else
let localityNumber = feature.get("loknr") |> unbox<int>
// 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
// 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<int option>
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,13 +933,26 @@ 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)
@@ -913,7 +961,7 @@ let update cmd (model: Model) =
// 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.OfFunc.perform fly InfoLayer.Lokaliteter AddInfoLayer
Cmd.OfPromise.perform refreshLayerWithDelay 50 Noop
]
| SetProp (pt, p) ->
@@ -1180,60 +1228,6 @@ let aquaculturePopup =
</sp-card>
"""
// 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<BarentsWatchFishHealth>(
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
)
[<HookComponent>]
let aquacultureModal (currentTime: DateTime) (aquacultureId: int option) onClose =
let fishHealthJson, setFishHealth = Hook.useState<string> ""
@@ -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 =

View File

@@ -151,19 +151,23 @@ let urlFunc = // must return a lambda!
// </PropertyIsEqualTo>
// </And>
// </Filter>
// <fes:Filter>
// <fes:And>
// <fes:PropertyIsNotEqualTo>
// <fes:ValueReference>FiskeridirWFS:Akvakultur_-_Lokaliteter/FiskeridirWFS:status</fes:ValueReference>
// <fes:Literal>RETIRED</fes:Literal>
// </fes:PropertyIsNotEqualTo>
// <fes:BBOX>
// <fes:ValueReference>FiskeridirWFS:Akvakultur_-_Lokaliteter/FiskeridirWFS:shape</fes:ValueReference>
// <gml:Box srsName='EPSG:3857'>
// <gml:coordinates>{extent}</gml:coordinates>
// </gml:Box>
// </fes:BBOX>
// </fes:And>
// </fes:Filter>
// NOTE: THE XML IS CASE SENSITIVE!
let filter =
$"""
<fes:Filter>
<fes:And>
<fes:PropertyIsNotEqualTo>
<fes:ValueReference>FiskeridirWFS:Akvakultur_-_Lokaliteter/FiskeridirWFS:status</fes:ValueReference>
<fes:Literal>RETIRED</fes:Literal>
</fes:PropertyIsNotEqualTo>
<fes:BBOX><fes:ValueReference>FiskeridirWFS:Akvakultur_-_Lokaliteter/FiskeridirWFS:shape</fes:ValueReference><gml:Box srsName='EPSG:3857'><gml:coordinates>{extent}</gml:coordinates></gml:Box></fes:BBOX>
</fes:And>
</fes:Filter>
"""
$"""<fes:Filter><fes:And><fes:PropertyIsNotEqualTo><fes:ValueReference>FiskeridirWFS:Akvakultur_-_Lokaliteter/FiskeridirWFS:status</fes:ValueReference><fes:Literal>RETIRED</fes:Literal></fes:PropertyIsNotEqualTo><fes:BBOX><fes:ValueReference>FiskeridirWFS:Akvakultur_-_Lokaliteter/FiskeridirWFS:shape</fes:ValueReference><gml:Box srsName='EPSG:3857'><gml:coordinates>{extent}</gml:coordinates></gml:Box></fes:BBOX></fes:And></fes:Filter>"""
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

View File

@@ -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<BarentsWatchToken>(
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<BarentsWatchToken, string> =
Decode.Auto.fromString<BarentsWatchToken>(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<Refresh> ())
@@ -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 =

View File

@@ -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
}

View File

@@ -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

View File

@@ -12,6 +12,7 @@
<Compile Include="Saturn.Dapr.fs"/>
<Compile Include="MessageHub.fs"/>
<Compile Include="Auth.fs"/>
<Compile Include="BarentsWatch.fs" />
<Compile Include="Api.fs"/>
<Compile Include="PubSub.fs"/>
<Compile Include="Server.fs"/>

View File

@@ -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,7 +23,8 @@ type OidToken =
scope: string
}
type BarentsWatchToken = {
module BarentsWatch =
type Token = {
AccessToken: string
/// In seconds. Should be 3600s as per BarentsWatch docs
ExpiresIn: int
@@ -26,6 +32,15 @@ type BarentsWatchToken = {
Scope: string
}
let tokenDecode (str: string) : Result<Token, string> =
Decode.Auto.fromString<Token>(json = str, caseStrategy = CaseStrategy.SnakeCase)
let tokenDecoder =
Decode.Auto.generateDecoder<Token>(caseStrategy = CaseStrategy.SnakeCase)
let tokenEncode (token: Token) : string =
Encode.Auto.toString(value = token, caseStrategy = CaseStrategy.SnakeCase)
[<RequireQualifiedAccess>]
module Api =
let routeBuilder (typeName: string) (methodName: string) = $"/api/{typeName}/{methodName}"
@@ -47,7 +62,7 @@ module Api =
IsAuthenticated: unit -> Async<(string * string) option>
HasRoleOf: string -> Async<bool>
RefreshAccessToken: string -> Async<(string * string) option>
BarentsWatchToken: unit -> Async<BarentsWatchToken option>
BarentsWatchToken: unit -> Async<BarentsWatch.Token option>
}
type Services =
@@ -137,4 +152,3 @@ module Hub =
| InboxUnread of int
| Success
| Failure of string