@@ -2,6 +2,8 @@
22{-# LANGUAGE TypeOperators #-}
33{-# LANGUAGE OverloadedStrings #-}
44{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE FlexibleContexts #-}
6+
57
68module Lib
79 ( server,
@@ -28,13 +30,18 @@ import qualified Data.Set as S
2830import Data.CyclicBuffer
2931import Data.Foldable (fold)
3032import qualified Database.Beam.Postgres as P
33+-- import Network.Wai
34+import Network.EngineIO.Wai (toWaiApplication, waiAPI)
35+import Network.SocketIO
36+import Control.Monad.State
37+import Debug.Trace
3138
3239type API = "users" :> Capture "id" UserId :> Get '[JSON] User
3340 :<|> "users" :> "add" :> Capture "first" Text :> Capture "second" Text :> Get '[JSON] [User]
3441 :<|> "users" :> "all" :> Get '[JSON] [User]
3542 :<|> "posts" :> Capture "id" PostId :> Get '[JSON] D.Post
3643 :<|> "posts" :> "all" :> Get '[JSON] (TokenizedResponse Update)
37− :<|> "posts" :> "subscribe" :> Capture "token" Int :> WebSocketPending
44+ :<|> "posts" :> "subscribe" :> Raw --Capture "token" Int :> WebSocketPending
3845
3946createServer :: P.Connection -> IO (Server API)
4047createServer pConn = do
@@ -44,19 +51,22 @@ createServer pConn = do
4451 -- newUser cfg "Darya" "Aiphonovna"
4552 -- newUser cfg "Ilya" "Serverovich"
4653 -- newUser cfg "Константин" "Дудосерович"
47− return $ hoistServer server (createApp cfg) serverAPI
54+ subscribePostsEndpoint <- subscribePosts cfg
55+ let app = toWaiApplication subscribePostsEndpoint :: Application
56+ let sAPI = serverAPI app
57+ return $ hoistServer server (createApp cfg) sAPI
4858
4959server :: Proxy API
5060server = Proxy
5161
52−serverAPI :: ServerT API App
53−serverAPI =
54− user
55− :<|> createUserPath
56− :<|> allUsers
57− :<|> post
58− :<|> returnPosts
59− :<|> validateConnection
62+serverAPI :: Application -> ServerT API App
63+serverAPI app = user
64+ :<|> createUserPath
65+ :<|> allUsers
66+ :<|> post
67+ :<|> returnPosts
68+ :<|> pure app
69+ -- :<|> validateConnection
6070
6171createUserPath :: Text -> Text -> App [User]
6272createUserPath first second = do
@@ -70,34 +80,63 @@ returnPosts = do
7080 t <- getToken
7181 liftIO $ atomically $ TokenizedResponse <$> t <*> (pure $ flip Update (S.empty) $ S.fromList $ Prelude.map D.postId posts)
7282
73−invalidTokenError :: RejectRequest
74−invalidTokenError = defaultRejectRequest {
75− rejectCode = 498,
76− rejectMessage = "The supplied token is not valid" }
83+-- invalidTokenError :: RejectRequest
84+-- invalidTokenError = defaultRejectRequest {
85+-- rejectCode = 498,
86+-- rejectMessage = "The supplied token is not valid" }
7787
78−validateConnection :: Int -> PendingConnection -> App ()
79−validateConnection t pc = do
80− cfg <- ask
81− (cyc, token) <- liftIO $ atomically $ do
82− uu <- readTVar $ updates cfg
83− return (getFrom uu t, lastToken uu)
84− case cyc of
85− Nothing -> liftIO $ rejectRequestWith pc invalidTokenError
86− Just uu -> do
87− conn <- liftIO $ acceptRequest pc
88− liftIO $ sendTextData conn $ encode $ TokenizedResponse token $ fold uu
89− subscribe conn
90− return ()
91−
92−subscribe :: Connection -> App ()
93−subscribe conn = do
94− cfg <- ask
95− cId <- liftSTM $ addConnection cfg conn
96− -- liftIO $ sendDataMessage conn . Binary . encode $ D.TokenizedResponse 1 (Update (S.fromList [1, 2, 3]) (S.fromList [4, 2,6]))
97− liftIO $ flip finally (atomically $ removeConnection cfg cId) $ forever $ do
98− _ <- receiveDataMessage conn
99− return ()
100− return ()
88+-- validToken :: Token -> App Bool
89+-- validToken t pc = do
90+-- cfg <- ask
91+-- (cyc, token) <- liftIO $ atomically $ do
92+-- uu <- readTVar $ updates cfg
93+-- return (getFrom uu t, lastToken uu)
94+-- return $ case cyc of
95+-- Nothing -> False
96+-- Just uu -> True
97+
98+
99+
100+-- subscribePosts :: Config -> IO (m())
101+subscribePosts cfg = do
102+ handle <- initialize waiAPI $ subscriptionHandler cfg
103+ return handle
104+
105+-- subscriptionHandler :: MonadIO m => Config -> StateT RoutingTable (ReaderT Socket m) a
106+subscriptionHandler :: MonadState RoutingTable m => Config -> m ()
107+subscriptionHandler cfg = do
108+ on "test" $ \ (i::Int) -> do
109+ emit "test" $ Update (S.fromList [1,2,3]) (S.fromList [4,5,6])
110+
111+ appendDisconnectHandler $ do
112+ conn <- ask
113+ liftSTM $ removeConnection cfg conn
114+
115+
116+ on D.subscribeWithToken $ \ (t :: Token) -> do
117+ -- emit "subscribeWithToken" $ do
118+ conn <- ask
119+ (cyc, token) <- liftIO $ atomically $ do
120+ uu <- readTVar $ updates cfg
121+ return (getFrom uu t, lastToken uu)
122+ case cyc of
123+ Nothing -> emit D.subscribeWithToken False
124+ Just uu -> do
125+ emit D.postUpdates $ TokenizedResponse token $ fold uu
126+ sId <- liftSTM $ addConnection cfg conn
127+ emit subscribeWithToken True
128+
129+ -- if validToken t then do
130+ -- conn <- ask
131+ -- liftSTM $ do
132+ -- subscribe cfg conn
133+ -- uu <- readTVar $ updates cfg
134+ -- return (lastToken uu)
135+
136+ -- emit "postUpdates"
137+ -- else return false
101138
139+
140+
102141liftSTM :: MonadIO m => STM a -> m a
103142liftSTM = liftIO . atomically