1 {-# LANGUAGE OverloadedStrings #-} 2 {-# LANGUAGE RankNTypes #-} 3 4 -- | 5 -- How to run Databrary Actions. 6 -- 7 -- This module is the foundation of the site. It provides a method for packaging 8 -- up route actions into 'Wai.Application's (which is effectively the HTTP 9 -- transport layer), as well as a method for packaging them into background 10 -- threads. 11 module Databrary.Action.Run 12 ( 13 -- * \"Framework\" code 14 actionApp 15 , forkAction 16 -- * Declaring authentication needs for Actions 17 , withAuth 18 , withoutAuth 19 , withReAuth 20 -- * The underlying type 21 , Action 22 ) where 23 24 import Control.Concurrent (ThreadId, forkFinally) 25 import Control.Exception (SomeException) 26 import Control.Monad.Reader (ReaderT(..), withReaderT, local) 27 import Data.Time (getCurrentTime) 28 import Network.HTTP.Types (hDate, hCacheControl, methodHead) 29 import qualified Network.Wai as Wai 30 31 import Databrary.Has 32 import Databrary.HTTP 33 import Databrary.Service.DB 34 import Databrary.Service.Types 35 import Databrary.Service.Log 36 import Databrary.Model.Identity 37 import Databrary.Model.Id.Types 38 import Databrary.Model.Party.Types 39 import Databrary.HTTP.Request 40 import Databrary.Context 41 import Databrary.Action.Types 42 import Databrary.Action.Request 43 import Databrary.Action.Response 44 45 -- | 46 -- Transform a web request to a lower-level action. 47 -- 48 -- Given an action that runs in a top-level Handler, build the necessary context 49 -- for that action, and run in it in the base-level ActionContextM 50 -- 51 -- Handler has a richer context: it has all of ActionContext, plus Identity and 52 -- the Wai Request. 53 withHandler 54 :: forall a 55 . Request -- ^ The wai request to handle 56 -> Identity -- ^ The identity to use for this action 57 -> Handler a -- ^ The action to perform 58 -> ActionContextM a -- ^ The base-level control access to the system 59 withHandler waiReq identity h = 60 let (handler :: ReaderT RequestContext IO a) = unHandler h 61 in withReaderT (\(c :: ActionContext) -> RequestContext c waiReq identity) handler 62 63 -- | Authentication requirements for an 'Action'. 64 data NeedsAuthentication = NeedsAuthentication | DoesntNeedAuthentication 65 66 -- | This type captures both the authentication needs and the handler for a 67 -- route. 68 -- 69 -- It extends ActionRoute, which already has most info about a route and how to 70 -- serve it, to include the authentication requirement. 71 data Action = Action 72 { _actionAuthentication :: !NeedsAuthentication 73 , _actionM :: !(Handler Response) 74 } 75 76 -- | Convert an Action into a Wai.Application. 77 -- 78 -- This is the 3rd level of the Databrary \"web framework\". It runs the 79 -- requested action with some resolved identity to build the HTTP response. See 80 -- 'actionRouteApp' for level 2, and 'servantApp' for level 1. 81 -- 82 -- TODO: For converting to Servant, this whole function should be duplicated by 83 -- new combinators. 84 -- 85 -- For instance, there is a section (in the second 'let', within the do) where 86 -- headers are added to the response. Servant requires us to put that in the 87 -- type, which can be easily done. We can even make a combinator for looking up 88 -- auth results and logging access. After all that, we should be able to create 89 -- something with HoistServer that will run the rest of the (Databrary) Handler. 90 -- 91 -- But then we'll have to map the Response (Action ~ ReaderT RequestContext IO 92 -- Response) into something else! And how do we catch exceptions? Plain old 93 -- catch blocks? And what do we convert exceptions into? 94 actionApp 95 :: Service -- ^ All the low-level system capabilities 96 -> Action -- ^ Action to run 97 -> Wai.Application -- ^ Callback for Wai 98 actionApp service (Action needsAuth act) waiReq waiSend = 99 let 100 isdb = isDatabraryClient waiReq 101 authenticatedAct :: ActionContextM (Identity, Response) 102 authenticatedAct = do 103 sec <- peek 104 conn <- peek 105 identity <- fetchIdent sec conn waiReq needsAuth 106 waiResponse <- 107 ReaderT 108 -- runResult unwraps the short-circuit machinery from 109 -- "Databrary.Action.Response", returning IO Response. 110 $ \actCtx -> 111 runResult 112 (runHandler act (RequestContext actCtx waiReq identity)) 113 return (identity, waiResponse) 114 in do 115 ts <- getCurrentTime 116 (identityUsed, waiResponse) <- runContextM authenticatedAct service 117 logAccess 118 ts 119 waiReq 120 (extractFromIdentifiedSessOrDefault 121 Nothing 122 (Just . (show :: Id Party -> String) . view) 123 identityUsed) 124 waiResponse 125 (serviceLogs service) 126 let 127 waiResponse' = Wai.mapResponseHeaders 128 (((hDate, formatHTTPTimestamp ts) :) 129 . (if isdb then ((hCacheControl, "no-cache") :) else id)) 130 waiResponse 131 waiSend $ if Wai.requestMethod waiReq == methodHead 132 then emptyResponse 133 (Wai.responseStatus waiResponse') 134 (Wai.responseHeaders waiResponse') 135 else waiResponse' 136 137 -- | Special-purpose context for determing the user's identity. We don't need 138 -- the full Handler for that, and since this is sensitive work, we don't want to 139 -- just cheat and use it anyway. 140 data IdContext = IdContext 141 { ctxReq :: Wai.Request 142 , ctxSec :: Secret 143 , ctxConn :: DBConn 144 } 145 146 instance Has Wai.Request IdContext where view = ctxReq 147 instance Has Secret IdContext where view = ctxSec 148 instance Has DBConn IdContext where view = ctxConn 149 150 -- | Look up the user's identity (or don't) 151 fetchIdent 152 :: Secret -- ^ Session key 153 -> DBConn -- ^ For querying the session table 154 -> Wai.Request 155 -- ^ FIXME: Why the entire request? Can we narrow the scope? What is 156 -- actually needed is the session cookie. 157 -> NeedsAuthentication 158 -- ^ Whether or not to actually do the lookup. 159 -- 160 -- FIXME: This seems like an unncessary complication. 161 -> ActionContextM Identity 162 fetchIdent sec con waiReq = \case 163 NeedsAuthentication -> 164 runReaderT determineIdentity (IdContext waiReq sec con) 165 DoesntNeedAuthentication -> return IdentityNotNeeded 166 167 -- | Run a Handler action in the background (IO). 168 -- 169 -- A new ActionContextM is built, with a fresh guaranteed db connection and 170 -- timestamp, via 'runContextM' 171 forkAction 172 :: Handler a -- ^ Handler action to run 173 -> RequestContext 174 -- ^ Original context 175 -- 176 -- The background action inherits this context's 'Request' and 'Service'. 177 -> (Either SomeException a -> IO ()) 178 -- ^ Cleanup to run when the action exits 179 -> IO ThreadId 180 forkAction h reqCtx = forkFinally $ runContextM (withHandler req ident h) srv 181 where 182 req = contextRequest reqCtx 183 ident = requestIdentity reqCtx 184 srv = contextService (requestContext reqCtx) 185 186 -- | Tag an 'Action' as needing to know whether or not the user is 187 -- authenticated. This simply triggers an extra session lookup in 'actionApp'. 188 withAuth 189 :: Handler Response -- ^ The handler for the route 190 -> Action -- ^ The bundled action 191 withAuth = Action NeedsAuthentication 192 193 -- | Tag an 'Action' as not needing auth. See note at 'withAuth'. 194 withoutAuth :: Handler Response -> Action 195 withoutAuth = Action DoesntNeedAuthentication 196 197 -- | This may be like a 'su' that allows running an action as a different 198 -- identity. 199 withReAuth 200 :: SiteAuth -- ^ The identity to assume 201 -> Handler a 202 -- ^ The action to perform as the assumed identity 203 -- 204 -- Note that one might argue for an indexed form of 'Handler' here, a la 205 -- Selda and subqueries. 206 -> Handler a -- ^ The re-authenticated action, packaged into the original context 207 withReAuth u = 208 Handler 209 . local (\a -> a { requestIdentity = ReIdentified u }) 210 . unHandler