Sessions.purs 10 KB
Newer Older
1 2 3
-- | A module for authenticating to create sessions and handling them
module Gargantext.Sessions where

4
import Data.Argonaut (class DecodeJson, decodeJson, class EncodeJson, encodeJson, (:=), (~>), (.:))
5
import Data.Argonaut.Core (Json, fromArray, jsonEmptyObject, stringify)
6
import Data.Argonaut.Decode.Error (JsonDecodeError(..))
7
import Data.Argonaut.Parser (jsonParser)
8
import Data.Array as A
9 10 11
import Data.Either (Either(..))
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Eq (genericEq)
12 13 14
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..), fromMaybe)
15
import Data.Sequence (Seq)
16
import Data.Sequence as Seq
17
import Data.Set (Set)
18
import Data.Traversable (traverse)
19
import DOM.Simple.Console (log2)
20 21
import Effect (Effect)
import Effect.Aff (Aff)
22 23 24 25
import Prelude (class Eq, class Show, Unit, const, otherwise, pure, show, unit, ($), (*>), (<*), (<$>), (<>), (==), (/=), (>>=), (<<<), bind)
import Reactix as R
import Web.Storage.Storage (getItem, removeItem, setItem)

26
import Gargantext.Components.Login.Types (AuthData(..), AuthInvalid(..), AuthRequest(..), AuthResponse(..), TreeId)
27
import Gargantext.Components.Nodes.Lists.Types as NT
28
import Gargantext.Config.REST as REST
29
import Gargantext.Ends (class ToUrl, Backend(..), backendUrl, sessionPath, toUrl)
30
import Gargantext.Routes (SessionRoute)
31
import Gargantext.Types (NodePath, SessionId(..), nodePath)
32
import Gargantext.Utils.Reactix (getls)
33 34
import Gargantext.Utils.Reactix as R2

35

36 37 38 39
-- | A Session represents an authenticated session for a user at a
-- | backend. It contains a token and root tree id.
newtype Session = Session
  { backend  :: Backend
40
  , caches   :: Map Int NT.CacheState  -- whether cache is turned on for node id
41
  , token    :: String
42
  , treeId   :: TreeId
43
  , username :: String
44
  }
45

46 47 48
------------------------------------------------------------------------
-- | Main instances

49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65
derive instance genericSession :: Generic Session _

instance eqSession :: Eq Session where
  eq = genericEq

instance showSession :: Show Session where
  show (Session {backend, username}) = username <> "@" <> show backend

instance toUrlSessionRoute :: ToUrl Session SessionRoute where
  toUrl (Session {backend}) r = backendUrl backend (sessionPath r)

instance toUrlSessionNodePath :: ToUrl Session NodePath where
  toUrl (Session {backend}) np = backendUrl backend (nodePath np)

sessionUrl :: Session -> String -> String
sessionUrl (Session {backend}) = backendUrl backend

66 67 68
sessionId :: Session -> SessionId
sessionId = SessionId <<< show

69 70 71
--------------------
-- | JSON instances
instance encodeJsonSession :: EncodeJson Session where
72 73 74 75
  encodeJson (Session { backend, caches, username, token, treeId })
    = "backend"  := encodeJson backend
    ~> "caches"   := encodeJson caches
    ~> "token"    := token
76
    ~> "treeId"   := treeId
77
    ~> "username" := username
78 79 80 81 82 83
    ~> jsonEmptyObject

instance decodeJsonSession :: DecodeJson Session where
  decodeJson json = do
    obj      <- decodeJson json
    backend  <- obj .: "backend"
84
    caches   <- obj .: "caches"
85 86
    token    <- obj .: "token"
    treeId   <- obj .: "treeId"
87 88
    username <- obj .: "username"
    pure $ Session { backend, caches, token, treeId, username }
89 90 91

------------------------------------------------------------------------

92
data Sessions = Sessions { sessions :: (Seq Session)}
93 94 95 96 97

derive instance genericSessions :: Generic Sessions _

instance eqSessions :: Eq Sessions where
  eq = genericEq
98

99 100
instance decodeJsonSessions :: DecodeJson Sessions where
  decodeJson json = do
Alexandre Delanoë's avatar
Alexandre Delanoë committed
101
    ss <- decodeSessions json
