1 {-# LANGUAGE ExistentialQuantification, RecordWildCards, ImpredicativeTypes, GeneralizedNewtypeDeriving #-} 2 module Databrary.HTTP.Route 3 ( Route 4 , routeURL 5 , routeURI 6 ) where 7 8 import Prelude hiding (lookup) 9 10 import qualified Data.ByteString.Builder as BSB 11 import qualified Data.ByteString.Char8 as BSC 12 import Data.Monoid ((<>)) 13 import Network.HTTP.Types (Query, simpleQueryToQuery, renderQuery) 14 import Network.URI (URI(..), nullURI) 15 import qualified Network.Wai as Wai 16 import qualified Web.Route.Invertible as R 17 import qualified Web.Route.Invertible.URI as R 18 import qualified Web.Route.Invertible.Internal as R 19 20 import Databrary.HTTP 21 import Databrary.HTTP.Request 22 23 type Route a r = R.RouteAction r a 24 25 routeURL :: Maybe Request -> R.Request -> Query -> BSB.Builder 26 routeURL w r q = bh (R.requestHost r) 27 <> encodePath' (R.requestPath r) 28 ((simpleQueryToQuery $ R.paramsQuerySimple $ R.requestQuery r) ++ q) 29 where 30 bh [] = foldMap (BSB.byteString . requestHost) w 31 bh [x] = BSB.byteString x 32 bh (x:l) = bh l <> BSB.char7 '.' <> BSB.byteString x 33 34 routeURI :: Maybe Wai.Request -> R.Request -> Query -> URI 35 routeURI req r q = (maybe nullURI requestURI req) 36 { uriPath = uriPath ruri 37 , uriQuery = BSC.unpack $ renderQuery True $ (simpleQueryToQuery $ R.paramsQuerySimple $ R.requestQuery r) ++ q 38 } where 39 ruri = R.requestURI r 40