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

30

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

40 41 42
------------------------------------------------------------------------
-- | Main instances

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

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

63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83
--------------------
-- | 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}

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

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

derive instance genericSessions :: Generic Sessions _

instance eqSessions :: Eq Sessions where
  eq = genericEq
90

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

96
    where
Alexandre Delanoë's avatar
Alexandre Delanoë committed
97
      decodeSessions :: Json -> Either String (Array Session)
98
      decodeSessions json2 = decodeJson json2
99 100
                          >>= \obj -> obj .: "sessions"
                          >>= traverse decodeJson
101 102

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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)

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)

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

240 241
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)