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