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)