Skip to content

Commit 35fbec6

Browse files
expedeexpede
committed
WIP cleaning up
1 parent 3037757 commit 35fbec6

File tree

3 files changed

+79
-60
lines changed
  • fission-core/library/Fission/Web
  • fission-web-server/library/Fission/Web/Server

3 files changed

+79
-60
lines changed

‎fission-core/library/Fission/Web/Async.hs

+3-2
Original file line numberDiff line numberDiff line change
@@ -83,8 +83,9 @@ waitAnySuccessCatchCancel asyncRefs = do
8383

8484
-- | Wait for all cluster peers to complete.
8585
waitAll :: MonadIO m => NonEmpty (Async (Either ClientError a)) -> m (NonEmpty (Either ClientError a))
86-
waitAll asyncRefs = liftIO $ forConcurrently asyncRefs \ref ->
87-
normalizeResult <$> waitCatch ref
86+
waitAll asyncRefs =
87+
liftIO $ forConcurrently asyncRefs \ref ->
88+
normalizeResult <$> waitCatch ref
8889

8990
normalizeResult :: Either SomeException (Either ClientError a) -> Either ClientError a
9091
normalizeResult = \case

‎fission-web-server/library/Fission/Web/Server/App/Modifier/Class.hs

+11
Original file line numberDiff line numberDiff line change
@@ -7,6 +7,7 @@ import qualified Network.IPFS.Add.Error as IPFS.Pin
77
import Network.IPFS.CID.Types
88
import qualified Network.IPFS.Get.Error as IPFS.Stat
99

10+
import Servant.API
1011
import Servant.Server
1112

1213
import Fission.Prelude hiding (on)
@@ -17,6 +18,9 @@ import Fission.URL
1718
import Fission.Web.Server.Error.ActionNotAuthorized.Types
1819
import Fission.Web.Server.Models
1920

