From 6f3733f6d5fd535fbcfdbd45011fc557fdd7d67a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Oskar=20Wickstr=C3=B6m?= Date: Tue, 14 Nov 2017 22:03:03 +0100 Subject: [PATCH 1/3] Upgrade to purescript-aff v4 --- bower.json | 10 +++--- src/Hyper/Form.purs | 1 + src/Hyper/Node/Server.purs | 53 +++++++++++++++++----------- src/Hyper/Node/Session/InMemory.purs | 13 +++---- 4 files changed, 46 insertions(+), 31 deletions(-) diff --git a/bower.json b/bower.json index 33986b5..dee8573 100644 --- a/bower.json +++ b/bower.json @@ -23,20 +23,20 @@ "purescript-transformers": "^3.2.0", "purescript-node-http": "^4.0.0", "purescript-media-types": "^3.0.0", - "purescript-node-fs-aff": "^4.0.0", + "purescript-node-fs-aff": "^5.0.0", "purescript-generics-rep": "^5.0.0", "purescript-proxy": "^2.0.0", "purescript-argonaut": "^3.0.0", "purescript-arrays": "^4.0.1", "purescript-argonaut-codecs": "^3.0.0", "purescript-http-methods": "^3.0.0", - "purescript-indexed-monad": "^0.2.0", + "purescript-indexed-monad": "^0.3.0", "purescript-smolder": "^7.0.0", - "purescript-aff": "^3.1.0" + "purescript-aff": "^4.0.0" }, "devDependencies": { "purescript-psci-support": "^3.0.0", - "purescript-spec": "^0.13.0", - "purescript-spec-discovery": "^0.5.0" + "purescript-spec": "^2.0.0", + "purescript-spec-discovery": "^2.0.0" } } diff --git a/src/Hyper/Form.purs b/src/Hyper/Form.purs index 9b2f599..bd6b36a 100644 --- a/src/Hyper/Form.purs +++ b/src/Hyper/Form.purs @@ -38,6 +38,7 @@ derive instance genericForm :: Generic Form derive newtype instance eqForm :: Eq Form derive newtype instance ordForm :: Ord Form derive newtype instance showForm :: Show Form +derive newtype instance semigroupForm :: Semigroup Form derive newtype instance monoidForm :: Monoid Form diff --git a/src/Hyper/Node/Server.purs b/src/Hyper/Node/Server.purs index 60462ca..ceb81ef 100644 --- a/src/Hyper/Node/Server.purs +++ b/src/Hyper/Node/Server.purs @@ -10,37 +10,38 @@ module Hyper.Node.Server ) where import Prelude -import Data.HTTP.Method as Method -import Data.Int as Int -import Data.StrMap as StrMap -import Node.Buffer as Buffer -import Node.HTTP as HTTP -import Node.Stream as Stream + import Control.IxMonad (ipure, (:*>), (:>>=)) -import Control.Monad.Aff (Aff, launchAff, makeAff, runAff) -import Control.Monad.Aff.AVar (putVar, takeVar, modifyVar, makeVar', AVAR, makeVar) +import Control.Monad.Aff (Aff, launchAff, launchAff_, makeAff, nonCanceler, runAff_) +import Control.Monad.Aff.AVar (AVAR, makeEmptyVar, makeVar, putVar, takeVar) import Control.Monad.Aff.Class (class MonadAff, liftAff) import Control.Monad.Eff (Eff) import Control.Monad.Eff.Class (class MonadEff, liftEff) import Control.Monad.Eff.Exception (EXCEPTION, catchException, error) import Control.Monad.Error.Class (throwError) import Data.Either (Either(..), either) +import Data.HTTP.Method as Method +import Data.Int as Int import Data.Lazy (defer) import Data.Maybe (Maybe(..)) import Data.Newtype (unwrap) +import Data.StrMap as StrMap import Data.Tuple (Tuple(..)) import Hyper.Conn (Conn) import Hyper.Middleware (Middleware, evalMiddleware, lift') import Hyper.Middleware.Class (getConn, modifyConn) -import Hyper.Node.Server.Options as Hyper.Node.Server.Options import Hyper.Node.Server.Options (Options) +import Hyper.Node.Server.Options as Hyper.Node.Server.Options import Hyper.Request (class ReadableBody, class Request, class StreamableBody, RequestData, parseUrl, readBody) import Hyper.Response (class ResponseWritable, class Response, ResponseEnded, StatusLineOpen) import Hyper.Status (Status(..)) import Node.Buffer (BUFFER, Buffer) +import Node.Buffer as Buffer import Node.Encoding (Encoding(..)) import Node.HTTP (HTTP) +import Node.HTTP as HTTP import Node.Stream (Stream, Writable) +import Node.Stream as Stream data HttpRequest @@ -62,15 +63,17 @@ newtype NodeResponse m e writeString :: forall m e. MonadAff e m => Encoding -> String -> NodeResponse m e writeString enc str = NodeResponse $ \w -> liftAff (makeAff (writeAsAff w)) where - writeAsAff w fail succeed = - Stream.writeString w enc str (succeed unit) >>= + writeAsAff w k = do + Stream.writeString w enc str (k (pure unit)) >>= if _ - then succeed unit - else fail (error "Failed to write string to response") + then k (pure unit) + else k (throwError (error "Failed to write string to response")) + pure nonCanceler write :: forall m e. MonadAff e m => Buffer -> NodeResponse m e write buffer = NodeResponse $ \w -> - liftAff (makeAff (\fail succeed -> void $ Stream.write w buffer (succeed unit))) + liftAff (makeAff (\k -> Stream.write w buffer (k (pure unit)) + *> pure nonCanceler)) instance stringNodeResponse :: (MonadAff e m) => ResponseWritable (NodeResponse m e) m String where toResponse = ipure <<< writeString UTF8 @@ -92,8 +95,8 @@ readBodyAsBuffer -> Aff (http :: HTTP, avar :: AVAR, buffer :: BUFFER | e) Buffer readBodyAsBuffer (HttpRequest request _) = do let stream = HTTP.requestAsStream request - bodyResult <- makeVar - chunks <- makeVar' [] + bodyResult <- makeEmptyVar + chunks <- makeVar [] fillResult <- liftEff $ catchException (pure <<< Left) (Right <$> fillBody stream chunks bodyResult) -- Await the body, or an error. @@ -104,16 +107,19 @@ readBodyAsBuffer (HttpRequest request _) = do fillBody stream chunks bodyResult = do -- Append all chunks to the body buffer. Stream.onData stream \chunk -> - void (launchAff (modifyVar (_ <> [chunk]) chunks)) + let modification = do + v <- takeVar chunks + putVar (v <> [chunk]) chunks + in void (launchAff modification) -- Complete with `Left` on error. Stream.onError stream $ - void <<< launchAff <<< putVar bodyResult <<< Left + launchAff_ <<< flip putVar bodyResult <<< Left -- Complete with `Right` on successful "end" event. Stream.onEnd stream $ void $ launchAff $ takeVar chunks >>= concat' >>= (pure <<< Right) - >>= putVar bodyResult + >>= flip putVar bodyResult concat' = liftEff <<< Buffer.concat instance readableBodyHttpRequestString :: (Monad m, MonadAff (http :: HTTP, avar :: AVAR, buffer :: BUFFER | e) m) @@ -250,7 +256,14 @@ runServer' options components runM middleware = do , response: HttpResponse response , components: components } - in conn # evalMiddleware middleware # runM # runAff options.onRequestError (const $ pure unit) # void + callback = + case _ of + Left err -> options.onRequestError err + Right _ -> pure unit + in conn + # evalMiddleware middleware + # runM + # runAff_ callback runServer :: forall e c c'. diff --git a/src/Hyper/Node/Session/InMemory.purs b/src/Hyper/Node/Session/InMemory.purs index b57b699..a1d27fd 100644 --- a/src/Hyper/Node/Session/InMemory.purs +++ b/src/Hyper/Node/Session/InMemory.purs @@ -1,12 +1,13 @@ module Hyper.Node.Session.InMemory where import Prelude -import Data.Map as Map + import Control.Monad.Aff (Aff) -import Control.Monad.Aff.AVar (AVAR, AVar, makeVar', modifyVar, peekVar) +import Control.Monad.Aff.AVar (AVAR, AVar, makeVar, putVar, readVar) import Control.Monad.Aff.Class (class MonadAff, liftAff) import Control.Monad.Aff.Console (CONSOLE, log) import Data.Map (Map) +import Data.Map as Map import Data.Newtype (unwrap) import Hyper.Session (class SessionStore, SessionID(..)) @@ -25,19 +26,19 @@ instance sessionStoreInMemorySessionStore :: ( Monad m get (InMemorySessionStore var) id = liftAff do log ("Looking up session: " <> show (unwrap id)) - Map.lookup id <$> peekVar var + Map.lookup id <$> readVar var put (InMemorySessionStore var) id session = do liftAff do log ("Saving session: " <> unwrap id) - modifyVar (Map.insert id session) var + Map.insert id session <$> readVar var >>= flip putVar var delete (InMemorySessionStore var) id = do liftAff do log ("Deleting session: " <> unwrap id) - modifyVar (Map.delete id) var + Map.delete id <$> readVar var >>= flip putVar var newInMemorySessionStore :: forall e session . Aff ( avar ∷ AVAR | e ) (InMemorySessionStore session) -newInMemorySessionStore = InMemorySessionStore <$> makeVar' Map.empty +newInMemorySessionStore = InMemorySessionStore <$> makeVar Map.empty From a1aab033010694285bef917f36edecd24ab01e77 Mon Sep 17 00:00:00 2001 From: Jimmy Hu Date: Tue, 5 Dec 2017 00:38:55 +0800 Subject: [PATCH 2/3] Fix InMemory put and delete bug --- src/Hyper/Node/Session/InMemory.purs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Hyper/Node/Session/InMemory.purs b/src/Hyper/Node/Session/InMemory.purs index a1d27fd..6ed7197 100644 --- a/src/Hyper/Node/Session/InMemory.purs +++ b/src/Hyper/Node/Session/InMemory.purs @@ -3,7 +3,7 @@ module Hyper.Node.Session.InMemory where import Prelude import Control.Monad.Aff (Aff) -import Control.Monad.Aff.AVar (AVAR, AVar, makeVar, putVar, readVar) +import Control.Monad.Aff.AVar (AVAR, AVar, makeVar, putVar, readVar, takeVar) import Control.Monad.Aff.Class (class MonadAff, liftAff) import Control.Monad.Aff.Console (CONSOLE, log) import Data.Map (Map) @@ -31,12 +31,12 @@ instance sessionStoreInMemorySessionStore :: ( Monad m put (InMemorySessionStore var) id session = do liftAff do log ("Saving session: " <> unwrap id) - Map.insert id session <$> readVar var >>= flip putVar var + Map.insert id session <$> takeVar var >>= flip putVar var delete (InMemorySessionStore var) id = do liftAff do log ("Deleting session: " <> unwrap id) - Map.delete id <$> readVar var >>= flip putVar var + Map.delete id <$> takeVar var >>= flip putVar var newInMemorySessionStore :: forall e session From 821ffeae6524cb83b728319c6c18b561ad3e6413 Mon Sep 17 00:00:00 2001 From: Jimmy Hu Date: Tue, 5 Dec 2017 23:42:44 +0800 Subject: [PATCH 3/3] replace AVar with Ref and fix session id bug --- bower.json | 4 +++- examples/Sessions.purs | 7 +++--- src/Hyper/Node/Session/InMemory.js | 5 ++++ src/Hyper/Node/Session/InMemory.purs | 36 +++++++++++++++------------- 4 files changed, 32 insertions(+), 20 deletions(-) create mode 100644 src/Hyper/Node/Session/InMemory.js diff --git a/bower.json b/bower.json index dee8573..fb8d923 100644 --- a/bower.json +++ b/bower.json @@ -32,7 +32,9 @@ "purescript-http-methods": "^3.0.0", "purescript-indexed-monad": "^0.3.0", "purescript-smolder": "^7.0.0", - "purescript-aff": "^4.0.0" + "purescript-aff": "^4.0.0", + "purescript-random": "^3.0.0", + "purescript-refs": "^3.0.0" }, "devDependencies": { "purescript-psci-support": "^3.0.0", diff --git a/examples/Sessions.purs b/examples/Sessions.purs index 2c4d148..329129f 100644 --- a/examples/Sessions.purs +++ b/examples/Sessions.purs @@ -3,12 +3,13 @@ module Examples.Sessions where import Prelude import Control.IxMonad ((:*>), (:>>=)) import Control.Monad.Aff (launchAff) -import Control.Monad.Aff.AVar (AVAR) import Control.Monad.Aff.Console (log) import Control.Monad.Eff (Eff) import Control.Monad.Eff.Class (liftEff) import Control.Monad.Eff.Console (CONSOLE) import Control.Monad.Eff.Exception (EXCEPTION) +import Control.Monad.Eff.Random (RANDOM) +import Control.Monad.Eff.Ref (REF) import Data.Maybe (Maybe(..)) import Data.MediaType.Common (textHTML) import Hyper.Cookies (cookies) @@ -23,9 +24,9 @@ import Node.HTTP (HTTP) newtype MySession = MySession { userId :: Int } -main :: forall e. Eff (exception :: EXCEPTION, avar :: AVAR, console :: CONSOLE, http :: HTTP | e) Unit +main :: forall e. Eff (exception :: EXCEPTION, ref :: REF, console :: CONSOLE, http :: HTTP, random ::RANDOM | e) Unit main = void $ launchAff do - store <- newInMemorySessionStore + store <- liftEff newInMemorySessionStore liftEff (runServer defaultOptionsWithLogging (components store) app) where components store = diff --git a/src/Hyper/Node/Session/InMemory.js b/src/Hyper/Node/Session/InMemory.js new file mode 100644 index 0000000..f569b30 --- /dev/null +++ b/src/Hyper/Node/Session/InMemory.js @@ -0,0 +1,5 @@ +"use strict"; + +exports.generatedSessionID = function() { + return String((new Date()).getTime() + Math.random()); +}; diff --git a/src/Hyper/Node/Session/InMemory.purs b/src/Hyper/Node/Session/InMemory.purs index 6ed7197..102546b 100644 --- a/src/Hyper/Node/Session/InMemory.purs +++ b/src/Hyper/Node/Session/InMemory.purs @@ -2,43 +2,47 @@ module Hyper.Node.Session.InMemory where import Prelude -import Control.Monad.Aff (Aff) -import Control.Monad.Aff.AVar (AVAR, AVar, makeVar, putVar, readVar, takeVar) -import Control.Monad.Aff.Class (class MonadAff, liftAff) -import Control.Monad.Aff.Console (CONSOLE, log) +import Control.Monad.Eff.Class (class MonadEff, liftEff) +import Control.Monad.Eff (Eff) +import Control.Monad.Eff.Console (CONSOLE, log) +import Control.Monad.Eff.Random (RANDOM) +import Control.Monad.Eff.Ref (REF, Ref, modifyRef, newRef, readRef) import Data.Map (Map) import Data.Map as Map import Data.Newtype (unwrap) import Hyper.Session (class SessionStore, SessionID(..)) -data InMemorySessionStore session = InMemorySessionStore (AVar (Map SessionID session)) +data InMemorySessionStore session = InMemorySessionStore (Ref (Map SessionID session)) + +foreign import generatedSessionID ::forall eff. Eff (random :: RANDOM | eff) String instance sessionStoreInMemorySessionStore :: ( Monad m - , MonadAff (avar :: AVAR, console :: CONSOLE | e) m + , MonadEff (ref:: REF, console :: CONSOLE, random :: RANDOM | e) m ) => SessionStore (InMemorySessionStore session) m session where - newSessionID _ = - pure (SessionID "new-id") + newSessionID _ = do + id <- liftEff generatedSessionID + pure (SessionID id) get (InMemorySessionStore var) id = - liftAff do + liftEff do log ("Looking up session: " <> show (unwrap id)) - Map.lookup id <$> readVar var + Map.lookup id <$> readRef var put (InMemorySessionStore var) id session = do - liftAff do + liftEff do log ("Saving session: " <> unwrap id) - Map.insert id session <$> takeVar var >>= flip putVar var + modifyRef var $ Map.insert id session delete (InMemorySessionStore var) id = do - liftAff do + liftEff do log ("Deleting session: " <> unwrap id) - Map.delete id <$> takeVar var >>= flip putVar var + modifyRef var $ Map.delete id newInMemorySessionStore :: forall e session - . Aff ( avar ∷ AVAR | e ) (InMemorySessionStore session) -newInMemorySessionStore = InMemorySessionStore <$> makeVar Map.empty + . Eff ( ref∷ REF | e ) (InMemorySessionStore session) +newInMemorySessionStore = InMemorySessionStore <$> newRef Map.empty