diff --git a/bower.json b/bower.json
index fb8d923..dfffcde 100644
--- a/bower.json
+++ b/bower.json
@@ -34,7 +34,9 @@
"purescript-smolder": "^7.0.0",
"purescript-aff": "^4.0.0",
"purescript-random": "^3.0.0",
- "purescript-refs": "^3.0.0"
+ "purescript-refs": "^3.0.0",
+ "purescript-simple-json": "^1.1.0",
+ "purescript-crypto": "^0.2.0"
},
"devDependencies": {
"purescript-psci-support": "^3.0.0",
diff --git a/src/Hyper/Node/Session/Cookie.js b/src/Hyper/Node/Session/Cookie.js
new file mode 100644
index 0000000..59fefa0
--- /dev/null
+++ b/src/Hyper/Node/Session/Cookie.js
@@ -0,0 +1,7 @@
+"use strict";
+
+var crypto = require('crypto')
+
+exports.randString = function () {
+ return crypto.randomBytes(32).toString('hex');
+}
diff --git a/src/Hyper/Node/Session/Cookie.purs b/src/Hyper/Node/Session/Cookie.purs
new file mode 100644
index 0000000..b626756
--- /dev/null
+++ b/src/Hyper/Node/Session/Cookie.purs
@@ -0,0 +1,63 @@
+module Hyper.Node.Session.Cookie where
+import Prelude
+
+import Control.Monad.Eff (Eff)
+import Control.Monad.Eff.Class (class MonadEff, liftEff)
+import Data.Either (hush)
+import Data.Maybe (Maybe(..))
+import Data.Newtype (class Newtype, unwrap)
+import Data.String (Pattern(..), joinWith, split)
+import Hyper.Session (SessionID(..), class SessionStore)
+import Node.Buffer (BUFFER)
+import Node.Crypto (CRYPTO)
+import Node.Crypto.Cipher as Cipher
+import Node.Crypto.Decipher as Decipher
+import Node.Crypto.Hash as Hash
+import Node.Crypto.Hmac as Hmac
+import Simple.JSON (class ReadForeign, class WriteForeign, readJSON, writeJSON)
+
+foreign import randString :: forall e. Eff (buffer :: BUFFER, crypto :: CRYPTO | e) String
+
+type Key = { hmacKey :: String, cipherKey :: String }
+
+mkSecret :: forall e m. MonadEff (buffer :: BUFFER, crypto :: CRYPTO | e) m => m Key
+mkSecret = do
+ hmacKey <- liftEff randString
+ cipherKey <- liftEff randString
+ pure $ { hmacKey, cipherKey }
+
+newtype CookieStore session = CookieStore Key
+derive instance newtypeCookieStore :: Newtype (CookieStore session) _
+
+encrypt :: forall e m. MonadEff (crypto :: CRYPTO, buffer :: BUFFER | e) m => Key -> String -> m String
+encrypt { cipherKey, hmacKey } text = do
+ encrypted <- liftEff $ Cipher.hex Cipher.AES256 cipherKey text
+ hmac <- liftEff $ Hmac.hex Hash.SHA512 hmacKey encrypted
+ pure $ joinWith "," [hmac, encrypted]
+
+decrypt :: forall e m. MonadEff (crypto :: CRYPTO, buffer :: BUFFER | e) m => Key -> String -> m (Maybe String)
+decrypt { cipherKey, hmacKey } text = case split (Pattern ",") text of
+ [hmac, encrypted] ->
+ let
+ calcHmac = liftEff $ Hmac.hex Hash.SHA512 hmacKey encrypted
+ decryptWhen hmac' | hmac == hmac' =
+ Just <$> liftEff (Decipher.fromHex Cipher.AES256 cipherKey encrypted)
+ decryptWhen _ = pure Nothing
+ in
+ calcHmac >>= decryptWhen
+ _ -> pure Nothing
+
+instance sessionStoreCookieStore ::
+ ( ReadForeign session
+ , WriteForeign session
+ , Monad m
+ , MonadEff (buffer :: BUFFER, crypto :: CRYPTO | e) m
+ ) =>
+ SessionStore (CookieStore session) m session where
+ newSessionID _ = pure $ SessionID "new-id"
+ get store id = do
+ text <- decrypt (unwrap store) $ unwrap id
+ pure $ text >>= readJSON >>> hush
+ put store _ session = SessionID <$> encrypt (unwrap store) json
+ where json = writeJSON session
+ delete store _ = pure unit
diff --git a/src/Hyper/Node/Session/InMemory.purs b/src/Hyper/Node/Session/InMemory.purs
index 102546b..f4f4492 100644
--- a/src/Hyper/Node/Session/InMemory.purs
+++ b/src/Hyper/Node/Session/InMemory.purs
@@ -36,6 +36,7 @@ instance sessionStoreInMemorySessionStore :: ( Monad m
liftEff do
log ("Saving session: " <> unwrap id)
modifyRef var $ Map.insert id session
+ pure id
delete (InMemorySessionStore var) id = do
liftEff do
diff --git a/src/Hyper/Session.purs b/src/Hyper/Session.purs
index 8fdaa1a..969b5cd 100644
--- a/src/Hyper/Session.purs
+++ b/src/Hyper/Session.purs
@@ -11,16 +11,16 @@ module Hyper.Session
) where
import Prelude
-import Data.NonEmpty as NonEmpty
-import Data.StrMap as StrMap
-import Hyper.Cookies as Cookies
import Control.IxMonad (ibind, ipure, (:>>=))
import Data.Either (Either(..))
import Data.Maybe (Maybe(Nothing, Just), maybe)
import Data.Newtype (class Newtype, unwrap)
+import Data.NonEmpty as NonEmpty
import Data.StrMap (StrMap)
+import Data.StrMap as StrMap
import Hyper.Conn (Conn)
import Hyper.Cookies (setCookie)
+import Hyper.Cookies as Cookies
import Hyper.Middleware (Middleware, lift')
import Hyper.Middleware.Class (getConn)
import Hyper.Response (class Response, HeadersOpen)
@@ -34,7 +34,7 @@ derive instance newtypeSessionID :: Newtype SessionID _
class SessionStore store m session | store -> m, store -> session where
newSessionID :: store -> m SessionID
get :: store -> SessionID -> m (Maybe session)
- put :: store -> SessionID -> session -> m Unit
+ put :: store -> SessionID -> session -> m SessionID
delete :: store -> SessionID -> m Unit
type Sessions s = { key :: String, store :: s }
@@ -125,8 +125,8 @@ saveSession session = do
| unwrap id' /= "" -> ipure id'
| otherwise -> lift' (newSessionID conn.components.sessions.store)
Nothing -> lift' (newSessionID conn.components.sessions.store)
- lift' (put conn.components.sessions.store sessionId session)
- setCookie conn.components.sessions.key (unwrap sessionId)
+ sessionId' <- lift' (put conn.components.sessions.store sessionId session)
+ setCookie conn.components.sessions.key (unwrap sessionId')
where
bind = ibind
@@ -148,6 +148,6 @@ deleteSession
Unit
deleteSession = do
conn <- getConn
- _ <- maybe (ipure unit) (lift' <<< delete conn.components.sessions.store) <$> currentSessionID
+ _ <- maybe (ipure unit) (lift' <<< delete conn.components.sessions.store) =<< currentSessionID
-- TODO: Better delete?
setCookie conn.components.sessions.key ""
diff --git a/test/Hyper/SessionSpec.purs b/test/Hyper/SessionSpec.purs
new file mode 100644
index 0000000..430ae4f
--- /dev/null
+++ b/test/Hyper/SessionSpec.purs
@@ -0,0 +1,126 @@
+module Hyper.SessionSpec where
+
+import Prelude
+import Control.IxMonad ((:*>))
+import Control.Monad.Aff (Aff)
+import Control.Monad.Aff.Class (liftAff)
+import Control.Monad.Eff.Class (liftEff)
+import Control.Monad.Eff.Console (CONSOLE)
+import Control.Monad.Eff.Random (RANDOM)
+import Control.Monad.Eff.Ref (REF)
+import Control.Monad.Writer.Trans (WriterT, execWriterT, runWriterT)
+import Data.Either (Either)
+import Data.Maybe (Maybe(..))
+import Data.Monoid (class Monoid)
+import Data.StrMap as StrMap
+import Data.Tuple (Tuple(..), fst)
+import Hyper.Conn (Conn)
+import Hyper.Cookies (Values, cookies)
+import Hyper.Middleware (Middleware, evalMiddleware, runMiddleware)
+import Hyper.Node.Session.Cookie (CookieStore(..), mkSecret)
+import Hyper.Node.Session.InMemory (newInMemorySessionStore)
+import Hyper.Response (HeadersOpen, class Response)
+import Hyper.Session (class SessionStore, delete, deleteSession, get, getSession, newSessionID, put, saveSession)
+import Hyper.Test.TestServer (TestRequest(..), TestResponse(..), defaultRequest)
+import Node.Buffer (BUFFER)
+import Node.Crypto (CRYPTO)
+import Test.Spec (Spec, it, describe)
+import Test.Spec.Assertions (shouldEqual, shouldNotEqual)
+
+type MyAff b state e = WriterT (TestResponse b state) (Aff e)
+
+saveSession' ::
+ forall b state e req res store c session.
+ Response res (MyAff b state e) b =>
+ SessionStore store (MyAff b state e) session =>
+ session ->
+ Middleware
+ (MyAff b state e)
+ (Conn
+ req
+ (res HeadersOpen)
+ { sessions :: { key :: String, store :: store }
+ , cookies :: Either String (StrMap.StrMap Values)
+ | c })
+ (Conn
+ req
+ (res HeadersOpen)
+ { sessions :: { key :: String, store :: store }
+ , cookies :: Either String (StrMap.StrMap Values)
+ | c })
+ Unit
+saveSession' = saveSession
+
+run :: forall w m a. Functor m => WriterT w m a -> m a
+run = runWriterT >>> map fst
+
+getCookie :: Array (Tuple String String) -> String
+getCookie [Tuple "Set-Cookie" c] = c
+getCookie _ = ""
+
+testStore :: forall store session e b state e.
+ SessionStore store (MyAff b state (console :: CONSOLE | e)) session =>
+ Show session =>
+ Eq session =>
+ Monoid session =>
+ Aff (console :: CONSOLE | e) store -> session -> session -> Spec (console :: CONSOLE | e) Unit
+testStore store session session' = do
+ it "retrieves data that was stored" do
+ store' <- store
+ liftAff (session `shouldNotEqual` session')
+ id <- run $ newSessionID store'
+ id' <- run $ put store' id session
+ sessionOut <- run $ get store' id'
+ sessionOut `shouldEqual` Just session
+ id1 <- run $ newSessionID store'
+ id1' <- run $ put store' id1 session'
+ sessionOut' <- run $ get store' id1'
+ sessionOut' `shouldEqual` Just session'
+ sessionOutSecond <- run $ get store' id'
+ sessionOutSecond `shouldEqual` Just session
+ id2 <- run $ newSessionID store'
+ blankSession <- run $ get store' id2
+ blankSession `shouldEqual` Nothing
+ run $ delete store' id'
+ sessionOutDeleted <- run $ get store' id
+ sessionOutDeleted `shouldEqual` Nothing
+ it "works with getSession/saveSession/deleteSession" do
+ store' <- store
+ Tuple sessionOut _ <- { request: TestRequest defaultRequest
+ , response: TestResponse Nothing [] []
+ , components: { sessions: { key: "session", store: store' }
+ , cookies: unit }}
+ # runMiddleware (cookies :*> getSession) >>> run
+ sessionOut `shouldEqual` Nothing
+ TestResponse _ headers _ <- { request: TestRequest defaultRequest
+ , response: TestResponse Nothing [] []
+ , components: { sessions: { key: "session", store: store' }
+ , cookies: unit }}
+ # evalMiddleware (cookies :*> saveSession' session) >>> execWriterT
+ let newCookies = getCookie headers
+ Tuple sessionOut' _ <- { request: TestRequest defaultRequest { headers = StrMap.singleton "cookie" newCookies }
+ , response: TestResponse Nothing [] []
+ , components: { sessions: { key: "session", store: store' }
+ , cookies: unit }}
+ # runMiddleware (cookies :*> getSession) >>> run
+ sessionOut' `shouldEqual` Just session
+ Tuple response (TestResponse _ headers' _)
+ <- { request: TestRequest defaultRequest { headers = StrMap.singleton "cookie" newCookies }
+ , response: TestResponse Nothing [] []
+ , components: { sessions: { key: "session", store: store' }
+ , cookies: unit }}
+ # evalMiddleware (cookies :*> getSession :*> deleteSession) >>> runWriterT
+ let newCookies' = getCookie headers'
+ Tuple sessionOut' _ <- { request: TestRequest defaultRequest { headers = StrMap.singleton "cookie" newCookies' }
+ , response: TestResponse Nothing [] []
+ , components: { sessions: { key: "session", store: store' }
+ , cookies: unit }}
+ # runMiddleware (cookies :*> getSession) >>> run
+ sessionOut' `shouldEqual` Nothing
+
+spec :: forall e. Spec (ref :: REF, console :: CONSOLE, random :: RANDOM, buffer :: BUFFER, crypto :: CRYPTO | e) Unit
+spec = do
+ describe "Hyper.Node.Session.InMemory" do
+ testStore (liftEff newInMemorySessionStore) "value1" "value2"
+ describe "Hyper.Node.Session.Cookie" do
+ testStore (CookieStore <$> mkSecret) "value1" "value2"