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