hyper/src/Hyper/Session.purs at 9a77a3b19dd8398ee8ca0851ab988d6259f93cc7 · purescript-hyper/hyper · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
module Hyper.Session
       ( SessionID(..)
       , class SessionStore
       , newSessionID
       , get
       , put
       , delete
       , saveSession
       , getSession
       , deleteSession
       ) where

import Prelude
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)

newtype SessionID = SessionID String

derive instance eqSessionID :: Eq SessionID
derive instance ordSessionID :: Ord SessionID
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 SessionID
  delete :: store -> SessionID -> m Unit

type Sessions s = { key :: String, store :: s }

currentSessionID
  :: forall m req res c store session
  .  Monad m
  => SessionStore store m session
  => Middleware
     m
     (Conn
      req
      res
      { sessions :: Sessions store
      , cookies :: Either String (StrMap Cookies.Values)
      | c
      })
     (Conn
      req
      res
      { sessions :: Sessions store
      , cookies :: Either String (StrMap Cookies.Values)
      | c
      })
     (Maybe SessionID)
currentSessionID =
  getConn :>>= \conn ->
  case conn.components.cookies of
    Left err ->
      ipure Nothing
    Right cookies ->
      StrMap.lookup conn.components.sessions.key cookies
      # map (SessionID <<< NonEmpty.head)
      # pure

getSession
  :: forall m req res c store session
  .  Monad m
  => SessionStore store m session
  => Middleware
     m
     (Conn
      req
      res
      { sessions :: Sessions store
      , cookies :: Either String (StrMap Cookies.Values)
      | c
      })
     (Conn
      req
      res
      { sessions :: Sessions store
      , cookies :: Either String (StrMap Cookies.Values)
      | c
      })
     (Maybe session)
getSession = do
  conn <- getConn
  sessionId <- currentSessionID
  case sessionId of
    Just id' -> lift' (get conn.components.sessions.store id')
    Nothing -> ipure Nothing
  where bind = ibind

saveSession
  :: forall m req res c b store session
  .  Monad m
  => Response res m b
  => SessionStore store m session
  => session
  -> Middleware
     m
     (Conn
      req
      (res HeadersOpen)
      { sessions :: Sessions store, cookies :: Either String (StrMap Cookies.Values) | c})
     (Conn
      req
      (res HeadersOpen)
      { sessions :: Sessions store, cookies :: Either String (StrMap Cookies.Values) | c})
     Unit
saveSession session = do
  conn <- getConn
  sessionId <-
    currentSessionID :>>=
    case _ of
      Just id'
        | unwrap id' /= "" -> ipure id'
        | otherwise -> lift' (newSessionID conn.components.sessions.store)
      Nothing -> lift' (newSessionID conn.components.sessions.store)
  sessionId' <- lift' (put conn.components.sessions.store sessionId session)
  setCookie conn.components.sessions.key (unwrap sessionId')
  where
    bind = ibind

deleteSession
  :: forall m req res c b store session
  .  Monad m
  => Response res m b
  => SessionStore store m session
  => Middleware
     m
     (Conn
      req
      (res HeadersOpen)
      { sessions :: Sessions store, cookies :: Either String (StrMap Cookies.Values) | c})
     (Conn
      req
      (res HeadersOpen)
      { sessions :: Sessions store, cookies :: Either String (StrMap Cookies.Values) | c})
     Unit
deleteSession = do
  conn <- getConn
  _ <- maybe (ipure unit) (lift' <<< delete conn.components.sessions.store) =<< currentSessionID
  -- TODO: Better delete?
  setCookie conn.components.sessions.key ""