1 {-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
    2 module Databrary.Action.Route
    3   ( Method(..)
    4   , ActionRoute
    5   , actionURL
    6   , actionURI
    7   , actionMethod
    8   , action
    9   , multipartAction
   10   , API(..)
   11   , pathHTML
   12   , pathJSON
   13   , pathAPI
   14   ) where
   15 
   16 import qualified Data.ByteString.Builder as BSB
   17 import qualified Data.Invertible as I
   18 import Network.HTTP.Types (Query)
   19 import Network.URI (URI(..))
   20 import qualified Web.Route.Invertible as R
   21 import Web.Route.Invertible (Method(..))
   22 
   23 import Databrary.HTTP.Request
   24 import Databrary.HTTP.Route
   25 import Databrary.HTTP.Path.Parser
   26 import Databrary.Action.Run
   27 
   28 -- | A 'R.RouteAction' (library code) that holds an 'Action' (Databrary code).
   29 -- The type parameter a represents the values that get captured in a route
   30 -- description (like /foo/:int would capture an Int).
   31 type ActionRoute a = R.RouteAction a Action
   32 
   33 actionURL :: Maybe Request -> R.RouteAction r a -> r -> Query -> BSB.Builder
   34 actionURL mreq route routeParams query
   35   | R.requestMethod rr == GET = routeURL mreq rr query
   36   | otherwise = error $ "actionURL: " ++ show rr
   37   where rr = R.requestActionRoute route routeParams
   38 
   39 actionURI :: Maybe Request -> R.RouteAction r a -> r -> Query -> URI
   40 actionURI req r a q
   41   | R.requestMethod rr == GET = routeURI req rr q
   42   | otherwise = error $ "actionURI: " ++ show rr
   43   where rr = R.requestActionRoute r a
   44 
   45 actionMethod :: R.RouteAction r a -> r -> Method
   46 actionMethod r = R.requestMethod . R.requestActionRoute r
   47 
   48 -- | A shortcut for specifying route actions.
   49 action
   50     :: Method -- ^ HTTP method to handle
   51     -> PathParser r -- ^ Path to handle (r holds the captured elements)
   52     -> (r -> a) -- ^ Action to build the response (a)
   53     -> R.RouteAction r a -- ^ The complete, built route/action specifier.
   54 action method path act =
   55     R.routePath path R.>* R.routeMethod method `R.RouteAction` act
   56 
   57 multipartAction :: R.RouteAction q a -> R.RouteAction q a
   58 multipartAction (R.RouteAction r a) =
   59   R.RouteAction (r R.>* (R.routeAccept "multipart/form-data" R.>| R.unit)) a
   60 
   61 data API
   62   = HTML
   63   | JSON
   64   deriving (Eq)
   65 
   66 pathHTML :: PathParser ()
   67 pathHTML = R.unit
   68 
   69 pathJSON :: PathParser ()
   70 pathJSON = "api"
   71 
   72 pathAPI :: PathParser API
   73 pathAPI = [I.biCase|Left () <-> JSON ; Right () <-> HTML|] R.>$< (pathJSON R.>|< pathHTML)