Retief/cookiestore

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",

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');
+}

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

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

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 ""

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"