21+
-- FIXME onlu the bytesrecieved; extract out!
22+
import Fission.Web.API.App.Update.Streaming.Types
23+
2024
type Errors' = OpenUnion
2125
'[ NotFound App
2226
, NotFound AppDomain
@@ -42,3 +46,10 @@ class Monad m => Modifier m where
4246
-> Bool -- ^ Flag: copy data (default yes)
4347
-> UTCTime -- ^ Now
4448
-> m (Either Errors' AppId)
49+
50+
setCIDStreaming ::
51+
UserId
52+
-> URL
53+
-> CID
54+
-> UTCTime
55+
-> m (SourceIO BytesReceived)

‎fission-web-server/library/Fission/Web/Server/Handler/App/Update.hs

+65-58
Original file line numberDiff line numberDiff line change
@@ -18,6 +18,7 @@ import Fission.Web.Server.Error as Web.Error
1818

1919
import qualified RIO.List as List
2020
import qualified RIO.NonEmpty as NonEmpty
21+
import qualified RIO.Text as Text
2122

2223
import Servant.Types.SourceT as S
2324
import qualified Streamly.Prelude as Streamly
@@ -71,79 +72,85 @@ updateStreaming ::
7172
=> ServerT API.App.StreamingUpdate m
7273
updateStreaming url newCID Authorization {about = Entity userId _} = do
7374
now <- currentTime
74-
status <- liftIO . newTVarIO $ Uploading 0 -- FIXME switch to mvar?
75+
status <- liftIO $ newTVarIO . Right $ BytesReceived 0
7576
pseudoStreams <- streamCluster $ (Streaming.client $ Proxy @PinComplete) newCID (Just True)
7677

7778
let (asyncRefs, chans) = NonEmpty.unzip pseudoStreams
78-
asyncListeners <- foo chans status
79-
80-
let
81-
source :: Streamly.SerialT IO (Maybe BytesReceived)
82-
source =
83-
Streamly.repeatM do
84-
sleepThread . Seconds $ Milli @Natural 500
85-
readTVarIO status >>= \case
86-
Uploading byteCount -> return . Just $ BytesReceived byteCount
87-
_ -> return $ Nothing
88-
89-
source
90-
|> Streamly.takeWhile isJust
79+
asyncListeners <- fanIn chans status
80+
81+
_ <- liftIO ( pure |> withAsync do
82+
results <- waitAll asyncRefs
83+
when (all isLeft results) $ atomically do
84+
let
85+
result' =
86+
case NonEmpty.head results of
87+
Right PinStatus {progress} ->
88+
case progress of
89+
Nothing -> Right $ BytesReceived 0
90+
Just bytes -> Right $ BytesReceived bytes
91+
92+
Left err
93+
-> Left err
94+
95+
writeTVar status result')
96+
97+
Streamly.repeatM (readTVarIO status)
98+
|> Streamly.delay 0.500
99+
|> Streamly.takeWhile isRight
91100
|> Streamly.finally do
92101
forM_ asyncListeners cancel
93102
forM_ asyncRefs cancel
103+
readTVarIO status
104+
|> Streamly.take 1
105+
|> Streamly.takeWhile isLeft
106+
|> asSerial
94107
|> toSourceIO
95-
|> mapStepT go
108+
|> mapStepT simplify
96109
|> pure
97110

98-
where
99-
go :: Monad m => StepT m (Maybe BytesReceived) -> StepT m BytesReceived
100-
go = \case
101-
S.Yield Nothing more -> go more
102-
S.Yield (Just byteCount) more -> S.Yield byteCount (go more)
111+
simplify :: Monad m => StepT m (Either ClientError BytesReceived) -> StepT m BytesReceived
112+
simplify = \case
113+
S.Yield (Right byteCount) more -> S.Yield byteCount (simplify more)
114+
S.Yield (Left err) _ -> S.Error (show err)
103115

104-
S.Skip more -> go more
105-
S.Effect action -> S.Effect $ fmap go action
106-
S.Error msg -> S.Error msg
107-
S.Stop -> S.Stop
116+
S.Skip more -> simplify more
117+
S.Effect action -> S.Effect $ fmap simplify action
118+
S.Error msg -> S.Error msg
119+
S.Stop -> S.Stop
108120

109-
foo ::
121+
fanIn ::
110122
MonadIO m
111123
=> NonEmpty (TChan (Either ClientError PinStatus))
112-
-> TVar UploadStatus
124+
-> TVar (Either ClientError BytesReceived)
113125
-> m (NonEmpty (Async ()))
114-
foo chans statusVar =
115-
forM chans \statusChan ->
116-
liftIO $ withAsync (atomically $ fanIn statusChan statusVar) pure
117-
118-
fanIn :: TChan (Either ClientError PinStatus) -> TVar UploadStatus -> STM ()
119-
fanIn channel status = go
120-
where
121-
go :: STM ()
122-
go =
123-
readTVar status >>= \case
124-
Done ->
125-
return ()
126-
127-
Failed ->
126+
fanIn chans statusVar =
127+
forM chans \statusChan -> do
128+
liftIO $ withAsync (atomically $ reportBytes statusChan statusVar) pure
129+
130+
asSerial :: Streamly.Serial a -> Streamly.Serial a
131+
asSerial a = a
132+
133+
reportBytes ::
134+
TChan (Either ClientError PinStatus)
135+
-> TVar (Either ClientError BytesReceived)
136+
-> STM ()
137+
reportBytes channel status =
138+
readTVar status >>= \case
139+
Left _ ->
140+
return ()
141+
142+
Right (BytesReceived lastMax) ->
143+
readTChan channel >>= \case
144+
Left _ ->
128145
return ()
129146

130-
Uploading lastMax ->
131-
readTChan channel >>= \case
132-
Left err ->
133-
undefined -- FIXME
134-
135-
Right PinStatus {progress} ->
136-
case progress of
137-
Nothing ->
138-
return ()
139-
140-
Just bytesHere -> do -- FIXME I think it's bytes? Maybe blocks?
141-
when (bytesHere > lastMax) do
142-
writeTVar status $ Uploading bytesHere
147+
Right PinStatus {progress} ->
148+
case progress of
149+
Nothing ->
150+
return ()
143151

144-
go
152+
Just bytesHere -> do -- FIXME I think it's bytes? Maybe blocks?
153+
when (bytesHere > lastMax) do
154+
writeTVar status . Right $ BytesReceived bytesHere
145155

146-
data UploadStatus
147-
= Failed
148-
| Uploading Natural
149-
| Done
156+
reportBytes channel status

0 commit comments

Comments
 (0)