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