diff --git a/sparrow.cabal b/sparrow.cabal --- a/sparrow.cabal +++ b/sparrow.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 957956460f140925a30f23e180c41fb3a32e4af820b0a5146fe91a3d3ec4d22c +-- hash: ebd4e11dfaadfc68bb56b0cd34cc4bf376b7430cd16a28ef8c69413463be699b name: sparrow -version: 0.0.1.1 +version: 0.0.1.2 synopsis: Unified streaming dependency management for web apps description: Please see the README on Github at category: Web @@ -57,7 +57,7 @@ , monad-control , monad-control-aligned , mtl - , nested-routes >=9.0.0 + , nested-routes >=9.0.0.1 , path , path-extra >=0.0.6 , pred-trie >=0.6.0.1 @@ -70,57 +70,10 @@ , unordered-containers , urlpath >=8.0.1 , uuid - , wai-middleware-content-type >=0.6.0 - , wai-transformers - , websockets >=0.12.3.1 - , websockets-simple >=0.1.1 - , wuss - default-language: Haskell2010 - -test-suite sparrow-test - type: exitcode-stdio-1.0 - main-is: Spec.hs - other-modules: - Paths_sparrow - hs-source-dirs: - test - ghc-options: -Wall -threaded -rtsopts -Wall -with-rtsopts=-N - build-depends: - aeson - , aeson-attoparsec - , async - , attoparsec - , attoparsec-uri >=0.0.4 - , base >=4.7 && <5 - , bytestring - , deepseq - , exceptions - , extractable-singleton - , hashable - , http-client - , http-client-tls - , http-types - , list-t - , monad-control - , monad-control-aligned - , mtl - , nested-routes >=9.0.0 - , path - , path-extra >=0.0.6 - , pred-trie >=0.6.0.1 - , sparrow - , stm - , strict - , text - , tmapchan - , tmapmvar >=0.0.4 - , transformers - , unordered-containers - , urlpath >=8.0.1 - , uuid - , wai-middleware-content-type >=0.6.0 - , wai-transformers - , websockets >=0.12.3.1 - , websockets-simple >=0.1.1 + , wai >=0.12.4 + , wai-middleware-content-type >=0.6.1.1 + , wai-transformers >=0.1.0 + , websockets >=0.12.4.0 + , websockets-simple >=0.1.2.1 , wuss default-language: Haskell2010 diff --git a/src/Web/Dependencies/Sparrow/Client.hs b/src/Web/Dependencies/Sparrow/Client.hs --- a/src/Web/Dependencies/Sparrow/Client.hs +++ b/src/Web/Dependencies/Sparrow/Client.hs @@ -30,10 +30,9 @@ import qualified Data.Aeson as Aeson import Data.Singleton.Class (Extractable (runSingleton)) import Data.UUID.V4 (nextRandom) -import qualified Data.HashMap.Strict as HM import Data.HashSet (HashSet) import qualified Data.HashSet as HS -import Control.Monad (forever, void) +import Control.Monad (forever) import Control.Monad.Trans (MonadTrans (lift)) import Control.Monad.Trans.Control (MonadBaseControl) import qualified Control.Monad.Trans.Control.Aligned as Aligned @@ -47,11 +46,11 @@ import Control.Concurrent.STM.TMapMVar (newTMapMVar) import Control.DeepSeq (NFData (rnf)) import Control.Exception (evaluate) -import Path (Path, Abs, Rel, File, toFilePath, parseRelFile, (), parent, dirname, absdir) +import Path (Abs, File, toFilePath, parseRelFile, (), parent, dirname, absdir) import Path.Extended (Location, fromPath, (<&>)) import System.IO.Unsafe (unsafePerformIO) -import Network.Wai.Trans (runClientAppT) import Network.WebSockets (runClient) +import Network.WebSockets.Trans (runClientAppT) import Network.WebSockets.Simple (WebSocketsApp (..), WebSocketsAppParams (..), toClientAppT, expBackoffStrategy) import Network.WebSockets.Simple.PingPong (pingPong) import Network.HTTP.Client (parseRequest, newManager, defaultManagerSettings, method, requestBody, responseBody, responseStatus, httpLbs, RequestBody (RequestBodyLBS)) @@ -167,8 +166,9 @@ f | tls = runSecureClient (T.unpack $ printURIAuthHost host) (Strict.maybe 80 fromIntegral port) (show loc) | otherwise = runClient (T.unpack $ printURIAuthHost host) (Strict.maybe 80 fromIntegral port) (show loc) - x' <- runM $ pingPong ((10^6) * 10) x -- every 10 seconds - f $ runClientAppT runM $ toClientAppT x' + x' <- runM (pingPong ((10^6) * 10) x) -- every 10 seconds + x'' <- runM (runClientAppT (toClientAppT x')) + f x'' ( toWSThread :: TMVar (Async ()) ) <- newEmptyTMVarIO diff --git a/src/Web/Dependencies/Sparrow/Client/Types.hs b/src/Web/Dependencies/Sparrow/Client/Types.hs --- a/src/Web/Dependencies/Sparrow/Client/Types.hs +++ b/src/Web/Dependencies/Sparrow/Client/Types.hs @@ -14,15 +14,13 @@ import Web.Dependencies.Sparrow.Types (WSIncoming, WithTopic, Topic) import Data.Aeson (Value) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HM import Control.Monad.Reader (ReaderT (..), MonadReader (..)) import Control.Monad.Trans (MonadTrans (..)) import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Writer (MonadWriter) import Control.Monad.State (MonadState) import Control.Monad.Catch (MonadCatch, MonadThrow, MonadMask, Exception) -import Control.Concurrent.STM (STM, atomically, TVar, readTVar, modifyTVar') +import Control.Concurrent.STM (STM, atomically) import Control.Concurrent.STM.TMapMVar (TMapMVar) import qualified Control.Concurrent.STM.TMapMVar as TMapMVar import GHC.Generics (Generic) diff --git a/src/Web/Dependencies/Sparrow/Server.hs b/src/Web/Dependencies/Sparrow/Server.hs --- a/src/Web/Dependencies/Sparrow/Server.hs +++ b/src/Web/Dependencies/Sparrow/Server.hs @@ -72,9 +72,11 @@ import qualified Control.Concurrent.STM.TMapChan.Hash as TMapChan import Control.Exception (evaluate) import Control.DeepSeq (NFData (rnf)) -import Network.Wai.Trans (MiddlewareT, strictRequestBody, queryString, websocketsOrT) +import Network.Wai (strictRequestBody, queryString) +import Network.Wai.Trans (MiddlewareT) import Network.Wai.Middleware.ContentType.Json (jsonOnly) import Network.WebSockets (defaultConnectionOptions) +import Network.WebSockets.Trans (websocketsOrT) import Network.WebSockets.Simple (WebSocketsApp (..), WebSocketsAppParams (..), toServerAppT) import Network.WebSockets.Simple.PingPong (pingPong) import Network.HTTP.Types (status400) @@ -165,7 +167,7 @@ -- register onOpen thread registerOnOpenThread env withSessionIDSessionID topic thread - (NR.action $ NR.post $ NR.json serverInitOut) app req resp + (NR.action $ NR.post $ \_ -> NR.json serverInitOut) app req resp -- | Match an individual dependency @@ -276,7 +278,7 @@ wsApp' <- pingPong ((10^6) * 10) wsApp -- every 10 seconds - (websocketsOrT runM defaultConnectionOptions (toServerAppT wsApp')) app req resp + (websocketsOrT defaultConnectionOptions (toServerAppT wsApp')) app req resp -- RESTful initIn -> initOut endpoints RouterT (modify' (<> NR.Tries httpTrie mempty mempty)) diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 --- a/test/Spec.hs +++ /dev/null @@ -1,2 +0,0 @@ -main :: IO () -main = putStrLn "Test suite not yet implemented"