1 {-# LANGUAGE DataKinds #-} 2 {-# LANGUAGE FlexibleInstances #-} 3 {-# LANGUAGE MultiParamTypeClasses #-} 4 {-# LANGUAGE OverloadedStrings #-} 5 {-# LANGUAGE RankNTypes #-} 6 {-# LANGUAGE ScopedTypeVariables #-} 7 {-# LANGUAGE TypeOperators #-} 8 module Databrary.Action 9 ( Request 10 , RequestContext 11 , Databrary.Handler 12 , Action 13 14 , Response 15 , response 16 , emptyResponse 17 , redirectRouteResponse 18 , otherRouteResponse 19 , forbiddenResponse 20 , notFoundResponse 21 , okResponse 22 , result 23 , maybeAction 24 25 , module Databrary.Action.Route 26 27 , withAuth 28 , withoutAuth 29 -- * Building the application 30 , WaiRouteApp(..) 31 , ActionRouteApp (..) 32 , actionRouteApp 33 ) where 34 35 import Network.HTTP.Types 36 (Status, seeOther303, forbidden403, notFound404, ResponseHeaders, hLocation) 37 import Servant 38 import qualified Data.ByteString.Builder as BSB 39 import qualified Data.ByteString.Lazy as BSL 40 import qualified Network.Wai as Wai 41 import qualified Web.Route.Invertible.Wai as Invertible 42 43 import Databrary.Has (peeks) 44 import Databrary.HTTP.Request 45 import Databrary.Action.Types as Databrary 46 import Databrary.Action.Run 47 import Databrary.Action.Response 48 import Databrary.Action.Route 49 import Databrary.Service.Types 50 import Databrary.View.Error 51 52 -- | Redirect a request to a new route 53 redirectRouteResponse 54 :: Status 55 -> ResponseHeaders 56 -> Invertible.RouteAction r a 57 -> r 58 -> Request 59 -> Response 60 redirectRouteResponse status hdrs ra r req = 61 emptyResponse status (locationHeader : hdrs) 62 where 63 locationHeader = 64 (hLocation, build (actionURL (Just req) ra r (Wai.queryString req))) 65 build = BSL.toStrict . BSB.toLazyByteString 66 67 -- | Redirect with HTTP code 303 68 otherRouteResponse 69 :: ResponseHeaders -> Invertible.RouteAction r a -> r -> Request -> Response 70 otherRouteResponse = redirectRouteResponse seeOther303 71 72 -- | HTTP code 403 73 forbiddenResponse :: RequestContext -> Response 74 forbiddenResponse = response forbidden403 [] . htmlForbidden 75 76 -- | HTTP code 404 77 notFoundResponse :: RequestContext -> Response 78 notFoundResponse = response notFound404 [] . htmlNotFound 79 80 -- | Fail with 404 if not 'Just' 81 maybeAction :: Maybe a -> Databrary.Handler a 82 maybeAction (Just a) = return a 83 maybeAction Nothing = result =<< peeks notFoundResponse 84 85 newtype WaiRouteApp = WaiRouteApp Application 86 newtype ActionRouteApp = ActionRouteApp Application 87 88 -- | The second level of the Databrary 'web framework'. Makes a (wrapped) Wai 89 -- Application given a route map, a hatch into the Wai Route fallback, and the 90 -- already-generated system capabilities. 91 -- 92 -- Most routes are served by web-inv-route—style ActionRoutes, but some (~30%) 93 -- have been converted to Wai Routes. 94 actionRouteApp 95 :: Invertible.RouteMap Action 96 -- ^ The original route map. Now partially replaced by Wai Routes 97 -> WaiRouteApp 98 -- ^ The newer Wai Route-based Application 99 -> Service 100 -- ^ System capabilities 101 -> ActionRouteApp 102 -- ^ The actual web app 103 actionRouteApp invMap (WaiRouteApp waiRouteApp) svc = ActionRouteApp 104 (\waiRequest waiSend -> 105 -- Use the original Action if it still exists 106 either 107 (waiRouteFallback waiRequest waiSend) 108 (\act -> actionApp svc act waiRequest waiSend) 109 (Invertible.routeWai waiRequest invMap) 110 ) 111 where 112 waiRouteFallback waiRequest waiSend (st,hdrs) 113 -- Currently, this might be only possible error result? 114 | st == notFound404 = waiRouteApp waiRequest waiSend 115 -- Handle any other possible errors with the original app's error 116 -- handling. 117 | otherwise = actionApp svc (err (st,hdrs)) waiRequest waiSend 118 -- This is almost, but not quite, equal to 'notFoundResponseHandler' 119 err :: (Status, ResponseHeaders) -> Action 120 err (status, headers) = 121 withoutAuth (peeks (response status headers . htmlNotFound))