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

4 5
import DOM.Simple.Console (log2)
import Data.Argonaut (class DecodeJson, decodeJson, class EncodeJson, encodeJson, (:=), (~>), (.:))
6
import Data.Argonaut.Core (Json, fromArray, jsonEmptyObject, stringify)
7
import Data.Argonaut.Decode.Error (JsonDecodeError(..))
8
import Data.Argonaut.Parser (jsonParser)
9
import Data.Array as A
10 11 12 13
import Data.Either (Either(..))
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Eq (genericEq)
import Data.Maybe (Maybe(..))
14
import Data.Sequence (Seq)
15
import Data.Sequence as Seq
16
import Data.Set (Set)
17
import Data.Traversable (traverse)
18 19
import Effect (Effect)
import Effect.Aff (Aff)
20
import Gargantext.Components.Login.Types (AuthData(..), AuthInvalid(..), AuthRequest(..), AuthResponse(..), TreeId)
21
import Gargantext.Config.REST as REST
22
import Gargantext.Ends (class ToUrl, Backend(..), backendUrl, sessionPath, toUrl)
23
import Gargantext.Routes (SessionRoute)
24
import Gargantext.Types (NodePath, SessionId(..), nodePath)
25
import Gargantext.Utils.Reactix (getls)
26
import Gargantext.Utils.Reactix as R2
27 28 29
import Prelude (class Eq, class Show, Unit, const, otherwise, pure, show, unit, ($), (*>), (<*), (<$>), (<>), (==), (/=), (>>=), (<<<), bind)
import Reactix as R
import Web.Storage.Storage (getItem, removeItem, setItem)
30

31

32 33 34 35 36 37
-- | 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
  , username :: String
  , token    :: String
38 39
  , treeId   :: TreeId
  }
40

41 42 43
------------------------------------------------------------------------
-- | Main instances

44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60
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

61 62 63
sessionId :: Session -> SessionId
sessionId = SessionId <<< show

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

instance decodeJsonSession :: DecodeJson Session where
  decodeJson json = do
    obj      <- decodeJson json
    backend  <- obj .: "backend"
    username <- obj .: "username"
    token    <- obj .: "token"
    treeId   <- obj .: "treeId"
    pure $ Session { backend, username, token, treeId}

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

85
data Sessions = Sessions { sessions :: (Seq Session)}
86 87 88 89 90

derive instance genericSessions :: Generic Sessions _

instance eqSessions :: Eq Sessions where
  eq = genericEq
91

92 93
instance decodeJsonSessions :: DecodeJson Sessions where
  decodeJson json = do
Alexandre Delanoë's avatar
Alexandre Delanoë committed
94
    ss <- decodeSessions json
95 96
    pure (Sessions {sessions:Seq.fromFoldable ss})

97
    where
98
      decodeSessions :: Json -> Either JsonDecodeError (Array Session)
99
      decodeSessions json2 = decodeJson json2
100 101
                          >>= \obj -> obj .: "sessions"
                          >>= traverse decodeJson
102 103

instance encodeJsonSessions :: EncodeJson Sessions where
104
  encodeJson (Sessions {sessions:ss}) = "sessions" := (encodeSessions ss)
105 106 107
                           ~> jsonEmptyObject
    where
      encodeSessions :: Seq Session -> Json
108
      encodeSessions ss2 = fromArray $ encodeJson <$> (Seq.toUnfoldable ss2)
109

110
unSessions :: Sessions -> Array Session
111
unSessions (Sessions {sessions:s}) = A.fromFoldable s
112 113 114 115 116

useSessions :: R.Hooks (R2.Reductor Sessions Action)
useSessions = R2.useReductor actAndSave (const loadSessions) unit
  where
    actAndSave :: R2.Actor Sessions Action
117
    actAndSave a s = act s a >>= saveSessions
118

119
lookup :: SessionId -> Sessions -> Maybe Session
120
lookup sid (Sessions {sessions:ss}) = Seq.head (Seq.filter f ss) where
121 122 123
  f s = sid == sessionId s

cons :: Session -> Sessions -> Sessions
124
cons s (Sessions {sessions:ss}) = Sessions {sessions:(Seq.cons s ss)}
125 126 127 128 129 130 131

tryCons :: Session -> Sessions -> Either Unit Sessions
tryCons s ss = try (lookup sid ss) where
  sid = sessionId s
  try Nothing = Right (cons s ss)
  try _ = Left unit

132
remove :: SessionId -> Sessions -> Sessions
133
remove sid (Sessions {sessions:ss}) = Sessions {sessions: Seq.filter f ss} where
134 135
  f s = sid /= sessionId s

136 137 138
tryRemove :: SessionId -> Sessions -> Either Unit Sessions
tryRemove sid old@(Sessions ss) = ret where
  new = remove sid old
139 140 141 142
  ret
    | new == old = Left unit
    | otherwise =  Right new

143 144 145 146 147 148 149 150 151 152 153 154 155 156
-- 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

157 158 159 160 161
data Action
  = Login Session
  | Logout Session

act :: Sessions -> Action -> Effect Sessions
162 163 164 165 166
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) =
167
  case tryRemove (sessionId s) old of
168 169
    Right new -> pure $ new
    _ -> pure old <* log2 "Logged out of stale session:" (sessionId s)
170

171 172 173 174 175
-- Key we will store the data under
localStorageKey :: String
localStorageKey = "garg-sessions"

empty :: Sessions
176
empty = Sessions {sessions:Seq.empty}
177 178 179

-- True if there are no sessions stored
null :: Sessions -> Boolean
180
null (Sessions {sessions:seq}) = Seq.null seq
181 182 183 184


-- | Will attempt to load saved sessions from localstorage. should log
-- | if decoding fails
185
loadSessions :: Effect Sessions
186
loadSessions = getls >>= getItem localStorageKey >>= handleMaybe
187 188 189 190 191 192 193 194 195 196 197
  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)
198 199

mapLeft :: forall l m r. (l -> m) -> Either l r -> Either m r
200
mapLeft f (Left  l) = Left (f l)
201 202
mapLeft _ (Right r) = Right r

203
saveSessions :: Sessions -> Effect Sessions
204
saveSessions sessions = effect *> pure sessions where
205
  rem = getls >>= removeItem localStorageKey
206
  set v  = getls >>= setItem    localStorageKey v
207
  effect
208
    | null sessions = rem
209
    | otherwise = set (stringify $ encodeJson sessions)
210 211 212

postAuthRequest :: Backend -> AuthRequest -> Aff (Either String Session)
postAuthRequest backend ar@(AuthRequest {username}) =
213
  decode <$> REST.post Nothing (toUrl backend "auth") ar
214 215
  where
    decode (AuthResponse ar2)
216
      | {inval: Just (AuthInvalid {message})}     <- ar2 = Left message
217 218 219
      | {valid: Just (AuthData {token, tree_id})} <- ar2 =
          Right $ Session { backend, username, token, treeId: tree_id }
      | otherwise = Left "Invalid response from server"
220 221 222 223 224 225 226

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)

227 228 229
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)

230 231 232 233 234 235 236 237 238 239 240
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)

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

244 245
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)