102 103
    pure (Sessions {sessions:Seq.fromFoldable ss})

104
    where
105
      decodeSessions :: Json -> Either JsonDecodeError (Array Session)
106
      decodeSessions json2 = decodeJson json2
107 108
                          >>= \obj -> obj .: "sessions"
                          >>= traverse decodeJson
109 110

instance encodeJsonSessions :: EncodeJson Sessions where
111
  encodeJson (Sessions {sessions:ss}) = "sessions" := (encodeSessions ss)
112 113 114
                           ~> jsonEmptyObject
    where
      encodeSessions :: Seq Session -> Json
115
      encodeSessions ss2 = fromArray $ encodeJson <$> (Seq.toUnfoldable ss2)
116

117
unSessions :: Sessions -> Array Session
118
unSessions (Sessions {sessions:s}) = A.fromFoldable s
119

120 121 122
type Reductor = R2.Reductor Sessions Action

useSessions :: R.Hooks Reductor
123 124 125
useSessions = R2.useReductor actAndSave (const loadSessions) unit
  where
    actAndSave :: R2.Actor Sessions Action
126
    actAndSave a s = act s a >>= saveSessions
127

128
lookup :: SessionId -> Sessions -> Maybe Session
129
lookup sid (Sessions {sessions:ss}) = Seq.head (Seq.filter f ss) where
130 131 132
  f s = sid == sessionId s

cons :: Session -> Sessions -> Sessions
133
cons s (Sessions {sessions:ss}) = Sessions {sessions:(Seq.cons s ss)}
134 135

tryCons :: Session -> Sessions -> Either Unit Sessions
136 137 138 139 140 141 142 143 144 145 146 147
tryCons s ss = try $ lookup sid ss
  where
    sid = sessionId s
    try Nothing = Right (cons s ss)
    try _ = Left unit

update :: Session -> Sessions -> Sessions
update s ss = up $ lookup sid ss
  where
    sid = sessionId s
    up Nothing = cons s ss
    up _ = cons s $ remove sid ss
148

149
remove :: SessionId -> Sessions -> Sessions
150
remove sid (Sessions {sessions:ss}) = Sessions {sessions: Seq.filter f ss} where
151 152
  f s = sid /= sessionId s

153 154 155
tryRemove :: SessionId -> Sessions -> Either Unit Sessions
tryRemove sid old@(Sessions ss) = ret where
  new = remove sid old
156 157 158 159
  ret
    | new == old = Left unit
    | otherwise =  Right new

160 161 162 163 164 165 166 167 168 169 170 171 172 173
-- open tree nodes data
type OpenNodes = Set NodeId

type NodeId =
  { treeId :: TreeId  -- Id of the node
  , baseUrl :: String -- the baseUrl of the backend
  }

mkNodeId :: Session -> TreeId -> NodeId
mkNodeId (Session {backend: Backend {baseUrl}}) treeId = { treeId, baseUrl }

instance toUrlSessionString :: ToUrl Session String where
  toUrl = sessionUrl

174 175 176
data Action
  = Login Session
  | Logout Session
177
  | Update Session
178 179

act :: Sessions -> Action -> Effect Sessions
180 181 182 183 184
act ss (Login s) =
  case tryCons s ss of
    Right new -> pure new
    _ -> pure ss <* log2 "Cannot overwrite existing session: " (sessionId s)
act old@(Sessions ss) (Logout s) =
185
  case tryRemove (sessionId s) old of
186 187
    Right new -> pure $ new
    _ -> pure old <* log2 "Logged out of stale session:" (sessionId s)
188
act ss (Update s) = saveSessions $ update s ss
189

190 191 192 193 194
-- Key we will store the data under
localStorageKey :: String
localStorageKey = "garg-sessions"

empty :: Sessions
195
empty = Sessions { sessions: Seq.empty }
196 197 198

-- True if there are no sessions stored
null :: Sessions -> Boolean
199
null (Sessions { sessions: seq }) = Seq.null seq
200

201 202 203 204 205 206 207
getCacheState :: NT.CacheState -> Session -> Int -> NT.CacheState
getCacheState defaultCacheState (Session { caches }) nodeId =
  fromMaybe defaultCacheState $ Map.lookup nodeId caches

