1 {-# LANGUAGE OverloadedStrings #-} 2 module Model.Identity 3 ( module Model.Identity.Types 4 , determineIdentity 5 , maybeIdentity 6 , identityJSON 7 ) where 8 9 import Data.Monoid ((<>)) 10 11 import Ops 12 import Has 13 import qualified JSON 14 import Model.Id 15 import Model.Token 16 import HTTP.Request 17 import Service.Types 18 import Service.DB 19 import HTTP.Cookie 20 import Model.Party 21 import Model.Permission 22 import Model.Identity.Types 23 24 -- | Extract session token from cookie, and use it to find an active session. 25 -- 26 -- This is web framework code, and should NOT be used within application logic. 27 -- 28 -- TODO: Make this more plain, taking the Secret and Request (or just the 29 -- cookies) as regular arguments. 30 determineIdentity :: (MonadHas Secret c m, MonadHasRequest c m, MonadDB c m) => m Identity 31 determineIdentity = 32 maybe NotLoggedIn Identified <$> (flatMapM lookupSession =<< getSignedCookie "session") 33 34 -- | Takes default action and a monadic function. If the Identity within the 35 -- monadic context is 'Identified', apply the function to the 'Session' held 36 -- within. Otherwise, run the default action. 37 maybeIdentity 38 :: (MonadHasIdentity c m) 39 => m a -- ^ Default action 40 -> (Session -> m a) -- ^ Monadic function 41 -> m a -- ^ Result 42 maybeIdentity z f = extractFromIdentifiedSessOrDefault z f =<< peek 43 44 identityJSON :: JSON.ToObject o => Identity -> JSON.Record (Id Party) o 45 identityJSON i = partyJSON (view i) `JSON.foldObjectIntoRec` 46 ( "authorization" JSON..= accessSite i 47 <> "csverf" `JSON.kvObjectOrEmpty` identityVerf i 48 <> "superuser" `JSON.kvObjectOrEmpty` (True `useWhen` identityAdmin i))