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

4 5
import Prelude (class Eq, class Show, Unit, const, otherwise, pure, show, unit, ($), (*>), (<*), (<$>), (<>), (==), (/=), (>>=), (<<<), bind)
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
import Data.Traversable (traverse)
10
import DOM.Simple.Console (log2)
11 12 13 14
import Data.Either (Either(..))
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Eq (genericEq)
import Data.Maybe (Maybe(..))
15 16
import Data.Sequence as Seq
import Data.Sequence (Seq)
17 18 19 20 21
import Effect (Effect)
import Effect.Aff (Aff)
import Reactix as R
import Web.HTML (window)
import Web.HTML.Window (localStorage)
22
import Web.Storage.Storage (Storage, getItem, setItem, removeItem)
23 24
import Gargantext.Components.Login.Types
  (AuthRequest(..), AuthResponse(..), AuthInvalid(..), AuthData(..))
25
import Gargantext.Config.REST as REST
26 27
import Gargantext.Ends (class ToUrl, Backend, backendUrl, toUrl, sessionPath)
import Gargantext.Routes (SessionRoute)
28
import Gargantext.Types (NodePath, SessionId(..), nodePath)
29 30
import Gargantext.Utils.Reactix as R2

31

32 33 34 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
  , username :: String
  , token    :: String
  , treeId   :: Int }

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
instance toUrlSessionString :: ToUrl Session String where
  toUrl = sessionUrl

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

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

87
data Sessions = Sessions { sessions :: (Seq Session)}
88 89 90 91 92

derive instance genericSessions :: Generic Sessions _

instance eqSessions :: Eq Sessions where
  eq = genericEq
93

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

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

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

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

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

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

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

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

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

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

145 146 147 148 149
data Action
  = Login Session
  | Logout Session

act :: Sessions -> Action -> Effect Sessions
150 151 152 153 154
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) =
155
  case tryRemove (sessionId s) old of
156 157
    Right new -> pure $ new
    _ -> pure old <* log2 "Logged out of stale session:" (sessionId s)
158

159 160 161 162 163
-- Key we will store the data under
localStorageKey :: String
localStorageKey = "garg-sessions"

empty :: Sessions
164
empty = Sessions {sessions:Seq.empty}
165 166 167

-- True if there are no sessions stored
null :: Sessions -> Boolean
168
null (Sessions {sessions:seq}) = Seq.null seq
169 170 171 172


-- | Will attempt to load saved sessions from localstorage. should log
-- | if decoding fails
173
loadSessions :: Effect Sessions
174
loadSessions = getls >>= getItem localStorageKey >>= handleMaybe
175 176 177 178 179 180 181 182 183 184 185
  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)
186 187

mapLeft :: forall l m r. (l -> m) -> Either l r -> Either m r
188
mapLeft f (Left  l) = Left (f l)
189 190
mapLeft _ (Right r) = Right r

191
saveSessions :: Sessions -> Effect Sessions
192
saveSessions sessions = effect *> pure sessions where
193
  rem = getls >>= removeItem localStorageKey
194
  set v  = getls >>= setItem    localStorageKey v
195
  effect
196
    | null sessions = rem
197
    | otherwise = set (stringify $ encodeJson sessions)
198 199 200

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

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)

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

229 230
getls :: Effect Storage
getls = window >>= localStorage