git.iko.soy/rowtype-yoga/purescript-tauri
on main help sign in
rowtype-yoga/purescript-tauri/src/Tauri/Control.purs
137 lines 5.6 kB history raw
1-- | Authenticated localhost transport for an application's JSON-RPC handler.
2-- | Register tauri-plugin-local-control and grant local-control:allow-start,
3-- | local-control:allow-stop, local-control:allow-reply and the core event
4-- | listen/unlisten permissions to the owning webview only.
5module Tauri.Control (serve) where
7import Prelude
9import Control.Alt ((<|>))
10import Data.Array as Array
11import Data.DateTime.Instant (unInstant)
12import Data.Either (Either(..))
13import Data.Foldable (traverse_)
14import Effect (Effect)
15import Effect.Aff (Aff, Fiber, Milliseconds(..), apathize, attempt, delay, error, finally, generalBracket, joinFiber, killFiber, launchAff_, launchSuspendedAff, parallel, sequential)
16import Effect.Class (liftEffect)
17import Effect.Now (now)
18import Effect.Ref as Ref
19import Promise (Promise)
20import Promise.Aff (toAffE)
21import Tauri.Internal.Resource (acquireDisposer, once)
23type Request =
24 { session :: String
25 , id :: String
26 , kind :: String
27 , body :: String
28 , deadline :: Number
29 }
31type Running = { id :: String, fiber :: Fiber Unit }
33data SessionState = Starting (Array Request) | Active String | Stopped
35derive instance Eq SessionState
37type Resources =
38 { session :: Ref.Ref SessionState
39 , running :: Ref.Ref (Array Running)
40 , dispose :: Effect Unit
41 }
43clock :: Effect Number
44clock = do
45 Milliseconds value <- unInstant <$> now
46 pure value
48send :: Request -> String -> String -> Aff Boolean
49send request action body = toAffE $ replyImpl
50 { session: request.session, id: request.id, action, body }
52-- | Subscribe before publishing discovery. The returned, idempotent cleanup
53-- | immediately disables dispatch/unsubscribes, stops the native server, and
54-- | cancels pending handler fibers. Acquisition cancellation/failure cleans up
55-- | even when an uncancellable native registration finishes later.
56-- |
57-- | Requests have a native deadline and a native claim handshake, so an expired
58-- | queued event cannot start a handler. Active handlers are cancelled at their
59-- | deadline or when their HTTP request/session ends. Handlers must honour Aff
60-- | cancellation; already-completed synchronous effects cannot be rolled back.
61serve :: (String -> Aff String) -> Aff (Effect Unit)
62serve handler = generalBracket acquire
63 { killed: \_ resources -> liftEffect resources.dispose
64 , failed: \_ resources -> liftEffect resources.dispose
65 , completed: \_ _ -> pure unit
66 }
67 \resources -> generalBracket (toAffE startImpl)
68 { killed: \_ session -> apathize $ toAffE $ stopImpl session
69 , failed: \_ session -> apathize $ toAffE $ stopImpl session
70 , completed: \_ _ -> pure unit
71 }
72 \session -> do
73 liftEffect do
74 previous <- Ref.read resources.session
75 Ref.write (Active session) resources.session
76 case previous of
77 Starting pending -> traverse_ (receive resources.session resources.running) pending
78 _ -> pure unit
79 pure resources.dispose
80 where
81 acquire :: Aff Resources
82 acquire = do
83 session <- liftEffect $ Ref.new (Starting [])
84 running <- liftEffect $ Ref.new []
85 unlisten <- acquireDisposer $ listenImpl $ receive session running
86 dispose <- liftEffect $ once do
87 previous <- Ref.read session
88 Ref.write Stopped session
89 unlisten
90 fibers <- Ref.read running
91 Ref.write [] running
92 case previous of
93 Active id -> launchAff_ $ apathize $ toAffE $ stopImpl id
94 _ -> pure unit
95 traverse_ (\item -> launchAff_ $ apathize $ killFiber (error "Control stopped") item.fiber) fibers
96 pure { session, running, dispose }
98 receive session running request = do
99 current <- Ref.read session
100 case current of
101 -- Native discovery can be read before the start reply reaches this
102 -- webview. Retain those events until their session has been adopted.
103 Starting pending -> Ref.write (Starting (Array.snoc pending request)) session
104 _ -> when (current == Active request.session) do
105 fibers <- Ref.read running
106 if request.kind == "cancel" then
107 traverse_
108 (\item -> launchAff_ $ apathize $ killFiber (error "Control request cancelled") item.fiber)
109 (Array.filter (\item -> item.id == request.id) fibers)
110 else when (request.kind == "request" && not (Array.any (\item -> item.id == request.id) fibers)) do
111 time <- clock
112 when (time < request.deadline) do
113 fiber <- launchSuspendedAff $ finally
114 (liftEffect $ Ref.modify_ (Array.filter (\item -> item.id /= request.id)) running)
115 ( apathize $ sequential $
116 parallel (dispatch session request)
117 <|> parallel (delay $ Milliseconds $ request.deadline - time)
118 )
119 Ref.modify_ (\items -> Array.snoc items { id: request.id, fiber }) running
120 launchAff_ $ apathize $ joinFiber fiber
122 dispatch session request = do
123 claimed <- send request "claim" ""
124 current <- liftEffect $ Ref.read session
125 time <- liftEffect clock
126 when (claimed && current == Active request.session && time < request.deadline) do
127 response <- attempt $ handler request.body
128 case response of
129 Left _ -> void $ send request "fail" ""
130 Right body -> void $ send request "reply" body
132foreign import listenImpl :: (Request -> Effect Unit) -> Effect (Promise (Effect Unit))
133foreign import startImpl :: Effect (Promise String)
134foreign import stopImpl :: String -> Effect (Promise Unit)
135foreign import replyImpl
136 :: { session :: String, id :: String, action :: String, body :: String }
137 -> Effect (Promise Boolean)