setCacheState :: Session -> Int -> NT.CacheState -> Session
setCacheState (Session session@{ caches }) nodeId cacheState =
  Session $ session { caches = Map.insert nodeId cacheState caches }
208 209 210

-- | Will attempt to load saved sessions from localstorage. should log
-- | if decoding fails
211
loadSessions :: Effect Sessions
212
loadSessions = getls >>= getItem localStorageKey >>= handleMaybe
213 214 215 216 217 218 219 220 221 222 223
  where
    -- a localstorage lookup can find nothing
    handleMaybe (Just val) = handleEither (parse val >>= decode)
    handleMaybe Nothing    = pure empty

    -- either parsing or decoding could fail, hence two errors
    handleEither (Left err) = err *> pure empty
    handleEither (Right ss) = pure ss

    parse  s = mapLeft (log2 "Error parsing serialised sessions:") (jsonParser s)
    decode j = mapLeft (log2 "Error decoding serialised sessions:") (decodeJson j)
224 225

mapLeft :: forall l m r. (l -> m) -> Either l r -> Either m r
226
mapLeft f (Left  l) = Left (f l)
227 228
mapLeft _ (Right r) = Right r

229
saveSessions :: Sessions -> Effect Sessions
230
saveSessions sessions = effect *> pure sessions where
231
  rem = getls >>= removeItem localStorageKey
232
  set v  = getls >>= setItem    localStorageKey v
233
  effect
234
    | null sessions = rem
235
    | otherwise = set (stringify $ encodeJson sessions)
236

237 238 239 240 241 242
updateSession :: Session -> Effect Unit
updateSession s = do
  ss <- loadSessions
  _ <- saveSessions $ update s ss
  pure unit

243 244
postAuthRequest :: Backend -> AuthRequest -> Aff (Either String Session)
postAuthRequest backend ar@(AuthRequest {username}) =
245
  decode <$> REST.post Nothing (toUrl backend "auth") ar
246 247
  where
    decode (AuthResponse ar2)
248
      | {inval: Just (AuthInvalid {message})}     <- ar2 = Left message
249
      | {valid: Just (AuthData {token, tree_id})} <- ar2 =
250
          Right $ Session { backend, caches: Map.empty, token, treeId: tree_id, username }
251
      | otherwise = Left "Invalid response from server"
252 253 254 255 256 257 258

get :: forall a p. DecodeJson a => ToUrl Session p => Session -> p -> Aff a
get session@(Session {token}) p = REST.get (Just token) (toUrl session p)

put :: forall a b p. EncodeJson a => DecodeJson b => ToUrl Session p => Session -> p -> a -> Aff b
put session@(Session {token}) p = REST.put (Just token) (toUrl session p)

259 260 261
put_ :: forall a b p. DecodeJson b => ToUrl Session p => Session -> p -> Aff b
put_ session@(Session {token}) p = REST.put_ (Just token) (toUrl session p)

262 263 264 265 266 267 268 269 270 271 272
delete :: forall a p. DecodeJson a => ToUrl Session p => Session -> p -> Aff a
delete session@(Session {token}) p = REST.delete (Just token) (toUrl session p)

-- This might not be a good idea:
-- https://stackoverflow.com/questions/14323716/restful-alternatives-to-delete-request-body
deleteWithBody :: forall a b p. EncodeJson a => DecodeJson b => ToUrl Session p => Session -> p -> a -> Aff b
deleteWithBody session@(Session {token}) p = REST.deleteWithBody (Just token) (toUrl session p)

post :: forall a b p. EncodeJson a => DecodeJson b => ToUrl Session p => Session -> p -> a -> Aff b
post session@(Session {token}) p = REST.post (Just token) (toUrl session p)

273
postWwwUrlencoded :: forall b p. DecodeJson b => ToUrl Session p => Session -> p -> REST.FormDataParams -> Aff b
274
postWwwUrlencoded session@(Session {token}) p = REST.postWwwUrlencoded (Just token) (toUrl session p)
275

276 277
postMultipartFormData :: forall b p. DecodeJson b => ToUrl Session p => Session -> p -> String -> Aff b
postMultipartFormData session@(Session {token}) p = REST.postMultipartFormData (Just token) (toUrl session p)