Sessions.purs 6.07 KB
Newer Older
1
-- | A module for authenticating to create sessions and handling them
James Laver's avatar
James Laver committed
2 3
module Gargantext.Sessions
  ( module Gargantext.Sessions.Types
4
  , WithSession, WithSessionContext
James Laver's avatar
James Laver committed
5 6
  , load, change
  , Action(..), act, delete, get, post, put, put_
7 8
  , postAuthRequest, postForgotPasswordRequest
  , deleteWithBody, postWwwUrlencoded
James Laver's avatar
James Laver committed
9 10 11
  , getCacheState, setCacheState
  ) where

12 13
import DOM.Simple.Console (log2)
import Data.Either (Either(..), hush)
14 15
import Data.Map as Map
import Data.Maybe (Maybe(..), fromMaybe)
16 17
import Effect (Effect)
import Effect.Aff (Aff)
18 19 20 21 22 23 24
import Reactix as R
import Simple.JSON as JSON
import Toestand as T
import Web.Storage.Storage (getItem, removeItem, setItem)

import Gargantext.Prelude

25 26 27 28 29
import Gargantext.Components.Login.Types (AuthData(..), AuthInvalid(..), AuthRequest(..), AuthResponse(..))
import Gargantext.Components.Nodes.Lists.Types as NT
import Gargantext.Config.REST as REST
import Gargantext.Ends (class ToUrl, Backend, toUrl)
import Gargantext.Sessions.Types (Session(..), Sessions(..), OpenNodes, NodeId, mkNodeId, sessionUrl, sessionId, empty, null, unSessions, lookup, cons, tryCons, update, remove, tryRemove)
30 31
import Gargantext.Utils.Reactix as R2

32 33 34 35 36 37 38 39
type WithSession c =
  ( session :: Session
  | c )

type WithSessionContext c =
  ( session :: R.Context Session
  | c )

James Laver's avatar
James Laver committed
40 41 42
load :: forall c. T.Write c Sessions => c -> Effect Sessions
load cell = do
  sessions <- loadSessions
43
  T.write sessions cell
James Laver's avatar
James Laver committed
44 45 46 47 48 49 50 51 52 53

change
  :: forall c
   . T.Read  c Sessions
  => T.Write c Sessions
  => Action -> c -> Effect Sessions
change action cell = do
  cur <- T.read cell
  new <- act cur action
  saveSessions new *> T.write new cell
54

55 56 57
data Action
  = Login Session
  | Logout Session
58
  | Update Session
59 60

act :: Sessions -> Action -> Effect Sessions
61 62 63 64 65
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) =
66
  case tryRemove (sessionId s) old of
67 68
    Right new -> pure $ new
    _ -> pure old <* log2 "Logged out of stale session:" (sessionId s)
69
act ss (Update s) = saveSessions $ update s ss
70

71 72 73 74
-- Key we will store the data under
localStorageKey :: String
localStorageKey = "garg-sessions"

75 76 77 78 79 80 81
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 }
82 83 84

-- | Will attempt to load saved sessions from localstorage. should log
-- | if decoding fails
85
loadSessions :: Effect Sessions
86
loadSessions = do
87
  storage <- R2.getls
88 89 90 91 92 93 94 95
  mItem :: Maybe String <- getItem localStorageKey storage
  case mItem of
    Nothing -> pure empty
    Just val -> do
      let r = JSON.readJSON val
      case hush r of
        Nothing -> pure empty
        Just p -> pure p
96
-- loadSessions = R2.getls >>= getItem localStorageKey >>= handleMaybe
97 98 99 100 101 102 103 104
--   where
--     -- a localstorage lookup can find nothing
--     handleMaybe (Just val) = handleEither (JSON.readJSON val)
--     handleMaybe Nothing    = pure empty

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

106
saveSessions :: Sessions -> Effect Sessions
107
saveSessions sessions = effect *> pure sessions where
108 109
  rem = R2.getls >>= removeItem localStorageKey
  set v  = R2.getls >>= setItem    localStorageKey v
110
  effect
111
    | null sessions = rem
112
    | otherwise = set (JSON.writeJSON sessions)
113 114 115

postAuthRequest :: Backend -> AuthRequest -> Aff (Either String Session)
postAuthRequest backend ar@(AuthRequest {username}) =
116
  decode <$> REST.post Nothing (toUrl backend "auth") ar
117
  where
118
    decode (Left err) = Left $ "Error when sending REST.post: " <> show err
119
    decode (Right (AuthResponse ar2))
120
      | {inval: Just (AuthInvalid {message})}     <- ar2 = Left message
121 122
      | {valid: Just (AuthData {token, tree_id, user_id})} <- ar2 =
          Right $ Session { backend, caches: Map.empty, token, treeId: tree_id, username, userId: user_id }
123
      | otherwise = Left "Invalid response from server"
124

125
postForgotPasswordRequest :: Backend -> String -> Aff (Either String { status :: String })
126
postForgotPasswordRequest backend email =
127
  decode <$> REST.post Nothing (toUrl backend "async/forgot-password") { email }
128
  where
129
    decode (Left err) = Left $ "Error when sending REST.post: " <> show err
130 131
    decode (Right s) = Right s

132
get :: forall a p. JSON.ReadForeign a => ToUrl Session p =>
133
       Session -> p -> REST.AffRESTError a
134 135
get session@(Session {token}) p = REST.get (Just token) (toUrl session p)

136
put :: forall a b p. JSON.WriteForeign a => JSON.ReadForeign b => ToUrl Session p =>
137
       Session -> p -> a -> REST.AffRESTError b
138 139
put session@(Session {token}) p = REST.put (Just token) (toUrl session p)

140
put_ :: forall b p. JSON.ReadForeign b => ToUrl Session p => Session -> p -> REST.AffRESTError b
141 142
put_ session@(Session {token}) p = REST.put_ (Just token) (toUrl session p)

143
delete :: forall a p. JSON.ReadForeign a => ToUrl Session p =>
144
          Session -> p -> REST.AffRESTError a
145 146 147 148
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
149
deleteWithBody :: forall a b p. JSON.WriteForeign a => JSON.ReadForeign b => ToUrl Session p =>
150
                  Session -> p -> a -> REST.AffRESTError b
151 152
deleteWithBody session@(Session {token}) p = REST.deleteWithBody (Just token) (toUrl session p)

153
post :: forall a b p. JSON.WriteForeign a => JSON.ReadForeign b => ToUrl Session p =>
154
        Session -> p -> a -> REST.AffRESTError b
155 156
post session@(Session {token}) p = REST.post (Just token) (toUrl session p)

157
postWwwUrlencoded :: forall b p. JSON.ReadForeign b => ToUrl Session p =>
158
                     Session -> p -> REST.FormDataParams -> REST.AffRESTError b
159
postWwwUrlencoded session@(Session {token}) p = REST.postWwwUrlencoded (Just token) (toUrl session p)